abprttrd.pas

著名的虚拟仪表控件,包含全部源码, 可以在,delphi2007 下安装运行

    PaintPreview;
  end;

end;


constructor TAbPrintTrend.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

   {xxxxxxxxxxx Abakus-Info's xxxxxxxxxxxxx}
  AbInfo := LoadAbakusInfo;
   {xxxxxxxxxxx Abakus-Info's xxxxxxxxxxxxx}

  FLegend := TLegend.Create;
  FLegend.OnChange := ParamChange;

  Format := Metric;

  FLegend.FMargin := 20;

  FFont := TFont.Create;
  FFont.OnChange := ParamChange;
  FFont.Name := 'Arial';
  FPreviewZoom := 0.6;
  FLogPixelScreen := Screen.PixelsPerInch;
  FOptions := [ptCaption, ptLegend, ptColor, ptVerticalScale, ptUseTrdBkCol];
  LogPixelPrinter := 300;
  FWidth := 2700;
  FHeight := 1900;
  FFontSize := 26;
  FFontSizeCaption := 60;
  FScaleSpacing := 10;
  FTrendSpace := 20;
  FRecFrom := 0;
  FRecTo := MaxInt;
  FTimeScaleSteps := 5;
  FOuterBorder := 20;
  FBkColor := clWhite;
  CalcPixelSize;
end;

destructor TAbPrintTrend.Destroy;
begin
  if Assigned(FPreviewPaintBox) then
  begin
    FPreviewPaintBox.OnPaint := nil;
    FPreviewPaintBox.Invalidate;
  end;
  FLegend.Destroy;
  FFont.Free;
  inherited Destroy;
end;

procedure TAbPrintTrend.ParamChange(Sender: TObject);
begin
  CalcPixelSize;
  PaintPreview;
  if Assigned(FOnSettingsChange) then FOnSettingsChange(self);
end;

procedure TAbPrintTrend.SetScaleSpacing(Value: Integer);
begin
  FScaleSpacing := Value;
  ParamChange(self);
end;

procedure TAbPrintTrend.SetTrendSpace(Value: Integer);
begin
  FTrendSpace := Value;
  ParamChange(self);
end;


procedure TAbPrintTrend.SetFontSize(Value: Integer);
begin
  FFontSize := Value;
  ParamChange(self);
end;

procedure TAbPrintTrend.SetFontSizeCaption(Value: Integer);
begin
  FFontSizeCaption := Value;
  ParamChange(self);
end;

procedure TAbPrintTrend.SetLogPixelScreen(Value: Integer);
var
  Factor            : Single;
begin
  if Value <> FLogPixelScreen then
  begin
    if Format = Pixel then
    begin
      Factor := Value / FLogPixelScreen;
      FWidth := Round(FWidth * Factor);
      FHeight := Round(FHeight * Factor);
      FFontSize := Round(FFontSize * Factor);
      FFontSizeCaption := Round(FFontSizeCaption * Factor);
      FScaleSpacing := Round(FScaleSpacing * Factor);
      FTrendSpace := Round(FTrendSpace * Factor);
      FOuterBorder := Round(FOuterBorder * Factor);
      FLegend.FMargin := Round(FLegend.FMargin * Factor);
    end;
    FLogPixelScreen := Value;
    ParamChange(self);
  end;
end;

procedure TAbPrintTrend.SetHeight(Value: Integer);
begin
  FHeight := Value;
  ParamChange(self);
end;

procedure TAbPrintTrend.SetWidth(Value: Integer);
begin
  FWidth := Value;
  ParamChange(self);
end;

procedure TAbPrintTrend.SetFormat(Value: TFormat);
var
  Factor            : Single;
begin
  if Value <> FFormat then
  begin
    if FFormat = Pixel then
    begin
      if Value = Metric then
      begin
        Factor := 254 / FLogPixelScreen;
      end
      else
      begin                             {Inch}
        Factor := 100 / FLogPixelScreen;
      end;
    end
    else
      if FFormat = Metric then
      begin
        if Value = Pixel then
        begin
          Factor := FLogPixelScreen / 254;
        end
        else
        begin                           {Inch}
          Factor := 0.3937;
        end;
      end
      else
      begin                             {Inch}
        if Value = Pixel then
        begin
          Factor := FLogPixelScreen / 100;
        end
        else
        begin                           {Metric}
          Factor := 2.54;
        end;
      end;
    FWidth := Round(FWidth * Factor);
    FHeight := Round(FHeight * Factor);
    FFontSize := Round(FFontSize * Factor);
    FScaleSpacing := Round(FScaleSpacing * Factor);
    FTrendSpace := Round(FTrendSpace * Factor);
    FOuterBorder := Round(FOuterBorder * Factor);
    FFontSizeCaption := Round(FFontSizeCaption * Factor);
    FLegend.FMargin := Round(FLegend.FMargin * Factor);
    FFormat := Value;
    ParamChange(self);
  end;                                  {If Value <> FFormat}
end;


procedure TAbPrintTrend.AbDrawHLines(can: TCanvas);
var
  n                 : Integer;
  y                 : Integer;
begin
  for n := 0 to Trend.GridYSteps do
  begin
    y := Round(r.Top + ((r.Bottom - r.Top - 1) / Trend.GridYSteps) * n);
    can.Pen.Style := psDot;
    can.moveTo(r.Left, y);
    can.LineTo(r.Right, y);
    can.Pen.Style := psSolid;
    can.LineTo(r.Right + Round(tInPixel * poFactor), y);
  end;
end;

procedure TAbPrintTrend.AbDrawScale(can: TCanvas; no: Integer);

var
  n                 : Integer;
  stepH             : Single;
  y                 : Integer;
  ScaleText, txt    : string;
  w, h              : Integer;
  tw                : Integer;
  hFont, FontOld    : Integer;
  FontName          : string;
begin
  hFont := 0;
  FontOld := 0;

  if (ptVerticalScale in Options) then
  begin
    FontName := Font.Name + #0;
    hFont := createFont(-Round(fInPixel * poFactor), 0, 900, 0, fw_normal, 0, 0,
      0, 1, 4, $10, 2, 4, @FontName[1]);
    FontOld := SelectObject(can.Handle, hFont);
  end;

  ScaleText := AbRangeStr(Trend.FChannel[no].ValueFrom,
  Trend.FChannel[no].ValueTo, Trend.GridYSteps,
  Trend.FChannel[no].ValueFormat);
  AbGetMaxTokenSize(can, w, h, ScaleText);
  stepH := (r.Bottom - r.Top - 1) / Trend.GridYSteps;
  can.Brush.Style := bsSolid;

  can.Font.Color := clBlack;
  if (ptVerticalScale in Options) then
  begin
    for n := 0 to Trend.GridYSteps do
    begin
      y := Round(r.Top + stepH * n);
      txt := AbStrToken(ScaleText, ';');
      tw := can.TextWidth(txt);
      if not ((n = 1) or (n = Trend.GridYSteps - 1)) then
        can.textout(r.Right - h, y + (tw div 2), txt);
    end;

    y := Round(r.Top + stepH * 1);
    tw := can.TextWidth(Trend.FChannel[no].ValueUnit);
    can.textout(r.Right - h, y + (tw div 2), Trend.FChannel[no].ValueUnit);

    can.Font.Color := clBlack;
    if (ptColor in FOptions) then
      can.Brush.Color := Trend.FChannel[no].Color
    else
      can.Brush.Color := clSilver;
    can.Brush.Style := bsSolid;

    y := Round(r.Top + stepH * (Trend.GridYSteps - 1));
    txt := ' ch' + IntToStr(no) + ' ';
    tw := can.TextWidth(txt);
    can.textout(r.Right - h, y + (tw div 2), txt);

    r.Right := r.Right - can.Textheight('X') - Round(sInPixel * poFactor);

    SelectObject(can.Handle, FontOld);
    DeleteObject(hFont);

  end
  else
  begin                                 {vertical scale}

    for n := 0 to Trend.GridYSteps do
    begin
      y := Round(r.Top + stepH * n);
      txt := AbStrToken(ScaleText, ';');
      if not ((n = 1) or (n = Trend.GridYSteps - 1)) then
        AbTextOut(can, r.Right, y, txt, toMidRight);
    end;
    y := Round(r.Top + stepH);
    if (Trend.FChannel[no].ValueUnit <> '') then
      AbTextOut(can, r.Right, y, Trend.FChannel[no].ValueUnit, toMidRight);

    y := Round(r.Top + stepH * (Trend.GridYSteps - 1));

    can.Font.Color := clBlack;
    if (ptColor in FOptions) then
      can.Brush.Color := Trend.FChannel[no].Color
    else
      can.Brush.Color := clSilver;

    can.Brush.Style := bsSolid;
    txt := ' ' + IntToStr(no) + ' ';
    AbTextOut(can, r.Right, y, txt, toMidRight);

    r.Right := r.Right - MaxFontWidth - Round(sInPixel * poFactor);

  end;
  can.Font.Color := clBlack;
  can.Brush.Color := clWhite;

end;

{==============================================================================}

constructor TLegendCaptions.Create;
begin
  inherited Create;
  FChannelNo := 'ChNo';
  FName1 := 'Name1';
  FName2 := 'Name2';
  FMin := 'Min';
  FMinTime := 'MinTime';
  FMax := 'Max';
  FMaxTime := 'MaxTime';
  FlUnit := 'Unit';
end;

procedure TLegendCaptions.Change;
begin
  if Assigned(FOnChange) then FOnChange(self);
end;


procedure TLegendCaptions.SetChannelNo(Value: string);
begin
  if FChannelNo <> Value then
  begin
    FChannelNo := Value;
    Change(self);
  end;
end;

procedure TLegendCaptions.SetName1(Value: string);
begin
  if FName1 <> Value then
  begin
    FName1 := Value;
    Change(self);
  end;
end;

procedure TLegendCaptions.SetName2(Value: string);
begin
  if FName2 <> Value then
  begin
    FName2 := Value;
    Change(self);
  end;
end;

procedure TLegendCaptions.SetMin(Value: string);
begin
  if FMin <> Value then
  begin
    FMin := Value;
    Change(self);
  end;
end;

procedure TLegendCaptions.SetMinTime(Value: string);
begin
  if FMinTime <> Value then
  begin
    FMinTime := Value;
    Change(self);
  end;
end;

procedure TLegendCaptions.SetMax(Value: string);
begin
  if FMax <> Value then
  begin
    FMax := Value;
    Change(self);
  end;
end;

procedure TLegendCaptions.SetMaxTime(Value: string);
begin
  if FMaxTime <> Value then
  begin
    FMaxTime := Value;
    Change(self);
  end;
end;

procedure TLegendCaptions.SetlUnit(Value: string);
begin
  if FlUnit <> Value then
  begin
    FlUnit := Value;
    Change(self);
  end;
end;

{==============================================================================}

constructor TLegend.Create;
begin
  inherited Create;
  FCaptions := TLegendCaptions.Create;
  FCaptions.OnChange := Change;
  FOptions := [loName1, loName2, loMin, loMinTime, loMax, loMaxTime, loUnit];
  FMargin := 20;
end;

destructor TLegend.Destroy;
begin
  FCaptions.Destroy;
  inherited Destroy;
end;

procedure TLegend.Change;
begin
  if Assigned(FOnChange) then FOnChange(self);
end;

procedure TLegend.SetCaptions(Value: TLegendCaptions);
begin
  if FCaptions <> Value then
  begin
    FCaptions := Value;
    Change(self);
  end;
end;

procedure TLegend.SetOptions(Value: TLegendOptions);
begin
  if FOptions <> Value then
  begin
    FOptions := Value;
    Change(self);
  end;
end;

procedure TLegend.SetPosition(Value: TLegendPos);
begin
  if FPosition <> Value then
  begin
    FPosition := Value;
    Change(self);
  end;
end;

procedure TLegend.SetMargin(Value: Integer);
begin
  if FMargin <> Value then
  begin
    FMargin := Value;
    Change(self);
  end;
end;

{==============================================================================}

end.