mainform.pas

FlexGraphics是一套创建矢量图形的VCL组件

unit MainForm;

interface

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

type
  PArrowInfo = ^TArrowInfo;
  TArrowInfo = record
   Arrow: TFlexControl;
   Path: TFlexControl;
   Inited: boolean;
   IsVert: boolean;
   FromTopLeft: boolean;
  end;

  TArrowArray = array of TArrowInfo;

  TfmMain = class(TForm)
    Panel1: TPanel;
    lbHeat: TLabel;
    tbHeat: TTrackBar;
    sbtClose: TSpeedButton;
    tmWater: TTimer;
    tmTemp: TTimer;
    chAuto: TCheckBox;
    cbScale: TComboBox;
    Scale: TLabel;
    sbtAbout: TSpeedButton;
    tmArrows: TTimer;
    chArrows: TCheckBox;
    Flex: TFlexPanel;
    procedure FormCreate(Sender: TObject);
    procedure tbHeatChange(Sender: TObject);
    procedure FlexMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FlexMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FlexMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure tmWaterTimer(Sender: TObject);
    procedure sbtCloseClick(Sender: TObject);
    procedure tmTempTimer(Sender: TObject);
    procedure chAutoClick(Sender: TObject);
    procedure cbScaleChange(Sender: TObject);
    procedure sbtAboutClick(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure tmArrowsTimer(Sender: TObject);
    procedure chArrowsClick(Sender: TObject);
    procedure FormKeyUp(Sender: TObject; var Key: Word;
      Shift: TShiftState);
  private
    { Private declarations }
    FChanging: boolean;
    FCopyright: TFlexText;
    FWater: TFlexControl;
    FWaterTank: TFlexControl;
    FHeatStripe: TFlexControl;
    FHeatFiller: TFlexControl;
    FHeatRing: TFlexEllipse;
    FWaterLevel: TFlexText;
    FHeatLevel: TFlexText;
    FTempValue: TFlexText;
    FHeating: boolean;
    FWaterLevelVal: integer;
    FWaterReqLevelVal: integer;
    FArrowsLayer: TFlexLayer;
    FWaysLayer: TFlexLayer;
    FArrows: TArrowArray;
    procedure SetHeat(FromBar: boolean);
    procedure ScrollFlexHeat(MouseX: integer);
    procedure AutoHeating;
  public
    { Public declarations }
  end;

var
  fmMain: TfmMain;

implementation

{$R *.DFM}

uses
  FlexProps, fAboutPrg;

procedure TfmMain.FormCreate(Sender: TObject);
var i, Idx: integer;
    Control: TFlexControl;
begin
 LoadFlexCursors;
 SetLength(FArrows, 6 {max arrows});
 FillChar(FArrows[0], Length(FArrows)*SizeOf(FArrows[0]), 0);
 Flex.LoadFromFile(ChangeFileExt(ParamStr(0), '.fxd'));
 with Flex.ActiveScheme do begin
  // Find controls
  FCopyright := TFlexText(FindByName('Copyright'));
  FWater := FindByName('Water');
  FWaterTank := FindByName('WaterTank');
  FHeatStripe := FindByName('HeatStripe');
  FHeatFiller := FindByName('HeatFiller');
  FHeatRing := FindByName('HeatRing') as TFlexEllipse;
  FWaterLevel := FindByName('WaterLevel') as TFlexText;
  FHeatLevel := FindByName('HeatLevel') as TFlexText;
  FTempValue := FindByName('TempValue') as TFlexText;
  FTempValue.TextProp.Text := Format('%.1f',[7.0]);
  // Find ways and arrows
  FArrowsLayer := Flex.Layers.ByName['Arrows'];
  FWaysLayer := Flex.Layers.ByName['Ways'];
  for i:=0 to Flex.ActiveScheme.Count-1 do begin
   Control := Flex.ActiveScheme[i];
   if (Control.Layer <> FArrowsLayer) and
      (Control.Layer <> FWaysLayer) then continue;
   Idx := Control.Tag - 1;
   if (Idx < 0) or (Idx > High(FArrows)) then continue;
   if Control.Layer = FArrowsLayer then begin
    FArrows[Idx].Arrow := Control;
   end else
   if Control.Layer = FWaysLayer then begin
    FArrows[Idx].Path := Control;
    FArrows[Idx].IsVert := Control.Height > Control.Width;
   end;
  end;
  if Assigned(FWaysLayer) then FWaysLayer.Visible := False;
 end;
 SetHeat(True);
 tmWaterTimer(tmWater);
 cbScale.ItemIndex := cbScale.Items.IndexOf('100%');
 WindowState := wsMaximized;
end;

procedure TfmMain.SetHeat(FromBar: boolean);
var Value, Pos: integer;
begin
 if FChanging then exit;
 FChanging := True;
 if FromBar then begin
  // Set heat from TrackBar
  Value := tbHeat.Position;
  with FHeatStripe do
   Pos := Left + Round(Width * Value / 100);
  ScrollFlexHeat(FHeatStripe.ClientToOwner(Point(Pos, 0)).X);
 end else
 with FHeatFiller do begin
  // Set heat from Flex control
  if not Visible
   then Value := 100
   else Value := 100-Round(100 * Width / FHeatStripe.Width);
  tbHeat.Position := Value;
 end;
 // Update heat level flex control
 FHeatLevel.TextProp.Text := IntToStr(Value)+'%';
 // Set required water level
 FWaterReqLevelVal := Value;
 // End changing
 FChanging := False;
end;

procedure TfmMain.ScrollFlexHeat(MouseX: integer);
var P: TPoint;
begin
 P := FHeatStripe.OwnerToClient(Point(MouseX, 0));
 if P.X < 0 then P.X := 0;
 with FHeatFiller do
  if P.X >= FHeatStripe.Left + FHeatStripe.Width then
   Visible := False
  else begin
   Visible := True;
   Left := P.X;
   Width := FHeatStripe.Width - P.X;
  end;
end;

procedure TfmMain.AutoHeating;
var Temp: Double;
begin
 Temp := StrToFloat(FTempValue.TextProp.Text);
 tbHeat.Position :=  Round((1 - (Temp) / 10) * 100);
end;

procedure TfmMain.tmTempTimer(Sender: TObject);
var Value: Double;
begin
 Value := StrToFloat(FTempValue.TextProp.Text);
 Value := Value + Random - 0.5;
 FTempValue.TextProp.Text := Format('%.1f',[Value]);
 if chAuto.Checked then AutoHeating;
end;

procedure TfmMain.tmWaterTimer(Sender: TObject);
var Pos: integer;
    i: integer;
    Color: TColor;
begin
 // Change level
 if FWaterReqLevelVal > FWaterLevelVal then inc(FWaterLevelVal) else
 if FWaterReqLevelVal < FWaterLevelVal then dec(FWaterLevelVal);
 // Setup level
 Pos := Round(FWaterTank.Height * (100 - FWaterLevelVal) / 100);
 if Pos >= FWaterTank.Height then
  FWater.Visible := False
 else begin
  FWater.Visible := True;
  FWater.Top := FWaterTank.Top + Pos;
  FWater.Height := FWaterTank.Height - Pos;
  for i:=0 to FWater.Count-1 do
   FWater[i].Height := FWaterTank.Height - Pos;
 end;
 // Update Flex control with water level value
 FWaterLevel.TextProp.Text := IntToStr(FWaterLevelVal)+'%';
 // Update Heat Ring color
 if FWaterLevelVal <= 33 then Color := clNavy else
 if FWaterLevelVal <= 66 then Color := clLime
                      else Color := clRed;
 TBrushProp(FHeatRing.Props['Brush']).Color := Color;
end;

procedure TfmMain.tmArrowsTimer(Sender: TObject);
var i: integer;
begin
 for i:=0 to High(FArrows) do with FArrows[i] do begin
  if not Assigned(Arrow) or not Assigned(Path) then continue;
  if not Inited then begin
   // First call. Initialize arrow position
   if IsVert then begin
    // Vertical
    FromTopLeft :=
      (Arrow.Top + Arrow.Height) < (Path.Top + Path.Height div 2);
    if FromTopLeft
     then Arrow.Top := Path.Top
     else Arrow.Top := Path.Top + Path.Height - Arrow.Height;
    Arrow.Left := Path.Left - Arrow.Width div 2;
   end else begin
    // Horizontal
    FromTopLeft :=
      (Arrow.Left + Arrow.Width) < (Path.Left + Path.Width div 2);
    if FromTopLeft
     then Arrow.Left := Path.Left
     else Arrow.Left := Path.Left + Path.Width - Arrow.Width;
    Arrow.Top := Path.Top - Arrow.Height div 2;
   end;
   Inited := true;
  end else
  // Move arrow along path
  if IsVert then begin
   // Vertical
   if FromTopLeft then begin
    if Arrow.Top + Arrow.Height >= Path.Top + Path.Height
     then Arrow.Top := Path.Top
     else Arrow.Top := Arrow.Top + ScalePixels(1);
   end else begin
    if Arrow.Top <= Path.Top
     then Arrow.Top := Path.Top + Path.Height - Arrow.Height
     else Arrow.Top := Arrow.Top - ScalePixels(1);
   end;
  end else
   // Horizontal
   if FromTopLeft then begin
    if Arrow.Left + Arrow.Width >= Path.Left + Path.Width
     then Arrow.Left := Path.Left
     else Arrow.Left := Arrow.Left + ScalePixels(1);
   end else
    if Arrow.Left <= Path.Left
     then Arrow.Left := Path.Left + Path.Width - Arrow.Width
     else Arrow.Left := Arrow.Left - ScalePixels(1);
 end; { for }
end;

procedure TfmMain.tbHeatChange(Sender: TObject);
begin
 tbHeat.SelEnd := tbHeat.Position;
 SetHeat(True);
end;

procedure TfmMain.FlexMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
 if (Button <> mbLeft) or (Flex.ToolMode <> ftmSelect) then exit;
 if Flex.MouseSubControl = FCopyright then
  ShowAbout;
 if not chAuto.Checked and
    ((Flex.MouseSubControl = FHeatStripe) or
     (Flex.MouseSubControl = FHeatFiller)) then begin
  ScrollFlexHeat(X);
  SetHeat(False);
  FHeating := true;
 end;
end;

procedure TfmMain.FlexMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
 if Assigned(FCopyright) then with FCopyright.FontProp do
  if Flex.MouseSubControl = FCopyright then begin
   Color := clRed;
   Style := Style + [fsUnderline];
  end else begin
   Color := clBlack;
   Style := Style - [fsUnderline];
  end;
 if FHeating then begin
  ScrollFlexHeat(X);
  SetHeat(False);
 end;
end;

procedure TfmMain.FlexMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
 FHeating := False;
end;

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

procedure TfmMain.chAutoClick(Sender: TObject);
begin
 tbHeat.Enabled := not chAuto.Checked;
 lbHeat.Enabled := not chAuto.Checked;
 if chAuto.Checked then begin
  FHeating := False;
  AutoHeating;
 end;
end;

procedure TfmMain.cbScaleChange(Sender: TObject);
var s: string;
begin
 s := cbScale.Items[cbScale.ItemIndex];
 Flex.Zoom( StrToIntDef(copy(s, 1, pos('%', s)-1), 100), Nil);
end;

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

procedure TfmMain.chArrowsClick(Sender: TObject);
begin
 if Assigned(FArrowsLayer) then
  FArrowsLayer.Visible := chArrows.Checked;
 tmArrows.Enabled := chArrows.Checked;
end;

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

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

end.