home *** CD-ROM | disk | FTP | other *** search
/ Chip 2005 November / CDVD1105.ISO / Software / Freeware / programare / bass / Delphi / custloop / Unit1.pas < prev   
Encoding:
Pascal/Delphi Source File  |  2005-09-14  |  9.5 KB  |  355 lines
  1. unit Unit1;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.   Math, StdCtrls, Bass, ExtCtrls;
  8.  
  9. type
  10.   TForm1 = class(TForm)
  11.     OpenDialog1: TOpenDialog;
  12.     Timer1: TTimer;
  13.     PB: TPaintBox;
  14.     procedure FormCreate(Sender: TObject);
  15.     procedure Timer1Timer(Sender: TObject);
  16.     procedure FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  17.     procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
  18.     procedure FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  19.     procedure PBPaint(Sender: TObject);
  20.     procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
  21.     procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  22.   private
  23.     function PlayFile: boolean;
  24.     procedure ErrorPop(str: string);
  25.     procedure SetLoopStart(position: qword);
  26.     procedure SetLoopEnd(position: qword);
  27.     procedure ScanPeaks2(decoder: HSTREAM);
  28.     procedure DrawSpectrum;
  29.     procedure DrawTime_Line(position: QWORD; x,y : integer; cl : TColor);
  30.   public
  31.   end;
  32.  
  33. type TScanThread = class(TThread)
  34.   private
  35.     Fdecoder : HSTREAM;
  36.   protected
  37.     procedure Execute; override;
  38.   public
  39.     constructor Create(decoder:HSTREAM);
  40. end;
  41.  
  42. procedure LoopSyncProc(handle: HSYNC; channel, data, user: DWORD); stdcall;
  43.  
  44. var
  45.   Form1: TForm1;
  46.   lsync : HSYNC;        // looping synchronizer handle
  47.   chan : HSTREAM;   // sample stream handle
  48.   chan2: HSTREAM;
  49.   loop : array[0..1] of DWORD;
  50.   killscan : boolean;
  51.   bpp : dword; // stream bytes per pixel
  52.   wavebufL : array of smallint;
  53.   wavebufR : array of smallint;
  54.   mousedwn : integer;
  55.   Buffer: TBitmap;
  56.  
  57. implementation
  58.  
  59. {$R *.dfm}
  60.  
  61. //------------------------------------------------------------------------------
  62.  
  63. procedure TForm1.FormCreate(Sender: TObject);
  64. begin
  65.   // check that BASS 2.2 was loaded
  66.     if not (BASS_GetVersion() = dword(MAKELONG(2,2))) then
  67.   begin
  68.         MessageBox(0,'BASS version 2.2 was not loaded','Incorrect BASS.DLL',0);
  69.         Application.Terminate;
  70.     end;
  71.  
  72.   //assigning layout properties
  73.   ClientHeight := 201;
  74.   ClientWidth := 600;
  75.   Top := 100;
  76.   Left := 100;
  77.   Buffer := TBitmap.Create;
  78.   Buffer.Width:= PB.Width;
  79.   Buffer.Height:= PB.Height;
  80.   PB.Parent.DoubleBuffered := true;
  81.  
  82.   //set array size
  83.   setlength(wavebufL,ClientWidth);
  84.   setlength(wavebufR,ClientWidth);
  85.  
  86.   //init vars
  87.   loop[0] := 0;
  88.   loop[1] := 0;
  89.   
  90.   //init BASS
  91.   if not BASS_Init(-1,44100,0,Application.Handle,nil) then
  92.     ErrorPop('Can''t initialize device');
  93.   
  94.   //init timer for updating
  95.   Timer1.Interval := 20; //ms
  96.   Timer1.Enabled := true;
  97.  
  98.   //main start play function
  99.   if not PlayFile then
  100.   begin
  101.     BASS_Free();
  102.     Application.Terminate;
  103.   end;  
  104. end;
  105.  
  106. function TForm1.PlayFile : boolean;
  107. var
  108.   filename : string;
  109.   data : array[0..2000] of SmallInt;
  110.   i : integer;
  111. begin
  112.   result := false;
  113.   if OpenDialog1.Execute then
  114.   begin
  115.     filename := OpenDialog1.Filename;
  116.     BringWindowToTop(Form1.Handle);
  117.     SetForegroundWindow(Form1.Handle);
  118.  
  119.     //creating stream
  120.     chan := BASS_StreamCreateFile(FALSE,pchar(filename),0,0,0);
  121.     if chan = 0 then
  122.     begin
  123.       chan := BASS_MusicLoad(False, pchar(filename), 0, 0, BASS_MUSIC_RAMPS or BASS_MUSIC_POSRESET or BASS_MUSIC_PRESCAN, 0);
  124.       if (chan = 0) then
  125.       begin
  126.         ErrorPop('Can''t play file');
  127.         Exit;
  128.       end;
  129.     end;
  130.  
  131.     //playing stream and setting global vars
  132.     for i:=0 to length(data)-1 do data[0] := 0;
  133.     bpp := BASS_ChannelGetLength(chan) div ClientWidth; // stream bytes per pixel
  134.     if (bpp < BASS_ChannelSeconds2Bytes(chan,0.02)) then // minimum 20ms per pixel (BASS_ChannelGetLevel scans 20ms)
  135.       bpp := BASS_ChannelSeconds2Bytes(chan,0.02);
  136.     BASS_ChannelSetSync(chan,BASS_SYNC_END or BASS_SYNC_MIXTIME,0,LoopSyncProc,0); // set sync to loop at end
  137.     BASS_ChannelPlay(chan,FALSE); // start playing
  138.  
  139.     //getting peak levels in seperate thread, stream handle as parameter
  140.         chan2 := BASS_StreamCreateFile(FALSE,pchar(filename),0,0,BASS_STREAM_DECODE);
  141.         if (chan2 = 0) then chan2 := BASS_MusicLoad(FALSE,pchar(filename),0,0,BASS_MUSIC_DECODE,0);
  142.     TScanThread.Create(chan2); // start scanning peaks in a new thread
  143.     result := true;
  144.   end;
  145. end;
  146.  
  147. procedure TForm1.DrawSpectrum;
  148. var
  149.   i,ht : integer;
  150. begin
  151.   //clear background
  152.   Buffer.Canvas.Brush.Color := clBlack;
  153.   Buffer.Canvas.FillRect(Rect(0,0,Buffer.Width,Buffer.Height));
  154.  
  155.   //draw peaks
  156.   ht := ClientHeight div 2;
  157.   for i:=0 to length(wavebufL)-1 do
  158.   begin
  159.     Buffer.Canvas.MoveTo(i,ht);
  160.       Buffer.Canvas.Pen.Color := clLime;
  161.     Buffer.Canvas.LineTo(i,ht-trunc((wavebufL[i]/32768)*ht));
  162.     Buffer.Canvas.Pen.Color := clLime;
  163.     Buffer.Canvas.MoveTo(i,ht+2);
  164.       Buffer.Canvas.LineTo(i,ht+2+trunc((wavebufR[i]/32768)*ht));
  165.   end;
  166. end;
  167.  
  168. procedure TForm1.DrawTime_Line(position : QWORD; x,y : integer; cl : TColor);
  169. var
  170.   sectime : integer;
  171.   str:string;
  172. begin
  173.   sectime := trunc(BASS_ChannelBytes2Seconds(chan,position));
  174.  
  175.   //format time
  176.   str := '';
  177.   if (sectime mod 60 < 10) then str := '0';
  178.   str := str+inttostr(sectime mod 60);
  179.   str := inttostr(sectime div 60)+':'+str;
  180.  
  181.   //drawline
  182.   Buffer.Canvas.Pen.Color := cl;
  183.   Buffer.Canvas.MoveTo(x,0);
  184.   Buffer.Canvas.LineTo(x,ClientHeight);
  185.  
  186.   //drawtext
  187.   Buffer.Canvas.Font.Color := cl;
  188.   Buffer.Canvas.Font.Style := [fsBold];
  189.   if x > ClientWidth-20 then
  190.     dec(x,40);
  191.   SetBkMode(Buffer.Canvas.Handle,TRANSPARENT);
  192.   Buffer.Canvas.TextOut(x+2,y,str);
  193. end;               
  194.  
  195. procedure TForm1.ErrorPop(str:string);
  196. begin
  197.   //show last BASS errorcode when no argument is given, else show given text.
  198.   if str = '' then
  199.     Showmessage('Error code: '+inttostr(BASS_ErrorGetCode()))
  200.   else
  201.     Showmessage(str);
  202.   Application.Terminate;
  203. end;
  204.  
  205. procedure TForm1.SetLoopStart(position : qword);
  206. begin
  207.   loop[0] := position;
  208. end;
  209.  
  210. procedure TForm1.SetLoopEnd(position : qword);
  211. begin
  212.   loop[1] := position;
  213.   BASS_ChannelRemoveSync(chan,lsync); // remove old sync
  214.   lsync := BASS_ChannelSetSync(chan,BASS_SYNC_POS or BASS_SYNC_MIXTIME,loop[1],LoopSyncProc,0); // set new sync
  215. end;
  216.  
  217. procedure LoopSyncProc(handle: HSYNC; channel, data, user: DWORD); stdcall;
  218. begin
  219.     if not BASS_ChannelSetPosition(channel,loop[0]) then // try seeking to loop start
  220.         BASS_ChannelSetPosition(channel,0); // failed, go to start of file instead
  221. end;
  222.  
  223. procedure TForm1.ScanPeaks2(decoder : HSTREAM);
  224. var
  225.   cpos,level : DWord;
  226.   peak : array[0..1] of DWORD;
  227.   position : DWORD;
  228.   counter : integer;
  229. begin
  230.   cpos := 0;
  231.   peak[0] := 0;
  232.   peak[1] := 0;
  233.   counter := 0;
  234.   
  235.   while not killscan do
  236.   begin
  237.     level := BASS_ChannelGetLevel(decoder); // scan peaks
  238.     if (peak[0]<LOWORD(level)) then
  239.       peak[0]:=LOWORD(level); // set left peak
  240.         if (peak[1]<HIWORD(level)) then
  241.       peak[1]:=HIWORD(level); // set right peak
  242.     if BASS_ChannelIsActive(decoder) <> BASS_ACTIVE_PLAYING then
  243.     begin
  244.       position := cardinal(-1); // reached the end
  245.         end else
  246.       position := BASS_ChannelGetPosition(decoder) div bpp;
  247.  
  248.     if position > cpos then
  249.     begin
  250.       inc(counter);
  251.       if counter <= length(wavebufL)-1 then
  252.       begin
  253.         wavebufL[counter] := peak[0];
  254.         wavebufR[counter] := peak[1];
  255.       end;
  256.  
  257.       if (position >= dword(ClientWidth)) then
  258.         break;
  259.       cpos := position;
  260.      end;
  261.  
  262.  
  263.     peak[0] := 0;
  264.     peak[1] := 0;
  265.   end;
  266.   BASS_StreamFree(decoder); // free the decoder
  267. end;
  268.  
  269. //------------------------------------------------------------------------------
  270.  
  271. { TScanThread }
  272.  
  273. constructor TScanThread.Create(decoder: HSTREAM);
  274. begin
  275.   inherited create(false);
  276.   Priority := tpNormal;
  277.   FreeOnTerminate := true;
  278.   FDecoder := decoder;
  279. end;
  280.  
  281. procedure TScanThread.Execute;
  282. begin
  283.   inherited;
  284.   Form1.ScanPeaks2(FDecoder);
  285.   Terminate;
  286. end;
  287.  
  288. //------------------------------------------------------------------------------
  289.  
  290. procedure TForm1.Timer1Timer(Sender: TObject);
  291. begin
  292.   if bpp = 0 then exit;
  293.   DrawSpectrum; // draw peak waveform
  294.   DrawTime_Line(loop[0],(loop[0] div bpp),12,TColor($FFFF00)); // loop start
  295.   DrawTime_Line(loop[1],(loop[1] div bpp),24,TColor($00FFFF)); // loop end
  296.   DrawTime_Line(BASS_ChannelGetPosition(chan),(BASS_ChannelGetPosition(chan) div bpp),0,TColor($FFFFFF)); // current pos
  297.   PB.Refresh;
  298. end;
  299.  
  300. procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  301.   Shift: TShiftState; X, Y: Integer);
  302. begin
  303.   if Button = mbLeft then
  304.   begin
  305.     mousedwn := 1;
  306.     SetLoopStart(dword(x)*bpp)
  307.   end
  308.   else if Button = mbRight then
  309.   begin
  310.     mousedwn := 2;
  311.     SetLoopEnd(dword(x)*bpp);
  312.   end;
  313. end;
  314.  
  315. procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  316.   Y: Integer);
  317. begin
  318.   if mousedwn = 0 then
  319.     exit;
  320.   if mousedwn = 1 then
  321.     SetLoopStart(dword(x)*bpp)
  322.   else if mousedwn = 2 then
  323.     SetLoopEnd(dword(x)*bpp);
  324. end;
  325.  
  326. procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  327.   Shift: TShiftState; X, Y: Integer);
  328. begin
  329.   mousedwn := 0;
  330. end;
  331.  
  332. procedure TForm1.PBPaint(Sender: TObject);
  333. begin
  334.   if bpp = 0 then exit;
  335.   PB.Canvas.Draw(0,0,Buffer);
  336. end;
  337.  
  338. procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  339.   Shift: TShiftState);
  340. begin
  341.   if key = 27 then
  342.     Application.Terminate;
  343. end;
  344.  
  345. procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  346. begin
  347.   Timer1.Enabled := false;
  348.   bpp := 0;
  349.   killscan := true;
  350.   Buffer.Free;
  351.   BASS_Free();
  352. end;
  353.  
  354. end.
  355.