Inspired =)
Профиль
Группа: Экс. модератор
Сообщений: 1535
Регистрация: 7.5.2005
Репутация: 4
Всего: 191
|
Разобрал свой плеер | Код |
program Spectrum;
{ Tested with BASS 2.3.0.3 }
{ Author: rrader =) }
uses Windows, Messages, ShellApi, Bass;
{$R Spectrum.res}
{$WARNINGS OFF}
const
RES_DIALOG = 101;
ID_SPECTRUM = 101;
ID_PLAYING = 102;
ID_STOPPING = 103;
{ Number Of Bands For Spectrum Visualization }
NumFFTBands = 25;
{ Number Of Bands For Equalizer }
NumEQBands = 10;
{ For Spectrum Analyzer }
BlockWidth = 3;
HBlockGap = 1;
HBlockCount = NumFFTBands;
VLimit = 24;
var
hApp: Cardinal;
MemDC, TmpDC: HDC;
SpecPS: TPaintStruct;
SpecDC: HDC;
BasicBMP, OldBasicBMP: HBitmap;
GaugeTempBMP, OldTmpBMP: HBitmap;
DisplayBar: HBitmap;
GaugeRect, ClientRect: TRect;
MyVar1: Integer = 768;
MyVar2: Integer = 768;
PeakValue: array[1..NumFFTBands] of Single;
PassedCounter: array[1..NumFFTBands] of Integer;
type
TFFTData = array [0..512] of Single;
TBandOut = array[0..NumFFTBands - 1] of Word;
{ Current State }
TPlayerMode = (plmStandby, plmReady, plmStopped, plmPlaying, plmPaused);
TNotifyNewFFTDataEvent = procedure(Sender: TObject;
BandOut: TBandOut) of object;
{ Timer Class }
TThreadTimer = class(TObject)
private
FTerminated: Boolean;
FThread: THandle;
FInterval: Cardinal;
FEnabled: Boolean;
procedure SetEnabled(const Value: Boolean);
public
constructor Create(const CreateSuspended: Boolean);
destructor Destroy; override;
property Enabled: Boolean read FEnabled write SetEnabled;
property Interval: Cardinal read FInterval write FInterval;
end;
{ Player Class }
TLABassPlayer = class(TObject)
private
BandOut: TBandOut;
TimerFFT: TThreadTimer;
FChannel: Cardinal;
FPlayerMode: TPlayerMode;
function GetVolume: Integer;
procedure SetVolume(Value: Integer);
function GetPosition: Cardinal;
procedure SetPosition(Value: Cardinal);
public
constructor Create;
destructor Destroy; override;
function PlayLength: Cardinal;
{ Pause }
procedure Pause(Mode: Boolean);
{ Open File }
procedure Open(FileName: String);
{ Play Current File }
procedure Play;
{ Stop Playing }
procedure Stop;
{ Current State }
property Mode: TPlayerMode read FPlayerMode write FPlayerMode;
{ Volume }
property Volume: Integer read GetVolume write SetVolume;
property Position: Cardinal read GetPosition write SetPosition;
end;
var
Player: TLABassPlayer;
function Rect(ALeft, ATop, ARight, ABottom: Integer): TRect;
begin
with Result do
begin
Left := ALeft;
Top := ATop;
Right := ARight;
Bottom := ABottom;
end;
end;
procedure DrawSpectrum(const Background: Boolean);
var
R: TRect;
NewText, OldText: HFont;
begin
SpecDC := BeginPaint(GetDlgItem(hApp, ID_SPECTRUM), SpecPS);
try
GetClientRect(GetDlgItem(hApp, ID_SPECTRUM), R);
PatBlt(SpecDC, 0, 0, R.Right - R.Left, R.Bottom - R.Top, BLACKNESS);
if Background then
begin
BitBlt(SpecDC, GaugeRect.Left, GaugeRect.Top, R.Right - R.Left,
R.Bottom - R.Top, MemDC, GaugeRect.Left, GaugeRect.Top, SRCCOPY);
NewText := CreateFont(13, 0, 0, 0, 800, 0, 0, 0, RUSSIAN_CHARSET,
OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS,
DEFAULT_QUALITY, DEFAULT_PITCH, 'Tahoma');
try
OldText := SelectObject(SpecDC, NewText);
SetTextColor(SpecDC, $FFFFFF);
SetBkMode(SpecDC, TRANSPARENT);
DrawText(SpecDC, PChar('Spectrum'), - 1, R, DT_CENTER or DT_VCENTER);
SelectObject(SpecDC, OldText);
finally
DeleteObject(NewText);
end;
end
else
BitBlt(SpecDC, GaugeRect.Left, GaugeRect.Top, R.Right - R.Left,
R.Bottom - R.Top, TmpDC, GaugeRect.Left, GaugeRect.Top, SRCCOPY);
finally
EndPaint(GetDlgItem(hApp, ID_SPECTRUM), SpecPS);
end;
end;
procedure CreateSpectrumImage;
var
I: Integer;
R, G, B: Integer;
W, H: Integer;
OldPen, NewPen: HPen;
OldBrush, NewBrush: HBrush;
begin
W := (BlockWidth + HBlockGap) * HBlockCount - HBlockGap + 3;
H := VLimit + 1;
SetWindowPos(GetDlgItem(hApp, ID_SPECTRUM), 0, 0, 0, W, H, SWP_NOMOVE or
SWP_NOZORDER);
BasicBMP := CreateCompatibleBitmap(GetDC(GetDlgItem(hApp,
ID_SPECTRUM)), W, H);
GaugeTempBMP := CreateCompatibleBitmap(GetDC(GetDlgItem(hApp,
ID_SPECTRUM)), W, H);
OldTmpBMP := SelectObject(TmpDC, GaugeTempBMP);
GaugeRect.Left := 0;
GaugeRect.Top := 0;
GaugeRect.Right := W;
GaugeRect.Bottom := H;
OldBasicBMP := SelectObject(MemDC, BasicBMP);
NewPen := CreatePen(PS_DOT, 1, RGB(0, 0, 255));
try
OldPen := SelectObject(MemDC, NewPen);
MoveToEx(MemDC, 0, 0, NIL);
LineTo(MemDC, 0, H);
MoveToEx(MemDC, 0, H - 1, NIL);
LineTo(MemDC, W, H - 1);
SelectObject(MemDC, OldPen);
finally
DeleteObject(NewPen);
end;
DisplayBar := CreateCompatibleBitmap(GetDC(GetDlgItem(hApp,
ID_SPECTRUM)), BlockWidth, VLimit);
R := 200;
G := 0;
B := 100;
for I := 0 to VLimit - 1 do
begin
if I > VLimit / 2 then
Dec(R, Trunc(MyVar1 / VLimit))
else
Inc(G, Trunc(MyVar2 / VLimit));
if R < 0 then R := 0;
if G > 255 then G := 255;
NewBrush := CreateSolidBrush(RGB(R, G, B));
try
{ DisplayBar }
SelectObject(MemDC, DisplayBar);
OldBrush := SelectObject(MemDC, NewBrush);
FillRect(MemDC, Rect(0, I, BlockWidth, I + 1), NewBrush);
SelectObject(MemDC, OldBrush);
finally
DeleteObject(NewBrush);
end;
{ Basic }
SelectObject(MemDC, BasicBmp);
end;
end;
procedure DisplayFFTBand(Bands: TBandOut);
var
TmpRect, BarRect, R: TRect;
J: Integer;
NewPen, OldPen: HPen;
begin
GetClientRect(GetDlgItem(hApp, ID_SPECTRUM), R);
PatBlt(TmpDC, 0, 0, R.Right - R.Left, R.Bottom - R.Top, BLACKNESS);
{ Background }
BitBlt(TmpDC, GaugeRect.Left, GaugeRect.Top, R.Right - R.Left,
R.Bottom - R.Top, MemDC, GaugeRect.Left, GaugeRect.Top, SRCCOPY);
{ Draw Spectrum Image To TempDC }
for J := 1 to HBlockCount do
begin
if Bands[J - 1] > VLimit then Bands[J - 1] := VLimit;
if Bands[J - 1] > 0 then
begin
BarRect.Left := 0;
BarRect.Right := BlockWidth;
BarRect.Top := VLimit - Bands[J - 1];
if BarRect.Top < 0 then BarRect.Top := 0;
BarRect.Bottom := VLimit;
TmpRect.Left := (BlockWidth + HBlockGap) * (J - 1) + 2;
TmpRect.Right := TmpRect.Left + BlockWidth;
TmpRect.Top := BarRect.Top;
TmpRect.Bottom := BarRect.Bottom;
SelectObject(MemDC, DisplayBar);
BitBlt(TmpDC, TmpRect.Left, TmpRect.Top,
BlockWidth, TmpRect.Bottom - TmpRect.Top + 1, MemDC,
BarRect.Left, BarRect.Top, SRCCOPY);
SelectObject(MemDC, BasicBmp);
end;
if Bands[J - 1] >= Trunc(PeakValue[J]) then
begin
PeakValue[J] := Bands[J - 1] + 0.01;
PassedCounter[J] := 0;
end
else if Bands[J - 1] < Trunc(PeakValue[J]) then
begin
if Trunc(PeakValue[J]) > 0 then
begin
{ For Peak Line }
NewPen := CreatePen(PS_SOLID, 1, RGB(200, 192, 192));
try
OldPen := SelectObject(TmpDC, NewPen);
MoveToEx(TmpDC, (BlockWidth + HBlockGap) * (J - 1) + 2,
VLimit - Trunc(PeakValue[J]), NIL);
LineTo(TmpDC, (BlockWidth + HBlockGap) * (J - 1) + 2 + BlockWidth,
VLimit - Trunc(PeakValue[J]));
SelectObject(TmpDC, OldPen);
finally
DeleteObject(NewPen);
end;
if PassedCounter[J] >= 8 then
PeakValue[J] := PeakValue[J] - 0.3 * (PassedCounter[J] - 8);
if PeakValue[J] < 0 then
PeakValue[J] := 0
else
Inc(PassedCounter[J]);
end;
end;
end;
end;
{ Thread - function }
function SpectrumThreadFunc(Data: Pointer): DWORD; stdcall;
const
FreqCoef: array[0..NumFFTBands - 1] of Word =
(1, 2, 3, 6, 12, 18, 24, 30, 36,
42, 48, 54, 60, 66, 72, 78, 84, 90,
96, 102, 108, 120, 132, 156, 180);
Boost = 0.15;
Scale = 80;
var
FFTData: TFFTData;
NewBandOut: TBandOut;
StartIndex: Integer;
I, K: Integer;
TmpIntensity: Double;
begin
Result := 0;
with Player do
repeat
if TimerFFT.FTerminated then Break;
InvalidateRect(hApp, NIL, False);
Sleep(TimerFFT.Interval);
if Player.Mode <> plmPlaying then Continue;
if BASS_ChannelGetData(Player.FChannel, @FFTData,
BASS_DATA_FFT512) = $FFFFFFFF then
begin
for I := 0 to (NumFFTBands - 1) do BandOut[I] := 0;
Continue;
end;
for I := 0 to (NumFFTBands - 1) do
begin
if TimerFFT.FTerminated then Break;
if I = 0 then StartIndex := 1
else StartIndex := FreqCoef[I - 1] + 1;
TmpIntensity := 0;
for K := StartIndex to FreqCoef[I] do
if FFTData[K] > TmpIntensity then TmpIntensity := FFTData[K];
NewBandOut[I] := Round(TmpIntensity * (1 + I * Boost) * Scale);
if NewBandOut[I] > BandOut[I] then
BandOut[I] := NewBandOut[I]
else
if BandOut[I] >= 2 then
Dec(BandOut[I], 2)
else
BandOut[I] := 0;
if NewBandOut[I] > BandOut[I] then
BandOut[I] := NewBandOut[I];
end;
if TimerFFT.FTerminated then Break;
{ Show Spectrum }
DisplayFFTBand(BandOut);
until TimerFFT.FTerminated;
end;
procedure WMDragDropFiles(hDrop: DWORD);
var
L: DWORD;
K: DWORD;
DragFile: PChar;
begin
GetMem(DragFile, MAX_PATH);
try
K := DragQueryFile(hDrop, $FFFFFFFF, NIL, 0);
for L := 0 to K - 1 do
begin
DragQueryFile(hDrop, L, DragFile, MAX_PATH);
Player.Open(DragFile);
SendMessage(hApp, WM_SETTEXT, 0, LPARAM(PChar(DragFile)));
end;
finally
FreeMem(DragFile);
end;
end;
function GenDlgProc(hWnd: HWND; uMsg: UINT; wParam: WPARAM;
lParam: LPARAM): BOOL; stdcall;
begin
Result := FALSE;
case uMsg of
WM_DROPFILES: WMDragDropFiles(wParam);
WM_INITDIALOG:
begin
hApp := hWnd;
SendMessage(hApp, WM_SETTEXT, 0, Integer(PChar('Spectrum')));
MemDC := CreateCompatibleDC(0);
TmpDC := CreateCompatibleDC(0);
SetBkMode(MemDC, TRANSPARENT);
SetBkMode(TmpDC, TRANSPARENT);
CreateSpectrumImage;
Player := TLABassPlayer.Create;
end;
WM_ERASEBKGND:
begin
GetClientRect(hApp, ClientRect);
SpecDC := BeginPaint(hApp, SpecPS);
try
PatBlt(SpecDC, 0, 0, ClientRect.Right - ClientRect.Left,
ClientRect.Bottom - ClientRect.Top, BLACKNESS);
finally
EndPaint(hApp, SpecPS);
end;
Result := True;
end;
WM_PAINT:
begin
DrawSpectrum(Player.Mode <> plmPlaying);
Result := False;
end;
WM_COMMAND:
case LoWord(wParam) of
ID_PLAYING: Player.Play;
ID_STOPPING: Player.Stop;
end;
WM_CLOSE: DestroyWindow(hWnd);
WM_DESTROY:
begin
Player.Free;
SelectObject(MemDC, OldBasicBMP);
SelectObject(TmpDC, OldTmpBMP);
DeleteObject(BasicBMP);
DeleteObject(DisplayBar);
DeleteObject(GaugeTempBMP);
DeleteDC(MemDC);
DeleteDC(TmpDC);
PostQuitMessage(0);
end;
end;
end;
{ TLABassPlayer }
constructor TLABassPlayer.Create;
begin
FPlayerMode := plmStandby;
if not BASS_Init(-1, 44100, 0, hApp, NIL) then
begin
MessageBox(hApp, 'Невозможно выполнить инициализацию устройства!',
'Ошибка', MB_ICONHAND);
SendMessage(hApp, WM_CLOSE, 0, 0);
end;
{ For Spectrum }
TimerFFT := TThreadTimer.Create(False);
TimerFFT.Interval := 33;
FChannel := 0;
end;
destructor TLABassPlayer.Destroy;
begin
TimerFFT.Free;
if FPlayerMode = plmPlaying then Stop;
if FChannel <> 0 then
BASS_StreamFree(FChannel);
BASS_Free;
inherited;
end;
function TLABassPlayer.GetPosition: Cardinal;
var
Pos: Int64;
Pos2: Single;
begin
Pos := BASS_ChannelGetPosition(FChannel);
if Pos < 0 then Pos := 0;
Pos2 := BASS_ChannelBytes2Seconds(FChannel, Pos);
if Pos2 < 0 then Pos2 := 0;
{ In Milliseconds }
Result := Round(1000 * Pos2);
end;
function TLABassPlayer.GetVolume: Integer;
begin
Result := BASS_GetConfig(BASS_CONFIG_GVOL_STREAM);
end;
procedure TLABassPlayer.Open(FileName: String);
begin
BASS_StreamFree(FChannel);
FChannel := BASS_StreamCreateFile(False, PChar(FileName), 0, 0, 0);
{ Launch Spectrum }
FPlayerMode := plmReady;
end;
procedure TLABassPlayer.Pause(Mode: Boolean);
begin
If (Mode) and (FPlayerMode = plmPlaying) then
begin
BASS_ChannelPause(FChannel);
FPlayerMode := plmPaused;
end
else
if not (Mode) and (FPlayerMode <> plmPlaying) then
begin
BASS_ChannelPlay(FChannel, False);
FPlayerMode := plmPlaying;
TimerFFT.Enabled := True;
end;
end;
procedure TLABassPlayer.Play;
begin
if FChannel = 0 then Exit;
BASS_ChannelPlay(FChannel, True);
FPlayerMode := plmPlaying;
TimerFFT.Enabled := True;
end;
function TLABassPlayer.PlayLength: Cardinal;
var
Len: Int64;
Len2: Float;
begin
Len := BASS_ChannelGetLength(FChannel);
if Len < 0 then Len := 0;
Len2 := BASS_ChannelBytes2Seconds(FChannel, Len);
{ In Milliseconds }
if Len2 < 0 then Len2 := 0;
if Len2 = 0 then
Result := 0
else
Result := Round(1000 * Len2);
end;
procedure TLABassPlayer.SetPosition(Value: Cardinal);
var
Pos: Int64;
begin
Pos := BASS_ChannelSeconds2Bytes(FChannel, Value / 1000);
BASS_ChannelSetPosition(FChannel, Pos);
end;
procedure TLABassPlayer.SetVolume(Value: Integer);
begin
if Value > 100 then
Value := 100
else if Value < 0 then
Value := 0;
BASS_SetConfig(BASS_CONFIG_GVOL_STREAM, Value);
end;
procedure TLABassPlayer.Stop;
begin
BASS_ChannelStop(FChannel);
FPlayerMode := plmStopped;
end;
{ TThreadTimer }
constructor TThreadTimer.Create(const CreateSuspended: Boolean);
const
Flags: array[Boolean] of Byte = (0, CREATE_SUSPENDED);
begin
FTerminated := False;
FThread := CreateThread(NIL, 0, @SpectrumThreadFunc,
NIL, Flags[CreateSuspended], PLongWord(NIL)^);
end;
destructor TThreadTimer.Destroy;
begin
FTerminated := True;
if WaitForSingleObject(FThread, INFINITE) = WAIT_OBJECT_0 then
begin
CloseHandle(FThread);
inherited;
end;
end;
procedure TThreadTimer.SetEnabled(const Value: Boolean);
begin
if FEnabled <> Value then
begin
FEnabled := Value;
if FEnabled then ResumeThread(FThread)
else SuspendThread(FThread);
end;
end;
{ Entry Point }
begin
DialogBox(HInstance, MakeIntResource(RES_DIALOG), 0, @GenDlgProc);
end.
|
|
Спектрум Bass, Спектральный анализатор на WinApi 
spectrum__bass.dll_.zip 14,16 Kb
Загрузка ...
1.PNG 1,33 Kb
Дата 30.6.2008, 17:36 (
