einfache Visualisierung mit bass.dll ??

[Paul0703]

Hallo,
ich habe ein Problem mit der Visualisierung von Sounddateien mit der bass.dll.
Und zwar benutze ich eine PaintBox, um die Töne darzustellen.

Delphi-Quellcode:

 data := BassdllPlayer1.GetFFTData;
    for i := 0 to 255 do Data[i] := Data[i] * ln(i + 1) * 5 * Paintbox1.ClientHeight;
    for i := 0 to 255 do
      begin
        Paintbox1.Canvas.pen.color := clYellow;
        Paintbox1.Canvas.MoveTo(i, Paintbox1.height);
        Paintbox1.Canvas.lineTo(i, Paintbox1.height - round(Data[i]) - 2);
      end;

So, jetzt habe ich aber das Problem, dass in der PaintBox zwar alles korrekt gezeichnet wird, aber das alte nicht gelöscht wird. Also der zeichnet immer mehr Striche, bis alles nur noch gelb ist.
Und wenn ich es folgendermaßen mache, dann flackert das Bild!

Delphi-Quellcode:

 data := BassdllPlayer1.GetFFTData;
    for i := 0 to 255 do Data[i] := Data[i] * ln(i + 1) * 5 * Paintbox1.ClientHeight;
    for i := 0 to 255 do
      begin
        PaintBox1.Canvas.FillRect(Form1.PaintBox1.ClientRect); 
           // diese zeile löscht den bildschirm zwar, aber dadurch flackert es!!
        Paintbox1.Canvas.pen.color := clYellow;
        Paintbox1.Canvas.MoveTo(i, Paintbox1.height);
        Paintbox1.Canvas.lineTo(i, Paintbox1.height - round(Data[i]) - 2);
      end;

Vielleicht hat jemand eine Idee, wie ich das lösen kann.
Gruß Paul

[lbccaleb]

Lehre die PaintBox auserhalb der schleife, als0

Delphi-Quellcode:

PaintBox1.Canvas.FillRect(Form1.PaintBox1.ClientRect);
data := BassdllPlayer1.GetFFTData;
    for i := 0 to 255 do Data[i] := Data[i] * ln(i + 1) * 5 * Paintbox1.ClientHeight;
    for i := 0 to 255 do
      begin
           // diese zeile löscht den bildschirm zwar, aber dadurch flackert es!!
        Paintbox1.Canvas.pen.color := clYellow;
        Paintbox1.Canvas.MoveTo(i, Paintbox1.height);
        Paintbox1.Canvas.lineTo(i, Paintbox1.height - round(Data[i]) - 2);
      end;

[Paul0703]

Danke!! Das funzt einwandfrei

[Paul0703]

Ich habe jetzt noch ein Frage.
Kann man mit der Bass.dll auch Visualisierung in Vollbild machen?? Mit dem obigen Code wird nur ein Teil der Paintbox ausgefüllt.

[meama]

auch wenn der thread schon ein bisschen älter ist gebe ich mal meinen senf dazu
meine vollbild visualisierung habe ich so gemacht

Delphi-Quellcode:

 data := form1.BassdllPlayer1.GetFFTData;
     for i := 0 to 255 do
      Data[i] := Data[i] * ln(i + 1) * 5 * Paintbox1.ClientHeight;
      Paintbox1.Canvas.CopyRect(Paintbox1.ClientRect, bkBitmap.Canvas, BitmapRect);
     
      randcl:=random(5);
      case randcl of
      0:Paintbox1.Canvas.pen.color := cllime;
      1:Paintbox1.Canvas.pen.color := clred;
      2:Paintbox1.Canvas.pen.color := claqua;
      3:Paintbox1.Canvas.pen.color := clyellow;
      4:Paintbox1.Canvas.pen.color := clfuchsia;
      end;

      Paintbox1.Canvas.MoveTo(0, Paintbox1.height div 2);
      for i := 0 to 255 do
        Paintbox1.Canvas.LineTo(i*((paintbox1.width div 255)), Paintbox1.height div 2 - round(Data[i]) div 2);
      Paintbox1.Canvas.MoveTo(0, Paintbox1.height div 2);
      for i := 0 to 255 do
        Paintbox1.Canvas.LineTo(i*((paintbox1.width div 255)), Paintbox1.height div 2 + round(Data[i]) div 2);
        Paintbox1.Canvas.MoveTo(0, Paintbox1.height div 2);

Paintbox1.Canvas.LineTo(i*((paintbox1.width div 255)) sorgt dafür, dass die visualisierunf über die paintbox gestreckt wird. allerdings je nach auflösung auch nicht ganz, weil das ergebnis gerundet ist. wenn man die 255 etwas kleiner macht könnte man das beheben, hängt wie gesagt von auflösung, also größe der paintbox ab

[Maks1509]

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.

[Paul0703]

Zitat von meama:

auch wenn der thread schon ein bisschen älter ist gebe ich mal meinen senf dazu
meine vollbild visualisierung habe ich so gemacht

Delphi-Quellcode:

 data := form1.BassdllPlayer1.GetFFTData;
     for i := 0 to 255 do
      Data[i] := Data[i] * ln(i + 1) * 5 * Paintbox1.ClientHeight;
      Paintbox1.Canvas.CopyRect(Paintbox1.ClientRect, bkBitmap.Canvas, BitmapRect);
     
      randcl:=random(5);
      case randcl of
      0:Paintbox1.Canvas.pen.color := cllime;
      1:Paintbox1.Canvas.pen.color := clred;
      2:Paintbox1.Canvas.pen.color := claqua;
      3:Paintbox1.Canvas.pen.color := clyellow;
      4:Paintbox1.Canvas.pen.color := clfuchsia;
      end;

      Paintbox1.Canvas.MoveTo(0, Paintbox1.height div 2);
      for i := 0 to 255 do
        Paintbox1.Canvas.LineTo(i*((paintbox1.width div 255)), Paintbox1.height div 2 - round(Data[i]) div 2);
      Paintbox1.Canvas.MoveTo(0, Paintbox1.height div 2);
      for i := 0 to 255 do
        Paintbox1.Canvas.LineTo(i*((paintbox1.width div 255)), Paintbox1.height div 2 + round(Data[i]) div 2);
        Paintbox1.Canvas.MoveTo(0, Paintbox1.height div 2);

Paintbox1.Canvas.LineTo(i*((paintbox1.width div 255)) sorgt dafür, dass die visualisierunf über die paintbox gestreckt wird. allerdings je nach auflösung auch nicht ganz, weil das ergebnis gerundet ist. wenn man die 255 etwas kleiner macht könnte man das beheben, hängt wie gesagt von auflösung, also größe der paintbox ab

Danke, das habe ich noch gesucht! Habe es noch nicht hinbekommen, hatte aber auch noch nicht wirklich Zeit dafür.
Werde es mir mal ansehen!