|
Registriert seit: 14. Jan 2008
Ort: Russia
7 Beiträge
Delphi 7 Enterprise
|
Re: einfache Visualisierung mit bass.dll ??
23. Jan 2009, 10:57
I was a changed source code of TBassPlayer component. Maybe someone should. =)
So, can someone optimizes the current code. =)
Delphi-Quellcode:
unit F_Oscilloscope;
interface
uses
Windows, Messages, F_Constants, Bass;
const
{}
WM_MODESCOPE = WM_USER + 101;
{}
OSCSCOPE_NONE = 0;
OSCSCOPE_MODN = 1;
OSCSCOPE_FILL = 2;
OSCSCOPE_LINE = 3;
procedure Scope_Create(hWnd: Thandle);
procedure Scope_Delete;
function GetModeScop: DWORD;
implementation
type
TFFTData = Array [0..512] of Single;
TWavData = Array [0..2048] of DWORD;
var
TScopMode : WORD;
TViewUpdate: Integer;
iScopWidth : Integer;
iScopHeight: Integer;
hScopMemHdc: HDC;
hScopMemNew: hBitmap;
hScopMemOld: hBitmap;
hScopTmpHdc: HDC;
hScopTmpNew: hBitmap;
hScopTmpOld: hBitmap;
lpScope : TRect;
hThread : Cardinal;
hThreadId : Cardinal;
ScopOldProc: Pointer;
hControl : Thandle;
{}
function GetModeScop: DWORD;
begin
Result := TScopMode;
end;
procedure DisplayControlGrid( DC: HDC);
var
w: Integer;
h: Integer;
begin
SetPixel( DC, 0, 0, RGB(0, 0, 0));
SetPixel( DC, 1, 0, RGB(0, 0, 0));
SetPixel( DC, 1, 10, RGB(0, 0, 0));
SetPixel( DC, 0, 12, RGB(0, 0, 0));
SetPixel( DC, 1, 12, RGB(0, 0, 0));
SetPixel( DC, 1, 14, RGB(0, 0, 0));
SetPixel( DC, 0, 24, RGB(0, 0, 0));
SetPixel( DC, 1, 24, RGB(0, 0, 0));
for h := 0 to (iScopHeight - 3) do
if not Odd(h) then
SetPixel( DC, 2, h, RGB(0, 0, 0));
for h := 0 to (iScopHeight - 3) do
if not Odd(h) then
SetPixel( DC, iScopWidth - 3, h, RGB(0, 0, 0));
SetPixel( DC, iScopWidth - 1, 0, RGB(0, 0, 0));
SetPixel( DC, iScopWidth - 2, 0, RGB(0, 0, 0));
SetPixel( DC, iScopWidth - 2, 10, RGB(0, 0, 0));
SetPixel( DC, iScopWidth - 1, 12, RGB(0, 0, 0));
SetPixel( DC, iScopWidth - 2, 12, RGB(0, 0, 0));
SetPixel( DC, iScopWidth - 2, 14, RGB(0, 0, 0));
SetPixel( DC, iScopWidth - 1, 24, RGB(0, 0, 0));
SetPixel( DC, iScopWidth - 2, 24, RGB(0, 0, 0));
for w := 2 to (iScopWidth - 3) do
if not Odd(w) then
SetPixel( DC, w, iScopHeight - 3, RGB(0, 0, 0));
SetPixel( DC, 10, iScopHeight - 2, RGB(0, 0, 0));
SetPixel( DC, 10, iScopHeight - 1, RGB(0, 0, 0));
SetPixel( DC, 18, iScopHeight - 2, RGB(0, 0, 0));
SetPixel( DC, 26, iScopHeight - 2, RGB(0, 0, 0));
SetPixel( DC, 34, iScopHeight - 2, RGB(0, 0, 0));
SetPixel( DC, 44, iScopHeight - 2, RGB(0, 0, 0));
SetPixel( DC, 44, iScopHeight - 1, RGB(0, 0, 0));
SetPixel( DC, 54, iScopHeight - 2, RGB(0, 0, 0));
SetPixel( DC, 62, iScopHeight - 2, RGB(0, 0, 0));
SetPixel( DC, 70, iScopHeight - 2, RGB(0, 0, 0));
SetPixel( DC, 78, iScopHeight - 2, RGB(0, 0, 0));
SetPixel( DC, 78, iScopHeight - 1, RGB(0, 0, 0));
end;
procedure DisplayFFTWaveLines;
var
FFTData: TFFTData;
WavData: TWavData;
NewPen : HPEN;
OldPen : HPEN;
nIndex : WORD;
YPos : LongInt;
wRight : SmallInt;
wLeft : SmallInt;
xLine : WORD;
yLine : WORD;
ScopOff: WORD;
DrawRes: WORD;
begin
BitBlt(hScopMemHdc, 0, 0, iScopWidth, iScopHeight, hScopTmpHdc, 0, 0, SRCCOPY);
if (TScopMode = OSCSCOPE_MODN) then
begin
if (BASS_ChannelIsActive(sndChannel) = BASS_ACTIVE_PLAYING) then
begin
BASS_ChannelGetData(sndChannel, @FFTData, BASS_DATA_FFT512);
NewPen := CreatePen(PS_SOLID, 1, GetSysColor(COLOR_BTNFACE + 1));
OldPen := SelectObject(hScopMemHdc, NewPen);
for nIndex := 5 to (iScopWidth - 5) do
FFTData[nIndex] := FFTData[nIndex] * ln(nIndex + 1) * 3 * (iScopHeight - 10);
MoveToEx(hScopMemHdc, 5, (iScopHeight - 5) div 2, nil);
for nIndex := 5 to (iScopWidth - 5) do
LineTo(hScopMemHdc, nIndex, (iScopHeight - 5) div 2 - Round(FFTData[nIndex] / 3));
MoveToEx(hScopMemHdc, 5, (iScopHeight - 5) div 2, nil);
for nIndex := 5 to (iScopWidth - 5) do
LineTo(hScopMemHdc, nIndex, (iScopHeight - 5) div 2 + Round(FFTData[nIndex] / 3));
SelectObject(hScopMemHdc, OldPen);
DeleteObject(NewPen);
end
else
begin
for nIndex := 5 to (iScopWidth - 6) do
SetPixel(hScopMemHdc, nIndex, (iScopHeight - 5) div 2, GetSysColor(COLOR_BTNFACE + 10));
end;
end;
if (TScopMode = OSCSCOPE_FILL) then
begin
BASS_ChannelGetData(sndChannel, @WavData, 1024);
xLine := 10;
yLine := (iScopHeight - 5) div 2;
ScopOff := iScopHeight - 5;
DrawRes := 4;
NewPen := CreatePen(PS_SOLID, 1, GetSysColor(COLOR_BTNFACE + 10));
OldPen := SelectObject(hScopMemHdc, NewPen);
wRight := 0;
wLeft := 0;
YPos := 0;
MoveToEx(hScopMemHdc, xLine, yLine, nil);
for nIndex := 5 to (iScopWidth - 6) do
SetPixel(hScopMemHdc, nIndex, (iScopHeight - 5) div 2, GetSysColor(COLOR_BTNFACE + 10));
if (BASS_ChannelIsActive(sndChannel) = BASS_ACTIVE_PLAYING) then
begin
for nIndex := 5 to (iScopWidth - 24) do
begin
wRight := SmallInt(LoWord(WavData[nIndex * DrawRes]));
wLeft := SmallInt(HiWord(WavData[nIndex * DrawRes]));
YPos := Trunc( ((wRight + wLeft) / (65539 + (65539 / 3) )) * ScopOff );
MoveToEx(hScopMemHdc, xLine + nIndex, yLine, nil);
LineTo(hScopMemHdc, xLine + nIndex, yLine + YPos);
end;
end;
SelectObject(hScopMemHdc, OldPen);
DeleteObject(NewPen);
end;
if (TScopMode = OSCSCOPE_LINE) then
begin
BASS_ChannelGetData(sndChannel, @WavData, 1024);
xLine := 12;
yLine := (iScopHeight - 5) div 2;
ScopOff := iScopHeight - 5;
DrawRes := 4;
NewPen := CreatePen(PS_SOLID, 1, GetSysColor(COLOR_BTNFACE + 10));
OldPen := SelectObject(hScopMemHdc, NewPen);
wRight := 0;
wLeft := 0;
YPos := 0;
MoveToEx(hScopMemHdc, xLine, yLine, nil);
for nIndex := 5 to 11 do
SetPixel(hScopMemHdc, nIndex, yLine, GetSysColor(COLOR_BTNFACE + 10));
for nIndex := (iScopWidth - 12) to (iScopWidth - 6) do
SetPixel(hScopMemHdc, nIndex, yLine, GetSysColor(COLOR_BTNFACE + 10));
if (BASS_ChannelIsActive(sndChannel) = BASS_ACTIVE_PLAYING) then
begin
for nIndex := 5 to (iScopWidth - 24) do
begin
wRight := SmallInt(LoWord(WavData[nIndex * DrawRes]));
wLeft := SmallInt(HiWord(WavData[nIndex * DrawRes]));
YPos := Trunc( ((wRight + wLeft) / (65539 + (65535 / 2))) * ScopOff );
LineTo(hScopMemHdc, xLine + nIndex, yLine + YPos);
end;
end
else
begin
for nIndex := 5 to (iScopWidth - 6) do
SetPixel(hScopMemHdc, nIndex, (iScopHeight - 5) div 2, GetSysColor(COLOR_BTNFACE + 10));
end;
SelectObject(hScopMemHdc, OldPen);
DeleteObject(NewPen);
end;
end;
function ScopNewProc(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
PS: TPaintStruct;
begin
Result := 0;
case uMsg of
{}
WM_PAINT:
begin
BeginPaint(hWnd, PS);
BitBlt(PS.HDC, 0, 0, iScopWidth, iScopHeight, hScopMemHdc, 0, 0, SRCCOPY);
EndPaint(hWnd, PS);
end;
{}
WM_MODESCOPE:
TScopMode := (TScopMode + 1) mod 4;
else
Result := CallWindowProcW(ScopOldProc, hWnd, uMsg, wParam, lParam);
end;
end;
function OscilloscopeThread(lParam: Pointer): DWORD; stdcall;
begin
SetThreadPriority(hThread, THREAD_PRIORITY_NORMAL);
while TRUE do
begin
InvalidateRect(hControl, nil, FALSE);
Sleep(45);
GetClientRect(hControl, lpScope);
FillRect(hScopTmpHdc, lpScope, HBRUSH(COLOR_BTNFACE + 10));
// if BASS_ChannelGetData(sndChannel, @FFTData, BASS_DATA_FFT512) = $FFFFFFFF then
// if (BASS_ChannelIsActive(sndChannel) = BASS_ACTIVE_PLAYING) then
DisplayFFTWaveLines;
DisplayControlGrid(hScopMemHdc);
end;
Result := 0;
end;
procedure Scope_Create(hWnd: Thandle);
var
hTmpDC: HDC;
begin
{ получаем хэндл прорисовываемого элемента }
hControl := hWnd;
{}
iScopWidth := 89;
iScopHeight := 29;
{}
hTmpDC := GetDC(0);
hScopMemHdc := CreateCompatibleDC(hTmpDC);
hScopMemNew := CreateCompatibleBitmap(hTmpDC, iScopWidth, iScopHeight);
ReleaseDC(0, hTmpDC);
hScopMemOld := SelectObject(hScopMemHdc, hScopMemNew);
{}
hTmpDC := GetDC(0);
hScopTmpHdc := CreateCompatibleDC(hTmpDC);
hScopTmpNew := CreateCompatibleBitmap(hTmpDC, iScopWidth, iScopHeight);
ReleaseDC(0, hTmpDC);
hScopTmpOld := SelectObject(hScopTmpHdc, hScopTmpNew);
{}
SetWindowPos(hControl, 0, 0, 0, iScopWidth, iScopHeight, SWP_NOMOVE);
{}
hThread := CreateThread( nil, 0, @OscilloscopeThread, nil, 0, hThreadId);
{}
ScopOldProc := Pointer(SetWindowLongW(hControl, GWL_WNDPROC, LongInt(@ScopNewProc)));
end;
procedure Scope_Delete;
var
ExitCode: Cardinal;
begin
{}
GetExitCodeThread(hThread, ExitCode);
TerminateThread(hThread, ExitCode);
{}
SetWindowLongW(hControl, GWL_WNDPROC, LongInt(ScopOldProc));
{}
SelectObject(hScopMemHdc, hScopMemOld);
DeleteObject(hScopMemNew);
DeleteDC(hScopMemHdc);
{}
SelectObject(hScopTmpHdc, hScopTmpOld);
DeleteObject(hScopTmpNew);
DeleteDC(hScopTmpHdc);
end;
end.
Delphi-Quellcode:
unit F_Spectrum;
interface
uses
Windows, Messages, F_Constants, Bass;
const
{}
WM_MODESPECT = WM_USER + 101;
WM_SPEEDSPECT = WM_USER + 102;
{}
SPECTRUM_NONE = 0;
SPECTRUM_FILL = 1;
SPECTRUM_GRID = 2;
SPECTRUM_LINE = 3;
procedure Spectrum_Create(hWnd: Thandle);
procedure Spectrum_Delete;
function GetSpectrumMode: Integer;
procedure SetSpectrumMode(uMode: Integer);
implementation
const
{ число рисуемых линий }
BandsCount = 20;
{ ширина рисуемых линий }
BlockWidth = 3;
{ высота рисуемых линий }
BlockHeight = 25;
{ пространство между линиями }
BlockFillGap = 1;
{ число рисуемых блоков }
BlockCount = BandsCount;
type
TFFTData = Array [0..512] of Single;
TBandOut = Array [0..BandsCount - 1] of WORD;
var
TSpecMode : Integer;
TViewUpdate: Integer;
iSpecWidth : Integer;
iSpecHeight: Integer;
hSpecMemHdc: HDC;
hSpecMemNew: hBitmap;
hSpecMemOld: hBitmap;
hSpecTmpHdc: HDC;
hSpecTmpNew: hBitmap;
hSpecTmpOld: hBitmap;
hSpecBmpBar: hBitmap;
PeakValue : Array [1..BandsCount] of Single;
PassCount : Array [1..BandsCount] of Integer;
BandOut : TBandOut;
lpSpect : TRect;
hThread : Cardinal;
hThreadId : Cardinal;
SpecOldProc: Pointer;
hControl : Thandle;
FFTData : TFFTData;
{}
function GetSpectrumMode: Integer;
begin
Result := TSpecMode;
end;
{}
procedure SetSpectrumMode(uMode: Integer);
begin
TSpecMode := uMode;
end;
procedure DisplayControlGrid( DC: HDC);
var
w: Integer;
h: Integer;
begin
SetPixel( DC, 0, 0, RGB(0, 0, 0));
SetPixel( DC, 1, 0, RGB(0, 0, 0));
SetPixel( DC, 1, 10, RGB(0, 0, 0));
SetPixel( DC, 0, 12, RGB(0, 0, 0));
SetPixel( DC, 1, 12, RGB(0, 0, 0));
SetPixel( DC, 1, 14, RGB(0, 0, 0));
SetPixel( DC, 0, 24, RGB(0, 0, 0));
SetPixel( DC, 1, 24, RGB(0, 0, 0));
for h := 0 to (iSpecHeight - 3) do
if not Odd(h) then
SetPixel( DC, 2, h, RGB(0, 0, 0));
for h := 0 to (iSpecHeight - 3) do
if not Odd(h) then
SetPixel( DC, iSpecWidth - 3, h, RGB(0, 0, 0));
SetPixel( DC, iSpecWidth - 1, 0, RGB(0, 0, 0));
SetPixel( DC, iSpecWidth - 2, 0, RGB(0, 0, 0));
SetPixel( DC, iSpecWidth - 2, 10, RGB(0, 0, 0));
SetPixel( DC, iSpecWidth - 1, 12, RGB(0, 0, 0));
SetPixel( DC, iSpecWidth - 2, 12, RGB(0, 0, 0));
SetPixel( DC, iSpecWidth - 2, 14, RGB(0, 0, 0));
SetPixel( DC, iSpecWidth - 1, 24, RGB(0, 0, 0));
SetPixel( DC, iSpecWidth - 2, 24, RGB(0, 0, 0));
for w := 2 to (iSpecWidth - 3) do
if not Odd(w) then
SetPixel( DC, w, iSpecHeight - 3, RGB(0, 0, 0));
SetPixel( DC, 10, iSpecHeight - 2, RGB(0, 0, 0));
SetPixel( DC, 10, iSpecHeight - 1, RGB(0, 0, 0));
SetPixel( DC, 18, iSpecHeight - 2, RGB(0, 0, 0));
SetPixel( DC, 26, iSpecHeight - 2, RGB(0, 0, 0));
SetPixel( DC, 34, iSpecHeight - 2, RGB(0, 0, 0));
SetPixel( DC, 44, iSpecHeight - 2, RGB(0, 0, 0));
SetPixel( DC, 44, iSpecHeight - 1, RGB(0, 0, 0));
SetPixel( DC, 54, iSpecHeight - 2, RGB(0, 0, 0));
SetPixel( DC, 62, iSpecHeight - 2, RGB(0, 0, 0));
SetPixel( DC, 70, iSpecHeight - 2, RGB(0, 0, 0));
SetPixel( DC, 78, iSpecHeight - 2, RGB(0, 0, 0));
SetPixel( DC, 78, iSpecHeight - 1, RGB(0, 0, 0));
end;
procedure DisplayRectGridline( DC: HDC);
var
w: Integer;
h: Integer;
begin
if (GetSpectrumMode = SPECTRUM_GRID) then
begin
for w := 5 to (iSpecWidth - 6) do
for h := 0 to (iSpecHeight - 5) do
if Odd(h) then
SetPixel( DC, w, h, GetSysColor(COLOR_BTNFACE + 9));
end;
end;
procedure DisplayFFTBand(Bands: TBandOut);
var
TmpRect: TRect;
BarRect: TRect;
jBands : Integer;
NewPen : HPEN;
OldPen : HPEN;
nIndex : Integer;
begin
BitBlt(hSpecMemHdc, 0, 0, iSpecWidth, iSpecHeight, hSpecTmpHdc, 0, 0, SRCCOPY);
if (GetSpectrumMode = SPECTRUM_FILL) or (GetSpectrumMode = SPECTRUM_GRID) then
begin
for jBands := 1 to BlockCount do
begin
if Bands[jBands - 1] > BlockHeight then
Bands[jBands - 1] := BlockHeight;
if Bands[jBands - 1] > 0 then
begin
BarRect.Left := 0;
BarRect.Right := BlockWidth;
BarRect.Top := BlockHeight - Bands[jBands - 1];
if BarRect.Top < 0 then
BarRect.Top := 0;
BarRect.Bottom := BlockHeight;
TmpRect.Left := (BlockWidth + BlockFillGap) * (jBands - 1) + 5;
TmpRect.Right := TmpRect.Left + BlockWidth;
TmpRect.Top := BarRect.Top;
TmpRect.Bottom := BarRect.Bottom;
SelectObject(hSpecTmpHdc, hSpecBmpBar);
BitBlt(hSpecMemHdc, TmpRect.Left, TmpRect.Top, BlockWidth, TmpRect.Bottom - TmpRect.Top + 1, hSpecTmpHdc, BarRect.Left, BarRect.Top, SRCCOPY);
SelectObject(hSpecTmpHdc, hSpecTmpNew);
end;
if Bands[jBands - 1] >= Trunc(PeakValue[jBands]) then
begin
PeakValue[jBands] := Bands[jBands - 1] + 0.01;
PassCount[jBands] := 0;
end
else
if Bands[jBands - 1] < Trunc(PeakValue[jBands]) then
begin
if Trunc(PeakValue[jBands]) > 0 then
begin
NewPen := CreatePen(PS_SOLID, 1, GetSysColor(COLOR_BTNFACE + 1));
OldPen := SelectObject(hSpecMemHdc, NewPen);
MoveToEx(hSpecMemHdc, (BlockWidth + BlockFillGap) * jBands + 3, BlockHeight - Trunc(PeakValue[jBands]), nil);
LineTo(hSpecMemHdc, (BlockWidth + BlockFillGap) * (jBands - 1) + 1 + BlockWidth, BlockHeight - Trunc(PeakValue[jBands]));
SelectObject(hSpecMemHdc, OldPen);
DeleteObject(NewPen);
if PassCount[jBands] >= 8 then
PeakValue[jBands] := PeakValue[jBands] - 0.3 * (PassCount[jBands] - 8);
if PeakValue[jBands] <= 3 then
PeakValue[jBands] := 1 {0}
else
Inc(PassCount[jBands]);
end;
end;
end;
end;
if (GetSpectrumMode = SPECTRUM_LINE) then
begin
NewPen := CreatePen(PS_SOLID, 1, GetSysColor(COLOR_BTNFACE + 10));
OldPen := SelectObject(hSpecMemHdc, NewPen);
if (BASS_ChannelIsActive(sndChannel) = BASS_ACTIVE_PLAYING) then
for nIndex := 5 to (iSpecWidth - 6) do
begin
MoveToEx(hSpecMemHdc, nIndex, iSpecHeight - 5, nil);
LineTo(hSpecMemHdc, nIndex, (iSpecHeight - 5) - Round(FFTData[nIndex] * (iSpecHeight - 5) * nIndex));
end
else
for nIndex := 5 to (iSpecWidth - 6) do
begin
MoveToEx(hSpecMemHdc, nIndex, iSpecHeight - 5, nil);
LineTo(hSpecMemHdc, nIndex, (iSpecHeight - 5));
end;
SelectObject(hSpecMemHdc, OldPen);
DeleteObject(NewPen);
end;
end;
function SpecNewProc(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
PS: TPaintStruct;
begin
Result := 0;
case uMsg of
{}
WM_PAINT:
begin
BeginPaint(hWnd, PS);
BitBlt(PS.HDC, 0, 0, iSpecWidth, iSpecHeight, hSpecMemHdc, 0, 0, SRCCOPY);
EndPaint(hWnd, PS);
end;
{}
WM_SPEEDSPECT:
TViewUpdate := lParam;
{}
WM_MODESPECT:
SetSpectrumMode((GetSpectrumMode + 1) mod 4);
else
Result := CallWindowProcW(SpecOldProc, hWnd, uMsg, wParam, lParam);
end;
end;
function SpectrumThread(lParam: Pointer): DWORD; stdcall;
const
cFreq: Array [0..BandsCount - 1] of WORD = (1, 2, 3, 6, 12, 18, 24, 30, 36, 42, 48, 54, 60, 66, 72, 78, 84, 90, 96, 102);
Boost = 0.15;
Scale = 80;
var
NewBand : TBandOut;
StartIdx: Integer;
BandsIdx: Integer;
FreqIdx : Integer;
Intensit: Double;
begin
SetThreadPriority(hThread, THREAD_PRIORITY_NORMAL);
while TRUE do
begin
{}
InvalidateRect(hControl, nil, FALSE);
{}
Sleep(TViewUpdate);
{}
if (BASS_ChannelIsActive(sndChannel) = BASS_ACTIVE_PLAYING) then
begin
if BASS_ChannelGetData(sndChannel, @FFTData, BASS_DATA_FFT512) = $FFFFFFFF then
for BandsIdx := 0 to (BandsCount - 1) do
BandOut[BandsIdx] := 0;
for BandsIdx := 0 to (BandsCount - 1) do
begin
if BandsIdx = 0 then
StartIdx := 1
else
StartIdx := cFreq[BandsIdx - 1] + 1;
Intensit := 0;
for FreqIdx := StartIdx to cFreq[BandsIdx] do
if FFTData[FreqIdx] > Intensit then
Intensit := FFTData[FreqIdx];
NewBand[BandsIdx] := Round(Intensit * (1 + BandsIdx * Boost) * Scale);
if NewBand[BandsIdx] > BandOut[BandsIdx] then
BandOut[BandsIdx] := NewBand[BandsIdx]
else
if BandOut[BandsIdx] >= 2 then
Dec(BandOut[BandsIdx], 2)
else
BandOut[BandsIdx] := 0;
if NewBand[BandsIdx] > BandOut[BandsIdx] then
BandOut[BandsIdx] := NewBand[BandsIdx];
end;
end
else
begin
for BandsIdx := 0 to (BandsCount - 1) do
BandOut[BandsIdx] := 1 {0};
end;
{}
FillRect(hSpecTmpHdc, lpSpect, HBRUSH(COLOR_BTNFACE + 10));
{}
DisplayFFTBand(BandOut);
DisplayControlGrid(hSpecMemHdc);
{}
if (BASS_ChannelIsActive(sndChannel) = BASS_ACTIVE_PLAYING) then
DisplayRectGridline(hSpecMemHdc);
end;
Result := 0;
end;
procedure Spectrum_Create(hWnd: Thandle);
var
ValueIdx: Integer;
OldBrush: HBRUSH;
NewBrush: HBRUSH;
hTmpDC : HDC;
begin
{ получаем хэндл прорисовываемого элемента }
hControl := hWnd;
{}
iSpecWidth := (BlockWidth + BlockFillGap) * BlockCount - BlockFillGap + 10;
iSpecHeight := BlockHeight + 4;
{}
hTmpDC := GetDC(0);
hSpecMemHdc := CreateCompatibleDC(hTmpDC);
hSpecMemNew := CreateCompatibleBitmap(hTmpDC, iSpecWidth, iSpecHeight);
ReleaseDC(0, hTmpDC);
hSpecMemOld := SelectObject(hSpecMemHdc, hSpecMemNew);
{}
hTmpDC := GetDC(0);
hSpecTmpHdc := CreateCompatibleDC(hTmpDC);
hSpecTmpNew := CreateCompatibleBitmap(hTmpDC, iSpecWidth, iSpecHeight);
ReleaseDC(0, hTmpDC);
hSpecTmpOld := SelectObject(hSpecTmpHdc, hSpecTmpNew);
{}
hTmpDC := GetDC(0);
hSpecBmpBar := CreateCompatibleBitmap(hTmpDC, BlockWidth, BlockHeight);
ReleaseDC(0, hTmpDC);
{}
for ValueIdx := 0 to (BlockHeight - 1) do
begin
NewBrush := CreateSolidBrush(GetSysColor(COLOR_BTNFACE + 10));
SelectObject(hSpecTmpHdc, hSpecBmpBar);
OldBrush := SelectObject(hSpecTmpHdc, NewBrush);
lpSpect.Left := 0;
lpSpect.Top := ValueIdx;
lpSpect.Right := BlockWidth;
lpSpect.Bottom := ValueIdx + 1;
FillRect(hSpecTmpHdc, lpSpect, NewBrush);
SelectObject(hSpecTmpHdc, OldBrush);
DeleteObject(NewBrush);
SelectObject(hSpecTmpHdc, hSpecTmpNew);
end;
{}
SetWindowPos(hControl, 0, 0, 0, iSpecWidth, iSpecHeight, SWP_NOMOVE);
{}
GetClientRect(hControl, lpSpect);
{}
hThread := CreateThread( nil, 0, @SpectrumThread, nil, 0, hThreadId);
{}
SpecOldProc := Pointer(SetWindowLongW(hControl, GWL_WNDPROC, LongInt(@SpecNewProc)));
end;
procedure Spectrum_Delete;
var
ExitCode: Cardinal;
begin
{}
GetExitCodeThread(hThread, ExitCode);
TerminateThread(hThread, ExitCode);
{}
SetWindowLongW(hControl, GWL_WNDPROC, LongInt(SpecOldProc));
{}
SelectObject(hSpecMemHdc, hSpecMemOld);
DeleteObject(hSpecMemNew);
DeleteDC(hSpecMemHdc);
{}
SelectObject(hSpecTmpHdc, hSpecTmpOld);
DeleteObject(hSpecTmpNew);
DeleteDC(hSpecTmpHdc);
{}
DeleteObject(hSpecBmpBar);
end;
end.
Delphi-Quellcode:
unit F_Vumeter;
interface
uses
Windows, Messages, F_Constants, Bass;
const
{ установка скорости обновления }
WM_SPEEDMETER = WM_USER + 893;
procedure Vumeter_Create(hWnd: Thandle);
procedure Vumeter_Delete;
implementation
var
TMetUpdate : Integer;
iVmetWidth : Integer;
iVmetHeight: Integer;
hVmetMemHdc: HDC;
hVmetMemNew: hBitmap;
hVmetMemOld: hBitmap;
hThread : Cardinal;
hThreadId : Cardinal;
lpVmeter : TRect;
VmetOldProc: Pointer;
hControl : Thandle;
{}
procedure GetVuMeterLevel( var LeftChan, RightChan: DWORD);
var
VUCH: DWORD;
L_VU: DWORD;
R_VU: DWORD;
begin
VUCH := BASS_ChannelGetLevel(sndChannel);
L_VU := LoWord(VUCH);
R_VU := HiWord(VUCH);
if (BASS_ChannelIsActive(sndChannel) = BASS_ACTIVE_PLAYING) then
begin
LeftChan := L_VU;
RightChan := R_VU;
end
else
begin
LeftChan := 0;
RightChan := 0;
end;
end;
{}
procedure DisplayVmetGrid( DC: HDC);
var
w : DWORD;
h : DWORD;
LeftBASS : DWORD;
RightBASS: DWORD;
NewBrush : HBRUSH;
OldBrush : HBRUSH;
NewPen : HPEN;
OldPen : HPEN;
begin
//
GetVuMeterLevel(LeftBASS, RightBASS);
LeftBASS := (LeftBASS * 100) div 32768;
if LeftBASS >= 100 then
LeftBASS := Trunc((iVmetWidth - 2) - ((iVmetWidth - 2) * 0.1));
RightBASS := (RightBASS * 100) div 32768;
if RightBASS >= 100 then
RightBASS := Trunc((iVmetWidth - 2) - ((iVmetWidth - 2) * 0.1));
NewBrush := CreateSolidBrush(GetSysColor(COLOR_BTNFACE + 2));
OldBrush := SelectObject( DC, NewBrush);
NewPen := CreatePen(PS_SOLID, 1, GetSysColor(COLOR_BTNFACE + 9));
OldPen := SelectObject( DC, NewPen);
Rectangle( DC, 1, 1, LeftBASS, 4);
Rectangle( DC, 1, 5, RightBASS, 8);
SelectObject( DC, OldBrush);
DeleteObject(NewBrush);
SelectObject( DC, OldPen);
DeleteObject(NewPen);
// top
for w := 0 to iVmetWidth do
if not Odd(w) then
SetPixel( DC, w, 0, RGB(240, 240, 255));
// bottom
for w := 0 to iVmetWidth do
if not Odd(w) then
SetPixel( DC, w, iVmetHeight - 1, RGB(240, 240, 255));
// center
for w := 0 to iVmetWidth do
if not Odd(w) then
SetPixel( DC, w, 4, RGB(240, 240, 255));
// left
for h := 0 to (iVmetHeight - 0) do
if not Odd(h) then
SetPixel( DC, 0, h, RGB(240, 240, 255));
// right
for h := 0 to (iVmetHeight - 0) do
if not Odd(h) then
SetPixel( DC, iVmetWidth - 1, h, RGB(240, 240, 255));
end;
{}
function VmetNewProc(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM) : LRESULT; stdcall;
var
PS: TPaintStruct;
begin
Result := 0;
case uMsg of
{}
WM_SPEEDMETER:
TMetUpdate := lParam;
{}
WM_PAINT:
begin
BeginPaint(hWnd, PS);
BitBlt(PS.HDC, 0, 0, iVmetWidth, iVmetHeight, hVmetMemHdc, 0, 0, SRCCOPY);
EndPaint(hWnd, PS);
end;
else
Result := CallWindowProcW(VmetOldProc, hWnd, uMsg, wParam, lParam);
end;
end;
{}
function VumeterThread(lParam: Pointer): DWORD; stdcall;
begin
SetThreadPriority(hThread, THREAD_PRIORITY_NORMAL);
while TRUE do
begin
InvalidateRect(hControl, nil, FALSE);
Sleep(TMetUpdate);
FillRect(hVmetMemHdc, lpVmeter, HBRUSH(COLOR_BTNFACE + 10));
DisplayVmetGrid(hVmetMemHdc);
end;
Result := 0;
end;
{}
procedure Vumeter_Create(hWnd: Thandle);
var
hTmpDC: HDC;
begin
{}
hControl := hWnd;
{}
iVmetWidth := 90;
iVmetHeight := 9;
{}
hTmpDC := GetDC(0);
hVmetMemHdc := CreateCompatibleDC(hTmpDC);
hVmetMemNew := CreateCompatibleBitmap(hTmpDC, iVmetWidth, iVmetHeight);
ReleaseDC(0, hTmpDC);
hVmetMemOld := SelectObject(hVmetMemHdc, hVmetMemNew);
{}
SetWindowPos(hControl, 0, 0, 0, iVmetWidth, iVmetHeight, SWP_NOMOVE);
{}
GetClientRect(hControl, lpVmeter);
{}
hThread := CreateThread( nil, 0, @VumeterThread, nil, 0, hThreadId);
{}
VmetOldProc := Pointer(SetWindowLongW(hControl, GWL_WNDPROC, LongInt(@VmetNewProc)));
end;
{}
procedure Vumeter_Delete;
var
ExitCode: Cardinal;
begin
{}
GetExitCodeThread(hThread, ExitCode);
TerminateThread(hThread, ExitCode);
{}
SetWindowLongW(hControl, GWL_WNDPROC, LongInt(VmetOldProc));
{}
SelectObject(hVmetMemHdc, hVmetMemOld);
DeleteObject(hVmetMemNew);
DeleteDC(hVmetMemHdc);
end;
end.
|