abirdlg.pas

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

unit AbIRDlg;

{******************************************************************************}
{ Abakus VCL                                                                   }
{                    Property-editor to adjust indRect                         }
{                      belongs to TAbOperatingPoint                            }
{                                                                              }
{******************************************************************************}
{        e-Mail: [e-mail] , Web: http://www.abaecker.com            }
{------------------------------------------------------------------------------}
{          (c) Copyright 1998..2001 A.Baecker, All rights Reserved             }
{******************************************************************************}

{$I Abks.inc}

interface

uses
  Windows,
  Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  extctrls, StdCtrls,
  Buttons,
  {$IFDEF D6} DesignWindows, DesignEditors, DesignIntf, {$ELSE} DsgnIntf, {$ENDIF}
  {****** Abakus VCL - Units ******}
  _AbProc,
  AbOpPnt;

type
  TAbIndRectDlg = class(TForm)
    PaintBox1: TPaintBox;
    BitBtn1: TBitBtn;
    BitBtn2: TBitBtn;
    Label1: TLabel;

    procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; x, y: Integer);
    procedure PaintBox1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; x, y: Integer);
    procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; x,
      y: Integer);
    procedure FormCreate(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
    procedure CorrectRect(var r: TRect);
    procedure Mark(no: Integer; p: TPoint);
    procedure MarkRect(can: TCanvas; r: TRect);
  end;

  TAbIndRectEditor = class(TPropertyEditor)
  public
    procedure edit; override;
    function GetAttributes: TPropertyAttributes; override;
    function GetValue: string; override;
  end;

var
  Bmp               : TBitmap;
  TempBmp           : TBitmap;
  MaxRect           : TRect;
  xClick            : Integer;
  yClick            : Integer;
  rClick            : TRect;

  MarkBoxes         : array[0..9] of TRect; {   0..7 die markierungs-boxen,
                                         8 der innere Zeichenbereich
                                         9 au遝rhalb}
  SelBox            : Integer;          {nr der gew鋒lten Box}
  xyRect            : TRect;            {rechteck des xy zeichenbereichs}
  MsDown            : Boolean;          {maustaste wurde gedr點kt}


implementation

{$R *.DFM}

procedure TAbIndRectEditor.edit;
var
  AbIndRectDlg      : TAbIndRectDlg;
begin
  AbIndRectDlg := TAbIndRectDlg.Create(Application);
  AbLoadFormPos(AbIndRectDlg);
  try
    with AbIndRectDlg do
    begin
      xyRect := (GetComponent(0) as TAbOperatingPoint).IndRect.GetxyRect;
      Bmp.Assign((GetComponent(0) as TAbOperatingPoint).CharacteristicBMP);
      if Bmp.Empty then
      begin
        if ClientWidth < 185 then ClientWidth := 185;
        if ClientHeight < 65 then ClientHeight := 65;
      end
      else
      begin
        if Bmp.Width > ClientWidth then ClientWidth := Bmp.Width;
        if (Bmp.Height + 35) > ClientHeight then
          ClientHeight := Bmp.Height + 35;
        Label1.Visible := false;
      end;
      TempBmp.Width := Bmp.Width;
      TempBmp.Height := Bmp.Height;
      PaintBox1.Width := Bmp.Width;
      PaintBox1.Height := Bmp.Height;
      MaxRect := PaintBox1.ClientRect;
      AbBorder(MaxRect, 4);

      if (showModal = mrOK) and not (Bmp.Empty) then
      begin
        (GetComponent(0) as TAbOperatingPoint).IndRect.SetxyRect(xyRect);
        (GetComponent(0) as TAbOperatingPoint).Invalidate;
      end;
    end;
  finally
    AbSaveFormPos(AbIndRectDlg);
    AbIndRectDlg.Free;
  end;
end;

function TAbIndRectEditor.GetAttributes: TPropertyAttributes;
begin
  Result := [paDialog];
end;

function TAbIndRectEditor.GetValue: string;
begin
  result := '(TAbIndRect)';
end;


procedure TAbIndRectDlg.CorrectRect(var r: TRect);
var
  HRect             : TRect;
begin
  HRect := r;
  if r.Left > r.Right then
  begin
    r.Left := HRect.Right;
    r.Right := HRect.Left;
  end;

  if r.Top > r.Bottom then
  begin
    r.Top := HRect.Bottom;
    r.Bottom := HRect.Top;
  end;
end;

procedure TAbIndRectDlg.Mark(no: Integer; p: TPoint);
var
  w                 : Integer;
begin
  w := 4;
  MarkBoxes[no] := Rect(p.x - w, p.y - w, p.x + w, p.y + w);
end;

procedure TAbIndRectDlg.MarkRect(can: TCanvas; r: TRect);
var
  w, h, n           : Integer;
begin
  w := r.Right - r.Left;
  h := r.Bottom - r.Top;

  with can do
  begin
    Pen.Color := clLime;
    Pen.Width := clBlack;
    Brush.Style := bsClear;
    Rectangle(r.Left, r.Top, r.Right, r.Bottom);

    Pen.Color := clBlack;
    Brush.Color := clLime;
    Brush.Style := bsSolid;
    Mark(0, Point(r.Left, r.Top));
    Mark(1, Point(r.Left + w div 2, r.Top));
    Mark(2, Point(r.Right, r.Top));
    Mark(3, Point(r.Right, r.Top + h div 2));
    Mark(4, Point(r.Right, r.Bottom));
    Mark(5, Point(r.Left + w div 2, r.Bottom));
    Mark(6, Point(r.Left, r.Bottom));
    Mark(7, Point(r.Left, r.Top + h div 2));
    MarkBoxes[8] := r;
    for n := 0 to 7 do
    begin
      Rectangle(MarkBoxes[n].Left, MarkBoxes[n].Top, MarkBoxes[n].Right,
        MarkBoxes[n].Bottom);
    end;
    MarkBoxes[9] := Cliprect;
  end;
end;

procedure TAbIndRectDlg.PaintBox1MouseDown(Sender: TObject; Button:
  TMouseButton;
  Shift: TShiftState; x, y: Integer);
begin
  if SelBox <> 9 then
  begin
    TempBmp.Canvas.Draw(0, 0, Bmp);
    MsDown := true;
    TempBmp.Canvas.Pen.Color := clLime;
    TempBmp.Canvas.Pen.Width := 1;
    TempBmp.Canvas.Brush.Color := clBlack;
    TempBmp.Canvas.Brush.Style := bsClear;
    TempBmp.Canvas.Rectangle(xyRect.Left, xyRect.Top, xyRect.Right,
      xyRect.Bottom);
    PaintBox1.Canvas.Draw(0, 0, TempBmp);
  end;
  xClick := x;
  yClick := y;
  rClick := xyRect;
end;

procedure TAbIndRectDlg.PaintBox1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; x, y: Integer);
begin
  MsDown := false;

  CorrectRect(xyRect);
  AbRectIntersection(MaxRect, xyRect, xyRect);

  TempBmp.Canvas.Draw(0, 0, Bmp);
  TempBmp.Canvas.Pen.Color := clLime;
  TempBmp.Canvas.Pen.Width := 1;
  MarkRect(TempBmp.Canvas, xyRect);
  PaintBox1.Canvas.Draw(0, 0, TempBmp);
end;

procedure TAbIndRectDlg.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState;
  x,
  y: Integer);
var
  n                 : Integer;
  xDiff, yDiff      : Integer;
begin
  xDiff := x - xClick;
  yDiff := y - yClick;

  TempBmp.Canvas.Draw(0, 0, Bmp);

  if MsDown then
  begin
    TempBmp.Canvas.Pen.Color := clLime;
    TempBmp.Canvas.Pen.Width := 1;
    TempBmp.Canvas.Brush.Color := clBlack;
    TempBmp.Canvas.Brush.Style := bsClear;
    case SelBox of
      0:
        begin
          xyRect.Top := y;
          xyRect.Left := x;
        end;
      1: xyRect.Top := y;
      2:
        begin
          xyRect.Top := y;
          xyRect.Right := x;
        end;
      3: xyRect.Right := x;
      4:
        begin
          xyRect.Right := x;
          xyRect.Bottom := y;
        end;
      5: xyRect.Bottom := y;
      6:
        begin
          xyRect.Bottom := y;
          xyRect.Left := x;
        end;
      7: xyRect.Left := x;
      8:
        begin
          xyRect.Left := rClick.Left + xDiff;
          xyRect.Top := rClick.Top + yDiff;
          xyRect.Right := rClick.Right + xDiff;
          xyRect.Bottom := rClick.Bottom + yDiff;
        end;
    end;

    TempBmp.Canvas.Rectangle(xyRect.Left, xyRect.Top, xyRect.Right,
      xyRect.Bottom);
    PaintBox1.Canvas.Draw(0, 0, TempBmp);
  end
  else
  begin
    for n := 0 to 9 do
    begin
      if AbInRect(x, y, MarkBoxes[n]) then
      begin
        case n of
          0, 4: Cursor := crSizeNWSE;
          1, 5: Cursor := crSizeNS;
          2, 6: Cursor := crSizeNESW;
          3, 7: Cursor := crSizeWE;
          8, 9: Cursor := crDefault;
        end;
        SelBox := n;
        Break;
      end;
    end;
  end;

end;

procedure TAbIndRectDlg.FormCreate(Sender: TObject);
var
  Datei             : string;
begin
  Datei := 'C:\1_Test\OpPoint\generator3.bmp';
  Bmp := TBitmap.Create;
  Bmp.Width := 100;
  Bmp.Height := 100;
  TempBmp := TBitmap.Create;
  with Bmp.Canvas do
  begin
    Pen.Color := clBlack;
    Brush.Color := clWhite;
    Rectangle(0, 0, Bmp.Width, Bmp.Height);
  end;

end;

procedure TAbIndRectDlg.PaintBox1Paint(Sender: TObject);
begin

  TempBmp.Canvas.Draw(0, 0, Bmp);
  MarkRect(TempBmp.Canvas, xyRect);
  PaintBox1.Canvas.Draw(0, 0, TempBmp);

end;

procedure TAbIndRectDlg.FormDestroy(Sender: TObject);
begin
  Bmp.Free;
  TempBmp.Free;
end;

end.