_gclass.pas

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

  if FFormatStr <> Value then begin
    FFormatStr := Value;
    Change;
  end;
end;


procedure TAbCustomScale.SetTextAlignment(Value : ToPos);
begin
  if FTextAlignment <> Value then begin
    FTextAlignment := Value;
    Change;
  end;
end;

procedure TAbCustomScale.SetTextOffsetX(Value : Integer);
begin
  if FTextOffsetX <> Value then begin
    FTextOffsetX := Value;
    Change;
  end;
end;

procedure TAbCustomScale.SetTextOffsetY(Value : Integer);
begin
  if FTextOffsetY <> Value then begin
    FTextOffsetY := Value;
    Change;
  end;
end;

procedure TAbCustomScale.SetText(Value : String);
begin
  if FText <> Value then begin
    FText := Value;
    Change;
  end;
end;


constructor TAbCustomScale.Create;
begin
  inherited Create;
  FFont := TFont.Create;
  FFont.OnChange := ChangeObject;
  FFormatStr := '##0.#';
  FStepLines := TAbLineSettings.Create;
  FStepLines.Pen.Color := clWhite;
  FStepLines.Pen.Width := 2;
  FStepLines.OnChange := ChangeObject;
  FTextAlignment := toMidCenter;
  FSubStepLines := TAbLineSettings.Create;
  FSubStepLines.Pen.Color := clSilver;
  FSubStepLines.OnChange := ChangeObject;
end;

destructor TAbCustomScale.Destroy;
begin
  FFont.Free;
  FStepLines.Free;
  FSubStepLines.Free;
  inherited Destroy;
end;

{XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
X      TAbFlexScale
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}
Procedure TAbFlexScale.SetSubStepAt(Value : Single);
begin
  if (FSubStepAt <> Value) and (Value > 0) then begin
    FSubStepAt := Value;
    Change;
  end;
end;

procedure TAbFlexScale.SetStepMulti(Value : Integer);
begin
  if (FStepMulti <> Value) and (Value > 0) then begin
    FStepMulti := Value;
    Change;
  end;
end;

procedure TAbFlexScale.SetSubStepsVis(Value : Integer);
begin
  if (FSubStepsVis <> Value) and (Value > 0) then begin
    FSubStepsVis := Value;
    Change;
  end;
end;


{XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
X        TAbText
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}
constructor TAbText.Create;
begin
  inherited create;
  FFont := TFont.Create;
  FFont.OnChange := ChangeObject;
  FVisible := true;
end;

destructor TAbText.Destroy;
begin
  FFont.Free;
  inherited destroy;
end;

procedure TAbText.SetText(Value : String);
begin
  if FText <> Value then begin
    FText := Value;
    Change;
  end;
end;

procedure TAbText.SetOffsetX(Value : Integer);
begin
  if FOffsetX <> Value then begin
    FOffsetX := Value;
    Change;
  end;
end;

procedure TAbText.SetOffsetY(Value : Integer);
begin
  if FOffsetY <> Value then begin
    FOffsetY := Value;
    Change;
  end;
end;

procedure TAbText.SetPos(Value : toPos);
begin
  if FPos <> Value then begin
    FPos := Value;
    Change;
  end;
end;

procedure TAbText.SetVisible(Value : Boolean);
begin
  if FVisible <> Value then begin
    FVisible := Value;
    Change;
  end;
end;

procedure TAbText.SetFont(Value : TFont);
begin
   FFont.Assign(Value);
end;

{XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
X        TAbValInd
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}
constructor TAbValInd.Create;
begin
  inherited create;
  FBevel := TAbBevelSettings.Create;
  FBevel.SwapColors;
  FBevel.Width := 2;
  FBevel.OnChange := ChangeObject;

  FCaption := TAbText.Create;
  FCaption.OnChange := ChangeObject;
 // FBevel.ColorFrom := clRed;
  FTxtSpacing := TAbOffset.Create;
  FTxtSpacing.OnChange := ChangeObject;

  FVisible := true;
{  FOffset.Left := -1;
  FOffset.Top := -1;
  FOffset.Right := -1;
  FOffset.Bottom := -1;
}
  FFormatStr := '##0.0';
  FFont := TFont.Create;
  FFont.Color := clLime;
  FFont.Name := 'Arial';
  FFont.Style := [fsBold];
  FFont.Size := 10;
  FFont.OnChange := ChangeObject;
end;

procedure TAbValInd.SetFormatStr(Value : String);
begin
  if FFormatStr <> Value then begin
    FFormatStr := Value;
    Change;
  end;
end;

procedure TAbValInd.SetFont(Value : TFont);
begin
   FFont.Assign(Value);
end;

procedure TAbValInd.SetColor(Value : TColor);
begin
  if FColor <> Value then begin
    FColor := Value;
    Change;
  end;
end;

procedure TAbValInd.SetVisible(Value : Boolean);
begin
  if FVisible <> Value then begin
    FVisible := Value;
    Change;
  end;
end;

procedure TAbValInd.SetOffsetX(Value : Integer);
begin
  if FOffsetX <> Value then begin
    FOffsetX := Value;
    Change;
  end;
end;

procedure TAbValInd.SetOffsetY(Value : Integer);
begin
  if FOffsetY <> Value then begin
    FOffsetY := Value;
    Change;
  end;
end;

destructor TAbValInd.Destroy;
begin
  FBevel.Free;
  FCaption.Free;
  FFont.Free;
  FTxtSpacing.Free;
  inherited;
end;

procedure TAbValInd.DrawValue(can: TCanvas; Value : Real);
var
  bmp : TBitmap;
begin
  if not FVisible then exit;
  bmp := TBitmap.Create;

  with bmp.Canvas do begin
    Font := FFont;
    Pen.Color   := FColor;
    Brush.Color := FColor;

    bmp.Width  := rInd.Right - rInd.Left;
    bmp.Height := rInd.Bottom - rInd.Top;

    Rectangle(0,0,bmp.Width,bmp.Height);

    AbTextOut(bmp.Canvas,bmp.Width-wCorr+1, 0, FormatFloat(FFormatStr, Value), toTopRight);
  end;

  can.Draw(rInd.left, rInd.top, bmp);

  bmp.free;

end;

procedure TAbValInd.Draw(can: TCanvas; xyPos : TPoint; pos : toPos);
var
  h, w : Integer;
  x,y : Integer;
  th : integer;
  cp : TPoint;
begin
{-------------------------------------------------------------------------------
--------------------------------------------------------------------------------}

  if not FVisible then exit;

  x := 0;
  y := 0;

  with can do begin
    Font := FFont;
    th := TextHeight(FFormatStr);
    wCorr := (th Div 7);
    w := TextWidth(FFormatStr) + 2 * FBevel.Width+ wCorr * 2 + FTxtSpacing.Left + FTxtSpacing.Right;
    h := th + 2 * FBevel.Width + FTxtSpacing.Top + FTxtSpacing.Bottom;

    case Pos of
      toTopLeft: begin
                    x := FOffsetX + 1+ xyPos.x;
                    y := FOffsetY + xyPos.y;
                 end;
      toTopCenter: begin
                    x := FOffsetX + 1+ xyPos.x - w div 2;
                    y := FOffsetY + xyPos.y;
                 end;
      toTopRight: begin
                    x := FOffsetX + 1+ xyPos.x - w;
                    y := FOffsetY + xyPos.y;
                 end;
      toMidLeft: begin
                    x := FOffsetX + 1+ xyPos.x;
                    y := FOffsetY + xyPos.y - h div 2;
                 end;
      toMidCenter: begin
                    x := FOffsetX + 1+ xyPos.x - w div 2;
                    y := FOffsetY + xyPos.y - h div 2;
                 end;
      toMidRight: begin
                    x := FOffsetX + 1+ xyPos.x - w;
                    y := FOffsetY + xyPos.y - h div 2;
                 end;
      toBotLeft: begin
                    x := FOffsetX + 1+ xyPos.x;
                    y := FOffsetY + xyPos.y - h;
                 end;
      toBotCenter: begin
                    x := FOffsetX + 1+ xyPos.x - w div 2;
                    y := FOffsetY + xyPos.y - h;
                 end;
      toBotRight: begin
                    x := FOffsetX + 1+ xyPos.x - w;
                    y := FOffsetY + xyPos.y - h;
                 end;
    end;


    rInd := Rect(x, y, x + w, y + h);
    cp := AbCenterPoint(rInd);

    if FCaption.Visible then begin
      can.Font := FCaption.FFont;
      can.Brush.Style := bsClear;
      x := FCaption.FOffsetX;
      y := FCaption.FOffsetY;

      case FCaption.FPos of
        toTopLeft: AbTextOut(can,x + rInd.Left,y + rInd.Top, FCaption.FText, toBotLeft);
        toTopCenter: AbTextOut(can,x + cp.x,y + rInd.Top, FCaption.FText, toBotCenter);
        toTopRight: AbTextOut(can,x + rInd.Right,y + rInd.Top, FCaption.FText, toBotRight);

        toMidLeft: AbTextOut(can,x + rInd.Left-1,y + cp.y, FCaption.FText, toMidRight);
        toMidCenter: AbTextOut(can,x + cp.x,y + cp.y, FCaption.FText, toMidCenter);
        toMidRight: AbTextOut(can,x + rInd.Right,y + cp.y, FCaption.FText, toMidLeft);

        toBotLeft: AbTextOut(can,x + rInd.Left,y + rInd.Bottom, FCaption.FText, toTopLeft);
        toBotCenter: AbTextOut(can,x + cp.x,y + rInd.Bottom, FCaption.FText, toTopCenter);
        toBotRight: AbTextOut(can,x + rInd.Right,y + rInd.Bottom, FCaption.FText, toTopRight);
      end;

      can.Font := FFont;
      can.Brush.Style := bsSolid;
    end;

    Pen.Color := FColor;
    Brush.Color := FColor;

    Rectangle(rInd.left, rInd.top, rInd.right, rInd.bottom);

    Frame3D(Can, rInd, FBevel.ColorFrom, FBevel.ColorTo, FBevel.Width);


    AbTextOut(Can,rInd.right-wCorr+1-FTxtSpacing.Right, rInd.Top+FTxtSpacing.Top, FFormatStr, toTopRight);

//    rInd.Right := rInd.Right - hf;
{    Pen.Color := clRed;
    Brush.Color := clRed;

    Rectangle(rInd);
 }  AbMultiBorder(rInd,FTxtSpacing.Left,FTxtSpacing.Top,FTxtSpacing.Right,FTxtSpacing.Bottom);


  end;

end;



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

procedure TAbPersistent.ChangeObject(Sender: TObject);
begin
  if Assigned(FOnChange) then FOnChange(Sender);
end;

{XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
X        TAbBevelSettings
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}
procedure TAbBevelSettings.SwapColors;
var
  col : TColor;
begin
  col := FColorFrom;
  FColorFrom := FColorTo;
  FColorTo := Col;
  Change;
end;

procedure TAbBevelSettings.SetColorFrom(Value  : TColor);
begin
  if FColorFrom <> Value then begin
    FColorFrom := Value;
    Change;
  end;
end;

procedure TAbBevelSettings.SetColorTo(Value : TColor);
begin
  if FColorTo <> Value then begin
    FColorTo := Value;
    Change;
  end;
end;

procedure TAbBevelSettings.SetWidth(Value : Integer);
begin
  if FWidth <> Value then begin
    FWidth := Value;
    Change;
  end;
end;

constructor TAbBevelSettings.Create;
begin
  inherited Create;
  FColorFrom := clWhite;
  FColorTo := $00737373;
  FWidth := 2;
end;
//==============================================================================

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