mmspgram.pas

一套及时通讯的原码

   FBarColor := clGray;
   FBarTickColor := clWhite;
   FDrawScale := False;
   Fx1 := -FBarWidth;
   Fx2 := 0;
   FNeedReset := False;
   FScroll := False;
   FShowInfoHint := False;
   FShowInfo := True;
   FSaveData := False;
   FSelectStart := -1;
   FSelectEnd := -1;
   FLocator := -1;
   FSelectColor := clRed;
   FSelectDotColor := clRed;
   FLocatorColor := clYellow;
   FDrawing := False;
   FLocked := False;
   FUseSelection := False;
   FSaveBuffer := nil;

   Height := 90;
   Width := 194;
   Cursor := crCross;
   FFTLength := 128;

   if not (csDesigning in ComponentState) then
   begin
      { update the spectrogram list }
      AddSpectrogram(Self);
   end;

   ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
   if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;

{-- TMMSpectrogram ------------------------------------------------------}
Destructor TMMSpectrogram.Destroy;
begin
   if not (csDesigning in ComponentState) then
   begin
      { update the spectrogram list }
      RemoveSpectrogram(Self);
   end;

   FreeDataBuffers;
   FreeArrays;
   {$IFDEF WIN32}
   DoneRealFFT(FpFFT);
   {$ELSE}
   FFT.Free;
   {$ENDIF}

   inherited Destroy;
end;

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.ChangeDesigning(aValue: Boolean);
begin
   inherited ChangeDesigning(aValue);

   if not (csDesigning in ComponentState) then
   begin
      { update the spectrogram list }
      AddSpectrogram(Self);
   end;
end;

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.PcmOverflow;
begin
   if Assigned(FOnPcmOverflow) then FOnPcmOverflow(Self);
end;

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.CreateDataBuffers(Length: Cardinal);
begin
   if (Length > 0) then
   begin
      FFFTData   := GlobalAllocMem(Length * sizeOf(SmallInt));
      FWinBuf    := GlobalAllocMem(Length * sizeOf(Integer));
      FOldData   := GlobalAllocMem((Length div 2) * sizeOf(SmallInt));
      FDisplayVal:= GlobalAllocMem((Length div 2) * sizeOf(Long));
   end;
end;

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.FreeDataBuffers;
begin
   GlobalFreeMem(Pointer(FFFTData));
   GlobalFreeMem(Pointer(FWinBuf));
   GlobalFreeMem(Pointer(FOldData));
   GlobalFreeMem(Pointer(FDisplayVal));
   GlobalFreeMem(Pointer(FSaveBuffer));
end;

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.CreateArrays(Size: Cardinal);
begin
   if (Size > 0) then
   begin
      Fy1          := GlobalAllocMem(Size * sizeOf(Integer));
      Fy2          := GlobalAllocMem(Size * sizeOf(Integer));
      FColorValues := GlobalAllocMem(Size * sizeOf(Byte));
   end;
end;

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.FreeArrays;
begin
   GlobalFreeMem(Pointer(Fy1));
   GlobalFreeMem(Pointer(Fy2));
   GlobalFreeMem(Pointer(FColorValues));
end;

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.ResetData;
var
   P: TPoint;
begin
   if FShowInfoHint then
   begin
      GetCursorPos(P);
      P := ScreenToClient(P);
      Perform(WM_LBUTTONUP, 0, Longint(PointToSmallPoint(P)));
   end;
   FNeedReset   := True;
   FSelectStart := -1;
   FSelectEnd   := -1;
   FLocator     := -1;

   Fx1 := -BarWidth;//Max(-FBarWidth,0);
   Fx2 := 0;

   if (FSaveBuffer <> nil) then
       FillChar(FSaveBuffer^,(MAX_FFTLEN div 2) * sizeOf(Long)*FWidth,0);

   Refresh;
end;

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.SetFFTLen(aLength: integer);
var
   Order: integer;

begin
   aLength := MinMax(aLength,8,MAX_FFTLEN);
   { Convert FFTLen to a power of 2 }
   Order := 0;
   while aLength > 1 do
   begin
      aLength := aLength shr 1;
      inc(Order);
   end;
   if (Order > 0) then aLength := aLength shl Order;

   {$IFDEF WIN32}
   {$IFDEF TRIAL}
   {$DEFINE _HACK1}
   {$I MMHACK.INC}
   {$ENDIF}
   {$ENDIF}

   if (aLength <> FFTLen) then
   begin
      { re-init the FFTObject with the new FFT-length }
      {$IFDEF WIN32}
      DoneRealFFT(FpFFT);
      FpFFT := InitRealFFT(Order);
      FFTLen := aLength;
      GenWindowTableInt(FWinBuf,Ord(FWindow),Trunc(Log2(FFTLen)));
      {$ELSE}
      FFT.FFTLength := aLength;
      FFTLen := aLength;
      GenWindowTableInt(FWinBuf,Ord(FWindow),Trunc(Log2(FFTLen)));
      {$ENDIF}

      { Re-initialize the display }
      SetupYScale;
      SetBytesPerSpectrogram;
      Invalidate;
   end;
end;

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.SetWindow(aValue: TMMFFTWindow);
begin
   if (aValue <> FWindow) then
   begin
      FWindow := aValue;
      GenWindowTableInt(FWinBuf,Ord(FWindow),Trunc(Log2(FFTLen)));
   end;
end;

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.SetSampleRate(aValue: Longint);
begin
   if (aValue <> FSampleRate) then
   begin
      FSampleRate := MinMax(aValue, 8000, 100000);
      { Re-initialize the display }
      SetupYScale;
      { calc the number of scale steps }
      CalcScaleSteps;
      Invalidate;
   end;
end;

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.SetLogAmp(aValue: Boolean);
begin
   { Toggle linear/logarithmic amplitude axis }
   if (aValue <> FLogAmp) then
   begin
      FLogAmp := aValue;
   end;
end;

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.SetEnabled(aValue: Boolean);
begin
   if (aValue <> FEnabled) then
   begin
      FEnabled := aValue;
      { inherited Enabled := Value }
      Invalidate;
   end;
end;

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.SetBarWidth(aValue: integer);
begin
   if (aValue <> FBarWidth) then
   begin
      FBarWidth := Max(aValue,0);
      Invalidate;
   end;
   {$IFDEF WIN32}
   {$IFDEF TRIAL}
   {$DEFINE _HACK2}
   {$I MMHACK.INC}
   {$ENDIF}
   {$ENDIF}
end;

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.SetSaveData(aValue: Boolean);
begin
   if (aValue <> FSaveData) then
   begin
      if (FSaveBuffer <> nil) then
          GlobalFreeMem(Pointer(FSaveBuffer));

      FSaveData := aValue;

      if FSaveData then
         FSaveBuffer := GlobalAllocMem((MAX_FFTLEN div 2) * sizeOf(Long)*FWidth);
   end;
end;

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.Loaded;
begin
   inherited Loaded;

   SetupYScale;
   SetPalMode(FPalMode);
   FastDraw(DrawSpectrogram,True);
end;

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.AdjustSize(var W, H: Integer);
begin
   if FDrawScale then
      W := Max(W,2*SCALEWIDTH+2*BevelExtend+5)
   else
      W := Max(W,2*BevelExtend+5);

   H := Max(H,2*BevelExtend+5);
end;

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.AdjustBounds;
var
  W, H: Integer;

begin
   W := Width;
   H := Height;
   AdjustSize(W, H);
   if (W <> Width) or (H <> Height) then SetBounds(Left, Top, W, H)
   else Changed;
end;

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.SetBounds(aLeft, aTop, aWidth, aHeight: integer);
var
  W, H: Integer;

begin
   W := aWidth;
   H := aHeight;
   AdjustSize (W, H);
   inherited SetBounds(aLeft, aTop, W, H);
   Changed;
end;

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.Changed;
begin
   FClientRect := Rect(0,0,Width,Height);

   if FDrawScale then
   begin
      { make place for the scale }
      InflateRect(FClientRect, -SCALEWIDTH,0);
   end;
   { and now for the bevel }
   InflateRect(FClientRect, -Bevel.BevelExtend, -Bevel.BevelExtend);

   { save the real height and width }
   FWidth  := Max(FClientRect.Right - FClientRect.Left,4);
   FHeight := Max(FClientRect.Bottom - FClientRect.Top,4);

   FreeArrays;                               { adjust the dyn.array size }
   CreateArrays(FHeight);

   DIBCanvas.SetBounds(0,0,FWidth,FHeight);

   if (FSaveBuffer <> nil) then
   begin
      GlobalFreeMem(Pointer(FSaveBuffer));
      FSaveBuffer := GlobalAllocMem((MAX_FFTLEN div 2) * sizeOf(Long)*FWidth);
   end;

   SetBytesPerSpectrogram;        { calc the new bytes per Scope }
   SetupYScale;                   { recalc the scalings }
   CalcScaleSteps;

   ResetData;

   inherited Changed;
end;

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.SetBytesPerSpectrogram;
begin
   FBytes := (Ord(FBits)+1) * (Ord(FMode)+1) * FFTLen;
end;

{-- TMMSpectrogram ------------------------------------------------------}
Procedure TMMSpectrogram.SetPCMWaveFormat(wf: TPCMWaveFormat);
var
   pwfx: PWaveFormatEx;

begin
   pwfx := @wf;
   if not pcmIsValidFormat(pwfx) then
      raise EMMSpectrogramError.Create(LoadResStr(IDS_INVALIDFORMAT));

   SampleRate := pwfx^.nSamplesPerSec;
   BitLength := TMMBits(pwfx^.wBitsPerSample div 8 - 1);
   Mode := TMMMode(pwfx^.nChannels-1);
end;

{-- TMMSpectrogram ------------------------------------------------------}
function TMMSpectrogram.GetPCMWaveFormat: TPCMWaveFormat;
var
   wfx: TWaveFormatEx;
begin
   pcmBuildWaveHeader(@wfx, (Ord(FBits)+1)*8, Ord(FMode)+1, SampleRate);
   Result := PPCMWaveFormat(@wfx)^;
end;

{-- TMMSpectrogram ------------------------------------------------------}
Procedure TMMSpectrogram.SetBits(aValue: TMMBits);
begin
   if (aValue <> FBits) then
   begin
      FBits := aValue;
      SetBytesPerSpectrogram;
      Invalidate;
   end;
   {$IFDEF WIN32}
   {$IFDEF TRIAL}
   {$DEFINE _HACK3}
   {$I MMHACK.INC}
   {$ENDIF}