unit1.~pas

来自「电气控制仿真软件」· ~PAS 代码 · 共 181 行

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, OleCtrls, vgctrl40_TLB;

type
  TForm1 = class(TForm)
    vgctrl1: Tvgctrl;
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    function CreateDianGan( x, y : double ) : IUnit;
  public
    procedure DrawGanTa( x, y : double );
    { Public declarations }
  end;

  TDPoint = record
    x, y : double;
  end;

  PDPoint = ^ADPoint;
  ADPoint = array[0..100000] of TDPoint;

var
  Form1: TForm1;

implementation

{$R *.dfm}

var
  OldVgProc : Pointer;
  FDrawGanTa : Boolean;
  ss : WideString;
procedure TForm1.Button1Click(Sender: TObject);
begin
  FDrawGanTa := True;
end;

function TForm1.CreateDianGan( x, y : double ) : IUnit;
var
  Sheet1 : ISheet;
begin
  Sheet1 := ISheet( vgctrl1.ActiveSheet );
  Result := IUnit( Sheet1.AddUnit( 'Shape', x - 10, y - 10, 20, 20 ) );
end;

procedure TForm1.DrawGanTa( x, y : double );
var
  msg : TMsg;
  LastUnit : IUnit;
  TempLine : ILine;
  Sheet1 : ISheet;
  Points : PDPoint;
  dp : TDPoint;
begin
  Sheet1 := ISheet( vgctrl1.ActiveSheet );
  SetCapture( vgctrl1.Handle );
  LastUnit := CreateDianGan( x, y );
  TempLine := ILine( Sheet1.AddUnit( 'Line', x, y, 0, 0 ) );
  TempLine.SetPropertyValue('LinkMode', 1);
  TempLine.Locked := true;
  while( GetMessage( msg, 0, 0, 0 ) ) do
  begin
    if ( msg.message = WM_LBUTTONDOWN ) then
    begin
      TempLine.SetLink( LastUnit, 'P0', 'Center' );
      dp.x := short( LOWORD( msg.lparam ) );
      dp.y := short(HIWORD( msg.lparam ) );
      Sheet1.ClientToView( Integer( @dp ) );
      LastUnit := CreateDianGan( dp.x, dp.y );
      TempLine.SetLink( LastUnit, 'P1', 'Center' );
      TempLine := ILine( Sheet1.AddUnit( 'Line', dp.x, dp.y, 0, 0 ) );
      TempLine.SetPropertyValue('LinkMode', 1);
      TempLine.Locked := true;
    end
    else if( msg.message = WM_MOUSEMOVE )then
    begin
      dp.x := short( LOWORD( msg.lparam ) );
      dp.y := short(HIWORD( msg.lparam ) );
      Sheet1.ClientToView( Integer( @dp ) );
      Points := PDPoint( TempLine.Points );
      Points^[1].x := dp.x;
      Points^[1].y := dp.y;
      TempLine.Refresh;
    end
    else if( msg.message = WM_RBUTTONDOWN )then
    begin
      Sheet1.DeleteUnit( TempLine );
      break;
    end
    else
    begin
      TranslateMessage( msg );
      DispatchMessage( msg );
    end;
  end;
  ReleaseCapture;
end;

function VgProc(h: HWND; uMsg: uint; wParam: uint; lParam: Longint): longint; stdcall;
var
  dp: TDPoint;
  Sheet1: ISheet;
  b: Boolean;
begin
  b := False;
  if( Form1.vgctrl1.SheetCount = 0 )then
  begin
    Form1.Caption := 'Hello';
    Exit;
  end;
  Sheet1 := ISheet(Form1.vgctrl1.ActiveSheet);
  dp.x := short(LOWORD(lParam));
  dp.y := short(HIWORD(lParam));
  sheet1.ClientToView(Integer(@dp));

  if uMsg = WM_LBUTTONDOWN then
  begin
    if FDrawGanTa then
    begin
      Sheet1.Cursor := 23;
      Form1.DrawGanTa(dp.x, dp.y);
      FDrawGanTa := false;
      Result := 0;
      Sheet1.Cursor := 0;
    end
    else
      b := True;
  end
  else
    if uMsg = WM_RBUTTONDOWN then
    begin
      if Sheet1.UnitAtPoint(dp.x, dp.y, nil) = nil then
      begin
        Result := 0;
      end
      else
        b := True;
    end
    else
      if uMsg = WM_KEYDOWN then
      begin
        if wParam = VK_ESCAPE then
        begin
          Form1.vgctrl1.Edit;
          Result := 0;
        end
        else
          b := True;
      end
      else
        b := True;

  if b then
    Result := CallWindowProc(OldVgProc, h, uMsg, wParam, lParam);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  vgctrl1.Design('');
  vgctrl1.ShowRuler := true;
  vgctrl1.Execute('SystemParams.ScrollBarMode=1');
  vgctrl1.Execute('SystemParams.CenterLink=true');
  OldVgProc := Pointer(SetWindowLong( vgctrl1.Handle, GWL_WNDPROC, Longint( @VgProc ) ));
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  Close();
end;

end.