main.pas

来自「FlexGraphics是一套创建矢量图形的VCL组件」· PAS 代码 · 共 334 行

unit Main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  FlexBase, FlexUtils, FlexPath, FlexControls, Buttons, ExtCtrls;

type
  TfmMain = class(TForm)
    Panel2: TPanel;
    sbtMainScheme: TSpeedButton;
    sbtZoom: TSpeedButton;
    sbtAbout: TSpeedButton;
    sbtExit: TSpeedButton;
    fpMain: TFlexPanel;
    Panel1: TPanel;
    sbtPan: TSpeedButton;
    sbtVehicles: TSpeedButton;
    tmMarquee: TTimer;
    sbtLayers: TSpeedButton;
    procedure sbtExitClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure sbtAboutClick(Sender: TObject);
    procedure sbtMainSchemeClick(Sender: TObject);
    procedure sbtZoomClick(Sender: TObject);
    procedure fpMainMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure sbtPanClick(Sender: TObject);
    procedure fpMainNotify(Sender: TObject; Control: TFlexControl;
      Notify: TFlexNotify);
    procedure fpMainMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure sbtVehiclesClick(Sender: TObject);
    procedure tmMarqueeTimer(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure fpMainPaintOver(ACanvas: TCanvas; AControl: TFlexControl;
      ChildrenOnly, SelectedOnly: Boolean);
    procedure sbtLayersClick(Sender: TObject);
    procedure FormKeyUp(Sender: TObject; var Key: Word;
      Shift: TShiftState);
  private
    { Private declarations }
    FLastControl: TFlexControl;
    FCopyright: TFlexControl;
    FBoundaries: TFlexControl;
    FActiveControl: TFlexControl;
    FMarqueeBrush: TBrush;
    FMarqueeDisp: integer;
    procedure BestFit;
    function  GetIdahoScheme: TFlexCustomScheme;
    procedure SetActiveControl(const Value: TFlexControl);
    function  CreateControlRegion(Control: TFlexControl): HRGN;
    procedure RefreshMarquee;
  public
    { Public declarations }
    function  GeneratePos: TPoint;
    property  IdahoScheme: TFlexCustomScheme read GetIdahoScheme;
    property  ActiveControl: TFlexControl read FActiveControl
      write SetActiveControl;
  end;

var
  fmMain: TfmMain;

implementation

uses fSplash, fAboutPrg, Vehicles, Layers;

{$R *.DFM}

function CreateMarqueeBrush(Color: TColor): TBrush;
var B: TBitmap;
    x,y,n: integer;
begin
 // Create brush texture
 B := TBitmap.Create;
 B.Width := 8;
 B.Height := 8;
 for y:=0 to B.Height-1 do begin
  n := (8-y) mod 8;
  for x:=n to n+3 do
   B.Canvas.Pixels[x mod 8, y] := Color;
  //for x:=n+4 to n+5 do
  // B.Canvas.Pixels[x mod 8, y] := Color;
 end;
 // Set brush texture
 Result := TBrush.Create;
 Result.Bitmap := B;
end;

procedure TfmMain.FormCreate(Sender: TObject);
var i: integer;
begin
 if not Assigned(fmSplash) then CreateSplash;
 try
  Randomize;
  FMarqueeBrush := CreateMarqueeBrush(clNavy);
  LoadFlexCursors;
  // Loading from file
  fpMain.OnProgress := fmSplash.FlexProgress;
  Screen.Cursor := crHourGlass;
  try
   fpMain.LoadFromFile(ExtractFilePath(ParamStr(0))+'GisDemo.fxd');
  finally
   fpMain.OnProgress := Nil;
   Screen.Cursor := crDefault;
  end;
  // Cache all schemes bitmap
  for i:=0 to fpMain.Schemes.Count-1 do
   (fpMain.Schemes[i] as TFlexScheme).BrushProp.BitmapCache := true;
  // Init
  FCopyright := fpMain.FindControl('Copyright');
  FBoundaries := fpMain.FindControl('Boundaries');
  fpMain.ActiveScheme := fpMain.DefaultScheme;
  fpMain.ActiveLayer := fpMain.Layers.ByName['Active'];
 finally
  DestroySplash;
 end;
end;

procedure TfmMain.FormDestroy(Sender: TObject);
begin
 FMarqueeBrush.Free;
end;

function TfmMain.GetIdahoScheme: TFlexCustomScheme;
begin
 Result := fpMain.Schemes.ByName['Idaho'];
end;

function TfmMain.GeneratePos: TPoint;
var Rgn: HRGN;
begin
 Rgn := CreateControlRegion(FBoundaries);
 repeat
  Result.X := round(Random * fpMain.DocWidth);
  Result.Y := round(Random * fpMain.DocHeight);
  fpMain.TransformPoint(Result.X, Result.Y);
 until (Rgn = 0) or PtInRegion(Rgn, Result.X, Result.Y);
 fpMain.UnTransformPoint(Result.X, Result.Y);
end;

procedure TfmMain.sbtMainSchemeClick(Sender: TObject);
begin
 fpMain.ActiveScheme := fpMain.DefaultScheme;
 BestFit;
end;

procedure TfmMain.sbtVehiclesClick(Sender: TObject);
begin
 fmVehicles.Show;
end;

procedure TfmMain.sbtLayersClick(Sender: TObject);
begin
 fmLayers.Show;
end;

procedure TfmMain.sbtExitClick(Sender: TObject);
begin
 Close;
end;

procedure TfmMain.sbtAboutClick(Sender: TObject);
begin
 ShowAbout;
end;

procedure TfmMain.sbtZoomClick(Sender: TObject);
begin
 if sbtZoom.Down
  then fpMain.ToolMode := ftmZoom
  else fpMain.ToolMode := ftmSelect;
end;

procedure TfmMain.sbtPanClick(Sender: TObject);
begin
 if sbtPan.Down
  then fpMain.ToolMode := ftmPan
  else fpMain.ToolMode := ftmSelect;
end;

procedure TfmMain.fpMainMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
 if Sender = fpMain then begin
  fpMain.SetFocus;
  if not fpMain.Focused then Windows.SetFocus(fpMain.Handle);
 end;
 if FLastControl = FCopyright then
  ShowAbout
 else
 if Assigned(fpMain.MouseControl) and
   StrBeginsFrom(fpMain.MouseControl.Name, 'Vehicle') then
  with fmVehicles do begin
   lbxVehicles.ItemIndex := lbxVehicles.Items.IndexOfObject(fpMain.MouseControl);
   lbxVehiclesClick(Nil);
  end;
end;

procedure TfmMain.fpMainNotify(Sender: TObject; Control: TFlexControl;
  Notify: TFlexNotify);
begin
 if (Notify = fnSchemes) and not fpMain.IsLoading and
     Assigned(fpMain.ActiveScheme) then BestFit;
end;

procedure TfmMain.BestFit;
var AScale: TPoint;
begin
 with fpMain do
 try
  DocWidth := ScalePixels(StrToInt(ActiveScheme.UserData.Values['Width']));
  DocHeight := ScalePixels(StrToInt(ActiveScheme.UserData.Values['Height']));
  // Calculate scale
  AScale.X := ClientWidth * 100 div UnscalePixels(DocWidth);
  AScale.Y := ClientHeight * 100 div UnscalePixels(DocHeight);
  if AScale.X < AScale.Y
   then Scale := AScale.X
   else Scale := AScale.Y;
 except
 end;
end;

procedure TfmMain.fpMainMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
 if (FLastControl <> fpMain.MouseControl) then begin
  with TFlexText(FLastControl) do begin
   if FLastControl = FCopyright then begin
    FontProp.Color := clBlack;
    FontProp.Style := FontProp.Style - [fsUnderline];
   end;
  end;
  if Assigned(fpMain.MouseControl) and (fpMain.MouseControl is TFlexText) and
     (fpMain.ToolMode = ftmSelect) then begin
   with TFlexText(fpMain.MouseControl) do
    if fpMain.MouseControl = FCopyright then begin
     FontProp.Color := clRed;
     FontProp.Style := FontProp.Style + [fsUnderline];
    end;
   FLastControl := fpMain.MouseControl
  end else
   FLastControl := Nil;
 end;
end;

procedure TfmMain.SetActiveControl(const Value: TFlexControl);
begin
 if Value = FActiveControl then exit;
 RefreshMarquee;
 FActiveControl := Value;
 tmMarquee.Enabled := Assigned(FActiveControl);
end;

function TfmMain.CreateControlRegion(Control: TFlexControl): HRGN;
var Points: TPointArray;
    Rect: TRect;
begin
 Result := 0;
 Points := Nil;
 if not Assigned(Control) then exit;
 // Create active control region
 if Control is TFlexEllipse then begin
  Rect := Control.PaintRect;
  inc(Rect.Right);
  inc(Rect.Bottom);
  Result := CreateEllipticRgnIndirect(Rect);
 end else
 if Control.PointCount > 0 then with Control.PaintRect do begin
  Points := Control.GetTransformPoints(Left, Top, fpMain.Scale);
  Result := CreatePolygonRgn(Points[0], Length(Points), ALTERNATE);
 end else
  Result := CreateRectRgnIndirect(Control.PaintRect);
end;

procedure TfmMain.RefreshMarquee;
var Rgn: HRGN;
begin
 if not Assigned(FActiveControl) then exit;
 Rgn := CreateControlRegion(FActiveControl);
 InvalidateRgn(fpMain.Handle, Rgn, False);
 DeleteObject(Rgn);
end;

procedure TfmMain.tmMarqueeTimer(Sender: TObject);
begin
 dec(FMarqueeDisp);
 FMarqueeDisp := FMarqueeDisp and 7;
 RefreshMarquee;
end;

procedure TfmMain.fpMainPaintOver(ACanvas: TCanvas; AControl: TFlexControl;
  ChildrenOnly, SelectedOnly: Boolean);
var Rgn: HRGN;
    P: TPoint;
begin
 if Assigned(FActiveControl) and tmMarquee.Enabled  and
    (FActiveControl.ParentScheme = fpMain.ActiveScheme) then begin
  // Paint marquee
  SetBrushOrgEx(ACanvas.Handle, 7-FMarqueeDisp, 7-FMarqueeDisp, @P);
  Rgn := CreateControlRegion(FActiveControl);
  ACanvas.Brush.Assign(FMarqueeBrush);
  FrameRgn(ACanvas.Handle, Rgn, FMarqueeBrush.Handle,
    1, 1 {Options.SelFrameWidth, Options.SelFrameWidth});
  //PaintRgn(ACanvas.Handle, Rgn);
  DeleteObject(Rgn);
  SetBrushOrgEx(ACanvas.Handle, P.X, P.Y, Nil);
 end;
end;

procedure TfmMain.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
 if (Key = VK_MENU) and (fpMain.ToolMode = ftmSelect) and
    not Assigned(fpMain.CreatingControlClass) then
  fpMain.ToolMode := ftmPan
 else
 if Key = vk_F1 then ShowAbout;
end;

procedure TfmMain.FormKeyUp(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
 if (Key = VK_MENU) and
   ((fpMain.ToolMode = ftmPan) or (fpMain.ToolMode = ftmPanning)) then
  fpMain.ToolMode := ftmSelect;
end;

end.