bass.dll自带的演示中的有关部分: ‘-----------vb模块------------------ Option ExplicitPublic Const BI_RGB = 0& Public Const DIB_RGB_COLORS = 0& ' color table in RGBsPublic 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 TypePublic Type RGBQUAD rgbBlue As Byte rgbGreen As Byte rgbRed As Byte rgbReserved As Byte End TypePublic Type BITMAPINFO bmiHeader As BITMAPINFOHEADER bmiColors(255) As RGBQUAD End TypePublic 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 LongPublic Const TRANSPARENT = 1 Public Const TA_LEFT = 0 Public Const TA_RIGHT = 2Public 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 LongPublic 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 BooleanPublic wavebuf() As Byte ' wave buffer Public chan As Long ' stream/music handlePublic 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 SubFunction 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?
‘-----------vb模块------------------
Option ExplicitPublic Const BI_RGB = 0&
Public Const DIB_RGB_COLORS = 0& ' color table in RGBsPublic 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 TypePublic Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End TypePublic Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors(255) As RGBQUAD
End TypePublic 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 LongPublic Const TRANSPARENT = 1
Public Const TA_LEFT = 0
Public Const TA_RIGHT = 2Public 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 LongPublic 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 BooleanPublic wavebuf() As Byte ' wave buffer
Public chan As Long ' stream/music handlePublic 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 SubFunction 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?
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; //中线下
Buffer.Canvas.Pen.Color := rgb((255 * a) / (HEIGHT_ / 2) , 255 - bh.bmiColors(a).rgbRed ,255);
关键是vb里的a、HEIGHT_要找到对应
a好像是坐标,HEIGHT_好像是测到的数值?
问题就是delphi自带的例子缺乏vb自带例子的效果——一个渐变的红色镶边。感觉很酷。
(小帆)
:
感谢您的耐心指点。但我指的是"custloop”演示例程,请您试一下,它没有vb例程的红色镶边,通体一个颜色(缺省为绿色)。
(myQQ;729851670)