兼通VB与DELPHI的高人：delphi做不出vb这样的效果？！

[sghff110]

一个音频波形图，分别有VB与DELPHI的演示程序，delphi却做不出VB的效果(delphi为单色，vb为彩色)！
由于代码较多，不方便在这里贴出，请有兴趣的高手联系（QQ：729851670）我，我把两个演示程序发给你，以便对比研究。

[onlyou13]

只能说你做不出来我做不出来，不能说delphi做不出来

[hongss]

不同的开发平台而已

[haitao]

类似winamp的显示效果？好像早版本的winamp就是delphi做的吧

[cntigercat]

[Quote=引用 4 楼 onlyou13 的回复:]

只能说你做不出来我做不出来，不能说delphi做不出来
[/Quote]

[sghff110]

[Quote=引用 6 楼 sailxia 的回复:]
Bass 里面不是自带了Delphi 例子么？
[/Quote]

问题就是delphi自带的例子缺乏vb自带例子的效果——一个渐变的红色镶边。感觉很酷。

[sghff110]

bass.dll自带的演示中的有关部分：
‘-----------vb模块------------------
Option Explicit

Public Const BI_RGB = 0&
Public Const DIB_RGB_COLORS = 0& ' color table in RGBs

Public Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type

Public Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type

Public Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors(255) As RGBQUAD
End Type

Public Declare Function SetDIBitsToDevice Lib "gdi32.dll" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long

Public Const TRANSPARENT = 1
Public Const TA_LEFT = 0
Public Const TA_RIGHT = 2

Public Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Public Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Public Declare Function SetTextAlign Lib "gdi32" (ByVal hdc As Long, ByVal wFlags As Long) As Long
Public Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long

Public Const WIDTH_ = 600 ' display width
Public Const HEIGHT_ = 201 ' height (odd number for centre line)
Public bpp As Long ' stream bytes per pixel
Public loop_(2) As Long ' loop start & end
Public lsync As Long ' looping sync
Public killscan As Boolean

Public wavebuf() As Byte ' wave buffer
Public chan As Long ' stream/music handle

Public bh As BITMAPINFO ' bitmap header !!!!

Sub LoopSyncProc(ByVal handle As Long, ByVal channel As Long, ByVal data As Long, ByVal user As Long)
If (BASS_ChannelSetPosition(channel, loop_(0), BASS_POS_BYTE) = 0) Then ' try seeking to loop start
Call BASS_ChannelSetPosition(channel, 0, BASS_POS_BYTE) ' failed, go to start of file instead
End If
End Sub

Function PlayFile() As Boolean
On Local Error Resume Next ' if Cancel pressed...

With frmCustLoop.cmdCustLoop
.CancelError = True
.flags = cdlOFNExplorer Or cdlOFNFileMustExist Or cdlOFNHideReadOnly
.DialogTitle = "Select a file to play"
.Filter = "Playable files|*.mp3;*.mp2;*.mp1;*.ogg;*.wav;*.aif;*.mo3;*.it;*.xm;*.s3m;*.mtm;*.mod;*.umx|All files|*.*"
.ShowOpen

' if cancel was pressed, exit the procedure
If Err.Number = 32755 Then Exit Function

chan = BASS_StreamCreateFile(BASSFALSE, StrPtr(.filename), 0, 0, 0)
If (chan = 0) Then chan = BASS_MusicLoad(BASSFALSE, StrPtr(.filename), 0, 0, BASS_MUSIC_RAMPS Or BASS_MUSIC_POSRESET Or BASS_MUSIC_PRESCAN, 0)

If (chan = 0) Then
Call Error_("Can't play file")
PlayFile = False ' Can't load the file
Exit Function
End If

frmCustLoop.Show ' show form
With bh.bmiHeader
.biSize = Len(bh.bmiHeader)
.biWidth = WIDTH_
.biHeight = -HEIGHT_
.biPlanes = 1
.biBitCount = 8
.biClrUsed = HEIGHT_ / 2 + 1
.biClrImportant = HEIGHT_ / 2 + 1
End With

' setup palette
Dim a As Byte

For a = 1 To HEIGHT_ / 2
bh.bmiColors(a).rgbRed = (255 * a) / (HEIGHT_ / 2)
bh.bmiColors(a).rgbGreen = 255 - bh.bmiColors(a).rgbRed
Next a
End With
PlayFile = True
End Function


//------------------delphi有关部分----------
var
Buffer:TBitmap;
procedure TForm1.DrawSpectrum; //Spectrum 频谱 波形图
var
i,ht : integer;
begin
//clear background
Buffer.Canvas.Brush.Color := clBlack;
Buffer.Canvas.FillRect(Rect(0,0,Buffer.Width,Buffer.Height));

//draw peaks :峰值
ht := ClientHeight div 2;
for i:=0 to length(wavebufL)-1 do
begin
Buffer.Canvas.MoveTo(i,ht);
Buffer.Canvas.Pen.Color := clLime;//中线上
Buffer.Canvas.LineTo(i,ht-trunc((wavebufL[i]/32768)*ht));
Buffer.Canvas.Pen.Color :=clLime; //中线下
Buffer.Canvas.MoveTo(i,ht+2);
Buffer.Canvas.LineTo(i,ht+2+trunc((wavebufR[i]/32768)*ht));
end;
end;

怎样把vb代码中有关Public bh As BITMAPINFO 的部分通过何种方式融进delphi?

[Frank.WU]

Bass 里面不是自带了Delphi 例子么？

[haitao]

颜色的差别：

bh.bmiColors(a).rgbRed = (255 * a) / (HEIGHT_ / 2)
bh.bmiColors(a).rgbGreen = 255 - bh.bmiColors(a).rgbRed


Buffer.Canvas.Pen.Color := clLime;//中线上
Buffer.Canvas.LineTo(i,ht-trunc((wavebufL[i]/32768)*ht));
Buffer.Canvas.Pen.Color :=clLime; //中线下

[sghff110]

[Quote=引用 7 楼 sz_haitao 的回复:]
颜色的差别：

bh.bmiColors(a).rgbRed = (255 * a) / (HEIGHT_ / 2)
bh.bmiColors(a).rgbGreen = 255 - bh.bmiColors(a).rgbRed


Buffer.Canvas.Pen.Color := clLime;//中线上
Buffer.Canvas.LineTo(i,ht-tr……
[/Quote]
大师：我业余学习编程，对delphi掌握很浅薄，vb更是刚刚接触，解决这个问题可能就是小青蛙想吃天鹅肉（莫笑呀）。有关Vb颜色差别的代码以及它前边的类到delphi应如何处理？怎么把它的有关功能弄进delphi的Buffer（TBitmap）中？能否详细给个思路

[haitao]

就是并凑3种原色为实际颜色：
Buffer.Canvas.Pen.Color := rgb((255 * a) / (HEIGHT_ / 2) , 255 - bh.bmiColors(a).rgbRed ,255);
关键是vb里的a、HEIGHT_要找到对应
a好像是坐标，HEIGHT_好像是测到的数值？

[Frank.WU]

[Quote=引用 8 楼 sghff110 的回复:]

引用 7 楼 sz_haitao 的回复:
颜色的差别：

bh.bmiColors(a).rgbRed = (255 * a) / (HEIGHT_ / 2)
bh.bmiColors(a).rgbGreen = 255 - bh.bmiColors(a).rgbRed


Buffer.Canvas.Pen.Color := clLime;//中线上
Buffer.Canva……
[/Quote]我在 6 楼已经说的很清楚

[zenva]

没有Delphi做不出的效果！

[Frank.WU]

这个就是 bass 自带的 delphi 效果，和 VB 的相比较有什么区别么？

[sghff110]

to sailxia
(小帆)
:
感谢您的耐心指点。但我指的是"custloop”演示例程，请您试一下，它没有vb例程的红色镶边，通体一个颜色（缺省为绿色）。

[sghff110]

有人能让delphi的"custloop”演示例程加入像VB例程那样的红色镶边吗？鄙人愿付费。
（myQQ；729851670）

[xamlooc]

是人做不出来，不是delphi做不出来好不好

[sergery]

不要随便下结论

[qianchuan2010]

人做不出来

[sghff110]

各位咬定delphi能做，言之凿凿，可有谁尝试一下？所谓口惠而实不至嘛！

[不得闲]

[Quote=引用 16 楼 sghff110 的回复:]

有人能让delphi的"custloop”演示例程加入像VB例程那样的红色镶边吗？鄙人愿付费。
（myQQ；729851670）
[/Quote]
你要怎么画还不是随你自己，哎怎么画怎么画，你画一票鸡鸡都行！