mmspgram.pas

一套及时通讯的原码

            { Compute the magnitude }
            {$IFDEF WIN32}
            re := FFFTData^[i+i];
            im := FFFTData^[i+i+1];
            {$ELSE}
            re := FFFTData^[FFT.BitReversed^[i]];
            im := FFFTData^[FFT.BitReversed^[i]+1];
            {$ENDIF}
            a2 := re*re+im*im;
         end;

         { Watch for possible overflow }
         if a2 < 1 then a2 := 1;
         FDisplayVal^[i] := Trunc((20*FAmpScale*Log(a2))+2*(-90-FSensitivy))+MIN_COLOR;
         if (pSave <> nil) then
             pSave[i] := FDisplayVal^[i];
      end;
   end;
end;

{.$DEFINE COLORTEST}

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.DrawData(pDispData: PLongArray);
var
   i, j, y, index, repcount: integer;
   val,val2: Long;
   oldData: PSmallInt;
   LastVal: integer;

   {$IFDEF COLRTEST}
   clr: integer;
   {$ENDIF}

begin
   val := 0;
   i := 0;
   y := FHeight-1;
   oldData := Pointer(FOldData);
   LastVal := MIN_COLOR;
   repcount := 0;
   {$IFDEF COLORTEST}
   clr := MIN_COLOR+NUM_COLORS;
   {$ENDIF}
   while i < FHeight do
   begin
      { If this line is the same as the previous one, just use the previous
        Y value. Else go ahead and compute the value. }
      index := Fy1^[i];
      if (index <> -1) or (i = FHeight-1) then
      begin
         if i > 0 then
         begin
            if (FEmbossed) then
            begin
               { Get difference with offset }
               val2 := OldData^ - val + (NUM_COLORS div 2);
               Olddata^ := LastVal;
               inc(OldData);
               LastVal := val;
               val := val2;
            end;

            val := MinMax(val,MIN_COLOR,MIN_COLOR+NUM_COLORS-1);

            for j := 0 to repcount-1 do
            begin
               if y >= 0 then FColorValues^[y] := val;
               dec(y);
            end;

            if (i = FHeight-1) then
            begin
               while y > -1 do
               begin
                  FColorValues^[y] := val;
                  dec(y);
               end;
               break;
            end;
         end;
         repcount := 0;

         {$IFDEF COLORTEST}
         dec(Clr);
         val:= Clr;
         {$ELSE}
         val := pDispData^[index];
	 if (Fy2^[i] > 0) then { Take the maximum of a set of bins }
	 begin
	    while (index < Fy2^[i]) do
            begin
	       if (pDispData^[index] > val) then
                   val := pDispData^[index];
               inc(index);
            end;
         end;
         {$ENDIF}
      end;
      inc(repcount);
      inc(i);
   end;

   DIBCanvas.DIB_VLineMultiColor(Fx1, 0, PByte(FColorValues), FHeight);
  { for i := 0 to FHeight-1 do DIBCanvas.DIB_SetPixel(Fx1,i,FColorValues^[i]);}
end;

{-- TMMSpectrogram ------------------------------------------------------}
function TMMSpectrogram.GetFrequency(Pos: TPoint): Float;
begin
   Result := 0;
   if PtInRect(FClientRect,Pos) then
   begin
      dec(Pos.Y,FClientRect.Top);
      Result := FFreqBase+(FSampleRate/2-FFreqScaleFactor*FFReqBase)*(FHeight-Pos.Y-1)/(FHeight-1)/FFreqScaleFactor;
   end;
end;

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.CalcScaleSteps;
begin
   { calc the number of steps required }
   FNumScaleSteps := Trunc(FSampleRate/2/1000*FFreqScaleFactor);
   while (FHeight div FNumScaleSteps < SCALEFONTSIZE) do
   begin
      FNumScaleSteps := FNumScaleSteps div 2;
      if FNumScaleSteps <= 1 then break;
   end;
end;

{-- TMMSpectrogram ------------------------------------------------------}
function TMMSpectrogram.GetScaleBackColor: TColor;
begin
   {$IFNDEF BUILD_ACTIVEX}
   Result := TForm(Parent).Color;
   {$ELSE}
   Result := FScaleBackColor;
   {$ENDIF}
end;

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.DrawFrequencyScale;
var
   aBitmap: TBitmap;
   i, X, Y: integer;
   Text: String;
   Step: Float;

begin
   { put up the frequency scale }
   if FDrawScale then
   begin
      aBitmap := TBitmap.Create;
      try
         aBitmap.Width := SCALEWIDTH;
         aBitmap.Height := Height;
         aBitmap.Canvas.Font.Color := FScaleTextColor;
         aBitmap.Canvas.Pen.Color := FScaleLineColor;
         aBitmap.Canvas.Brush.Color := GetScaleBackColor;
         with aBitmap.Canvas do
         begin
            { Put up the frequency scale. }
            Step := (FSampleRate/2-FFreqScaleFactor*FFReqBase)/FNumScaleSteps/FFreqScaleFactor/1000;

            { draw the left side }
            FillRect(Rect(0,0,aBitmap.Width,aBitmap.Height));
            X := SCALEWIDTH-1;
            MoveTo(X, Height-BevelExtend-1);
            for i := 0 to FNumScaleSteps do
            begin
               Y := Height - BevelExtend - Trunc(i * (FHeight-1)/FNumScaleSteps)-1;
               LineTo(X, Y);
               LineTo(X-3, Y);
               MoveTo(X, Y);
               if (FFreqBase > 0) or (FFreqScaleFactor > 1) then
                  Text := Format('%4.2f',[FFreqBase/1000+i*step])
               else
	          Text := IntToStr(Round(FFreqBase/1000+i*step-0.05));
               TextOutAligned(aBitmap.Canvas, X-5, Y, Text,SCALEFONT,SCALEFONTSIZE,1);{ right text }
            end;
            { write right scale text }
            if (FFreqBase = 0) and (FFreqScaleFactor = 1) then
               TextOutAligned(aBitmap.Canvas, 2, Height-5,
                             'KHz', SCALEFONT,SCALEFONTSIZE,0);
            { copy to screen }
            Canvas.Draw(-3, 0, aBitmap);

            { draw the right side }
            FillRect(Rect(0,0,aBitmap.Width,aBitmap.Height));
            X := 0;
            MoveTo(X, Height-BevelExtend-1);
            for i := 0 to FNumScaleSteps do
            begin
               Y := Height - BevelExtend - Trunc(i * (FHeight-1)/FNumScaleSteps)-1;
               LineTo(X, Y);
               LineTo(X+3, Y);
               MoveTo(X, Y);
               if (FFreqBase > 0) or (FFreqScaleFactor > 1) then
                  Text := Format('%4.2f',[FFreqBase/1000+i*step])
               else
	          Text := IntToStr(Round(FFreqBase/1000+i*step-0.05));
               TextOutAligned(aBitmap.Canvas, X+6, Y, Text, SCALEFONT,SCALEFONTSIZE,0);{ left text }
            end;
            { write right scale text }
            if (FFreqBase = 0) and (FFreqScaleFactor = 1) then
               TextOutAligned(aBitmap.Canvas, SCALEWIDTH-19, Height-5,
                              'KHz', SCALEFONT,SCALEFONTSIZE,0);
            { copy to screen }
            Canvas.Draw((Width - SCALEWIDTH)+3, 0, aBitmap);
         end;

      finally
         aBitmap.Free;
      end;
   end;
end;

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.DrawBar;
var
   i,Y: integer;
   aRect: TRect;

begin
   if (FBarWidth > 0) then
   begin
      if FAccelerate then
      with Canvas do
      begin
         Pen.Mode := pmCopy;
         Pen.Color := FBarColor;
         Pen.Width := 1;
         aRect := Rect(FClientRect.Left+Fx2,FClientRect.Top,
                       FClientRect.Left+Fx2,FClientRect.Bottom);
         MoveTo(aRect.Left, aRect.Top);
         LineTo(aRect.Left, aRect.Bottom);
         for i := 0 to FNumScaleSteps do
         begin
            Y := (BevelExtend+FHeight)-Trunc(i * (FHeight-1)/FNumScaleSteps)-1;
            SetPixel(Handle,aRect.Left, Y, FBarTickColor);
         end;
      end
      else
      with DIBCanvas do
      begin
         Pen.Mode := pmCopy;
         Brush.Color := FBarColor;
         if Fx2 > Fx1 then
         begin
            aRect := Rect(Fx1+1,0,Fx2+1,FHeight);
            FillRect(aRect);
         end
         else
         begin
            aRect := Rect(0,0,Fx2+1,FHeight);
            FillRect(aRect);
         end;
         Pen.Color := FBarTickColor;
         for i := 0 to FNumScaleSteps do
         begin
            Y := FHeight - Trunc(i * (FHeight-1)/FNumScaleSteps)-1;
            MoveTo(aRect.Left,Y);
            LineTo(aRect.Right,Y);
         end;
      end;
   end;
end;

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.DrawSelection(aCanvas: TMMDIBCanvas; sStart, sEnd: Longint;
                                  sColor: TColor; Solid: Boolean);
var
   rColor: Longint;
begin
   if (sStart >= 0) and (sEnd >= 0) then
   begin
      with aCanvas do
      begin
         DIB_SetTColor(sColor);
         if Solid then
         begin
            DIB_FillRectXor(Rect(sStart,0,sEnd+1,Height));
         end
         else
         begin
            DIB_SetTColor(sColor);
            DIB_HLineDashed(sStart,sEnd+1,0);
            DIB_HLineDashed(sStart,sEnd+1,Height-1);
            DIB_VLineDashed(sStart,0,Height-1);
            DIB_VLineDashed(sEnd,0,Height-1);
         end;
      end;
   end;
end;

{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.DrawLocator(aCanvas: TMMDIBCanvas; aPos: Longint; aColor: TColor);
begin
   with aCanvas do
   begin
      DIB_SetTColor(aColor);

      DIB_MoveTo(aPos,0);
      DIB_LineTo(aPos,FHeight);
   end;
end;

{$IFDEF WIN32}
{-- TMMSpectrogram ------------------------------------------------------}
procedure TMMSpectrogram.DrawInfo(Pos: TPoint);
var
   Text: String;
   aRect: TRect;
   Buf: array[0..255] of Char;
   DC: HDC;
   WindowHandle: HWND;

begin
   if FShowInfoHint then
   with DIBCanvas do
   begin
      if PtInRect(FClientRect,Pos) then
      begin
         Text := Format('%2.3f KHz', [GetFrequency(Pos)/1000]);
         Font.Name := 'MS Sans Serif';
         Font.Size := 8;
         Font.Style := [];
         {$IFDEF WIN32}
         Font.Color := clInfoText;
         {$ELSE}
         Font.Color := clBlack;
         {$ENDIF}
         aRect.Left := Pos.X-BevelExtend;
         if FDrawScale then dec(aRect.Left, SCALEWIDTH);
         aRect.Top := Pos.Y-BevelExtend+15;
         aRect.Right := aRect.Left + TextWidth(Text)+4;
         aRect.Bottom := aRect.Top + TextHeight(Text)+2;
         if (aRect.Bottom > FHeight) then OffsetRect(aRect,0,-40);
         if (aRect.Right > FWidth) then OffsetRect(aRect,FWidth-aRect.Right,0);
         if (aRect.Top < 0) then
         begin
            aRect.Top := 0;
            aRect.Bottom := TextHeight(Text)+2;
         end;

         {$IFDEF TRIAL}
         {$DEFINE _HACK3}
         {$I MMHACK.INC}
         {$ENDIF}

         if (SaveDC = 0) then
         begin
            { create memory DC for save bitmap }
            SaveDC := CreateCompatibleDC(DIBCanvas.Handle);
            { create bitmap to store background }
            SaveWidth := 10*TextWidth('W')+4;
            SaveHeight := TextHeight('W')+2;
            SaveBitmap := CreateCompatibleBitmap(DIBCanvas.Handle,SaveWidth,SaveHeight);
            OldBitmap := SelectObject(SaveDC, SaveBitmap);
            OldPalette := SelectPalette(SaveDC, DIBCanvas.Palette, False);
         end
         else
            { restore background }
            BitBlt(DIBCanvas.Handle,SaveInfoPos.X,
                   SaveInfoPos.Y,SaveWidth,SaveHeight,
                   SaveDC, 0,0,SRCCOPY);

         { save background }
         BitBlt(SaveDC,0,0,SaveWidth,SaveHeight,
                DIBCanvas.Handle,aRect.Left,aRect.Top,SRCCOPY);

         SaveInfoPos := aRect.TopLeft;

         Brush.Color := INFOCOLOR;
         Brush.Style := bsSolid;
         Pen.Color := clBlack;
         Rectangle(aRect.Left,aRect.Top,aRect.Right,aRect.Bottom);

         Brush.Style := bsClear;
         DrawText(Handle, StrPCopy(Buf, Text), -1, aRect,
                  DT_SINGLELINE	 or DT_VCENTER or DT_CENTER or DT_NOPREFIX);
         Brush.Style := bsSolid;
      end
      else if (SaveDC <> 0) then
      begin
         { restore background }
         BitBlt(DIBCanvas.Handle,SaveInfoPos.X,
                   SaveInfoPos.Y,SaveWi