API tools faq
paste
Advertisement
Guest User

Untitled

a guest
Oct 17th, 2017
76
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Delphi 10.23 KB | None | 0 0
raw download clone embed print report diff
  1. unit uMain;
  2.  
  3. ////////////////////////////////////////////////////////////////////////////////
  4. /// Visual Program Designer in VCL (Delphi)                                  ///
  5. /// ------------------------------------------------------------------------ ///
  6. /// (c) 2016 Dennis Göhlert                                                  ///
  7. ///                                                                          ///
  8. /// LICENSE: Mozilla Public License v2.0                                     ///
  9. ////////////////////////////////////////////////////////////////////////////////
  10.  
  11. interface
  12.  
  13. uses
  14.   Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  15.   Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, uDesignPrograms,
  16.   Vcl.Grids, Vcl.ValEdit, Vcl.Menus;
  17.  
  18. type
  19.   TfmMain = class(TForm)
  20.     pnPrograms: TPanel;
  21.     coPrograms: TComboBox;
  22.     laPrograms: TLabel;
  23.     pbCommands: TPaintBox;
  24.     btAdd: TButton;
  25.     btDelete: TButton;
  26.     pmCommands: TPopupMenu;
  27.     miAdd: TMenuItem;
  28.     miDelete: TMenuItem;
  29.     veCommands: TValueListEditor;
  30.     sbCommands: TScrollBox;
  31.     pnCommands: TPanel;
  32.     btApply: TButton;
  33.     procedure coProgramsDropDown(Sender: TObject);
  34.     procedure btDeleteClick(Sender: TObject);
  35.     procedure btAddClick(Sender: TObject);
  36.     procedure FormCreate(Sender: TObject);
  37.     procedure pbCommandsPaint(Sender: TObject);
  38.     procedure coProgramsChange(Sender: TObject);
  39.     procedure miAddClick(Sender: TObject);
  40.     procedure miDeleteClick(Sender: TObject);
  41.     procedure pmCommandsPopup(Sender: TObject);
  42.     procedure pbCommandsMouseDown(Sender: TObject; Button: TMouseButton;
  43.       Shift: TShiftState; X, Y: Integer);
  44.     procedure sbCommandsMouseDown(Sender: TObject; Button: TMouseButton;
  45.       Shift: TShiftState; X, Y: Integer);
  46.     procedure pbCommandsMouseUp(Sender: TObject; Button: TMouseButton;
  47.       Shift: TShiftState; X, Y: Integer);
  48.     procedure pbCommandsMouseMove(Sender: TObject; Shift: TShiftState; X,
  49.       Y: Integer);
  50.     procedure btApplyClick(Sender: TObject);
  51.   private
  52.     { Private-Deklarationen }
  53.     Dragging: Boolean;
  54.     DragPos: TPoint;
  55.     Selected: PCommand;
  56.     procedure Select(Command: PCommand);
  57.   public
  58.     { Public-Deklarationen }
  59.   end;
  60.  
  61. var
  62.   fmMain: TfmMain;
  63.  
  64. implementation
  65.  
  66. {$R *.dfm}
  67.  
  68. procedure TfmMain.btAddClick(Sender: TObject);
  69. begin
  70.   SetLength(Programs,Length(Programs) + 1);
  71.   Programs[High(Programs)] := TProgram.Create(InputBox('Add program','Name:','My program'));
  72. end;
  73.  
  74. procedure TfmMain.btDeleteClick(Sender: TObject);
  75. var
  76.   Index: Integer;
  77. begin
  78.   Programs[coPrograms.ItemIndex].Free;
  79.   for Index := coPrograms.ItemIndex to High(Programs) - 1 do
  80.   begin
  81.     Programs[Index] := Programs[Index + 1];
  82.   end;
  83.   SetLength(Programs,Length(Programs) - 1);
  84.   coPrograms.ItemIndex := coPrograms.ItemIndex - 1;
  85.   coPrograms.OnChange(coPrograms);
  86. end;
  87.  
  88. procedure TfmMain.btApplyClick(Sender: TObject);
  89. var
  90.   Command: TCommand;
  91. begin
  92.   if Assigned(Selected) then
  93.   begin
  94.     Command.ID := StrToInt(veCommands.Values['ID']);
  95.     Command.Duration := StrToInt(veCommands.Values['Duration']);
  96.     Command.Order := StrToInt(veCommands.Values['Order']);
  97.     Programs[coPrograms.ItemIndex].Items[Programs[coPrograms.ItemIndex].IndexOf(Selected^)] := Command;
  98.     Programs[coPrograms.ItemIndex].Sort;
  99.     Select(@Command);
  100.   end;
  101. end;
  102.  
  103. procedure TfmMain.coProgramsChange(Sender: TObject);
  104. begin
  105.   Select(nil);
  106.   pbCommands.Repaint;
  107.   btDelete.Enabled := coPrograms.ItemIndex <> -1;
  108. end;
  109.  
  110. procedure TfmMain.coProgramsDropDown(Sender: TObject);
  111. var
  112.   Index: Integer;
  113. begin
  114.   coPrograms.Items.Clear;
  115.   for Index := Low(Programs) to High(Programs) do
  116.   begin
  117.     coPrograms.Items.Add(Programs[Index].Name);
  118.   end;
  119. end;
  120.  
  121. procedure TfmMain.FormCreate(Sender: TObject);
  122. begin
  123.   Constraints.MaxHeight := Height;
  124.   Constraints.MinHeight := Height;
  125.   Constraints.MinWidth := Width;
  126.   coPrograms.OnChange(coPrograms);
  127. end;
  128.  
  129. procedure TfmMain.miAddClick(Sender: TObject);
  130. var
  131.   Command: TCommand;
  132. begin
  133.   Command.ID := 0;
  134.   Command.Duration := 1;
  135.   Command.Order := Programs[coPrograms.ItemIndex].Count;
  136.   Programs[coPrograms.ItemIndex].Add(Command);
  137.   pbCommands.Repaint;
  138. end;
  139.  
  140. procedure TfmMain.miDeleteClick(Sender: TObject);
  141. begin
  142.   Programs[coPrograms.ItemIndex].Delete(Programs[coPrograms.ItemIndex].IndexOf(Selected^));
  143.   pbCommands.Repaint;
  144. end;
  145.  
  146. procedure TfmMain.pbCommandsMouseDown(Sender: TObject; Button: TMouseButton;
  147.   Shift: TShiftState; X, Y: Integer);
  148. var
  149.   Index: Integer;
  150.   Command: TCommand;
  151. begin
  152.   if (coPrograms.ItemIndex <> -1) and (Button = mbLeft) then
  153.   begin
  154.     Select(nil);
  155.     if (Y > pbCommands.Height div 2 - 24) and (Y < pbCommands.Height div 2 + 24) then
  156.     begin
  157.       for Index := 0 to Programs[coPrograms.ItemIndex].Count - 1 do
  158.       begin
  159.         if (X > 48 + Index * 66) and (X < 48 + (Index + 1) * 50 + Index * 16) then
  160.         begin
  161.           Command := Programs[coPrograms.ItemIndex].Items[Index];
  162.           Select(@Command);
  163.           Dragging := True;
  164.           DragPos := Point(X,Y);
  165.         end;
  166.       end;
  167.     end;
  168.   end;
  169. end;
  170.  
  171. procedure TfmMain.pbCommandsMouseMove(Sender: TObject; Shift: TShiftState; X,
  172.   Y: Integer);
  173. var
  174.   Index: Integer;
  175.   Command: TCommand;
  176. begin
  177.   if Dragging then
  178.   begin
  179.     Index := Programs[coPrograms.ItemIndex].IndexOf(Selected^);
  180.     if (Index > 0) and (X < DragPos.X - 16) then
  181.     begin
  182.       Programs[coPrograms.ItemIndex].Exchange(Index,Index - 1);
  183.       Command := Programs[coPrograms.ItemIndex].Items[Index - 1];
  184.       Select(@Command);
  185.       DragPos := Point(X,Y);
  186.     end else
  187.     begin
  188.       if (Index < Programs[coPrograms.ItemIndex].Count - 1) and (X > DragPos.X + 16) then
  189.       begin
  190.         Programs[coPrograms.ItemIndex].Exchange(Index,Index + 1);
  191.         Command := Programs[coPrograms.ItemIndex].Items[Index + 1];
  192.         Select(@Command);
  193.         DragPos := Point(X,Y);
  194.       end;
  195.     end;
  196.     pbCommands.Repaint;
  197.   end;
  198. end;
  199.  
  200. procedure TfmMain.pbCommandsMouseUp(Sender: TObject; Button: TMouseButton;
  201.   Shift: TShiftState; X, Y: Integer);
  202. begin
  203.   if Dragging and (Button = mbLeft) then
  204.   begin
  205.     Dragging := False;
  206.     pbCommands.Repaint;
  207.   end;
  208. end;
  209.  
  210. procedure TfmMain.pbCommandsPaint(Sender: TObject);
  211. var
  212.   Index: Integer;
  213. begin
  214.   if coPrograms.ItemIndex <> -1 then
  215.   begin
  216.     pbCommands.Width := Programs[coPrograms.ItemIndex].Count * 66 + 80;
  217.     pbCommands.Canvas.Pen.Color := clBlack;
  218.     pbCommands.Canvas.Pen.Width := 4;
  219.     pbCommands.Canvas.MoveTo(24,pbCommands.Height div 2);
  220.     pbCommands.Canvas.LineTo(pbCommands.Width - 24,pbCommands.Height div 2);
  221.     pbCommands.Canvas.Ellipse(16,pbCommands.Height div 2 - 8,32,pbCommands.Height div 2 + 8);
  222.     pbCommands.Canvas.Ellipse(pbCommands.Width - 16,pbCommands.Height div 2 - 8,pbCommands.Width - 32,pbCommands.Height div 2 + 8);
  223.     pbCommands.Canvas.Font.Color := clBlue;
  224.     pbCommands.Canvas.Font.Style := [fsBold];
  225.     pbCommands.Canvas.Font.Size := 8;
  226.     pbCommands.Canvas.TextOut(24 - pbCommands.Canvas.TextWidth('Begin') div 2,pbCommands.Height div 2 + 12,'Begin');
  227.     pbCommands.Canvas.TextOut(pbCommands.Width - 24 - pbCommands.Canvas.TextWidth('End') div 2,pbCommands.Height div 2 + 12,'End');
  228.     Programs[coPrograms.ItemIndex].Sort;
  229.     pbCommands.Canvas.Font.Color := clBlack;
  230.     pbCommands.Canvas.Font.Size := 10;
  231.     pbCommands.Canvas.Pen.Width := 2;
  232.     for Index := 0 to Programs[coPrograms.ItemIndex].Count - 1 do
  233.     begin
  234.       if Assigned(Selected) and (Index = Selected^.Order) then
  235.       begin
  236.         pbCommands.Canvas.Brush.Color := clYellow;
  237.         pbCommands.Canvas.Pen.Color := clGreen;
  238.       end else
  239.       begin
  240.         pbCommands.Canvas.Brush.Color := clRed;
  241.         pbCommands.Canvas.Pen.Color := clBlack;
  242.       end;
  243.       if Assigned(Selected) and Dragging and (Index = Selected^.Order) then
  244.       begin
  245.         pbCommands.Canvas.RoundRect(48 + Index * 66 + pbCommands.ScreenToClient(Mouse.CursorPos).X - DragPos.X,pbCommands.Height div 2 - 24 + pbCommands.ScreenToClient(Mouse.CursorPos).Y - DragPos.Y,48 + (Index + 1) * 50 + Index * 16 + pbCommands.ScreenToClient(Mouse.CursorPos).X - DragPos.X,pbCommands.Height div 2 + 24 + pbCommands.ScreenToClient(Mouse.CursorPos).Y - DragPos.Y,8,8);
  246.         pbCommands.Canvas.TextOut(73 + Index * 66 + pbCommands.ScreenToClient(Mouse.CursorPos).X - DragPos.X - pbCommands.Canvas.TextWidth(IntToStr(Programs[coPrograms.ItemIndex].Items[Index].ID)) div 2,pbCommands.Height div 2 + pbCommands.ScreenToClient(Mouse.CursorPos).Y - DragPos.Y - pbCommands.Canvas.TextHeight(IntToStr(Programs[coPrograms.ItemIndex].Items[Index].ID)) div 2,IntToStr(Programs[coPrograms.ItemIndex].Items[Index].ID));
  247.       end else
  248.       begin
  249.         pbCommands.Canvas.RoundRect(48 + Index * 66,pbCommands.Height div 2 - 24,48 + (Index + 1) * 50 + Index * 16,pbCommands.Height div 2 + 24,8,8);
  250.         pbCommands.Canvas.TextOut(73 + Index * 66 - pbCommands.Canvas.TextWidth(IntToStr(Programs[coPrograms.ItemIndex].Items[Index].ID)) div 2,pbCommands.Height div 2 - pbCommands.Canvas.TextHeight(IntToStr(Programs[coPrograms.ItemIndex].Items[Index].ID)) div 2,IntToStr(Programs[coPrograms.ItemIndex].Items[Index].ID));
  251.       end;
  252.     end;
  253.   end;
  254. end;
  255.  
  256. procedure TfmMain.pmCommandsPopup(Sender: TObject);
  257. begin
  258.   miAdd.Enabled := coPrograms.ItemIndex <> -1;
  259. end;
  260.  
  261. procedure TfmMain.sbCommandsMouseDown(Sender: TObject; Button: TMouseButton;
  262.   Shift: TShiftState; X, Y: Integer);
  263. begin
  264.   if Button = mbLeft then
  265.   begin
  266.     Select(nil);
  267.   end;
  268. end;
  269.  
  270. procedure TfmMain.Select(Command: PCommand);
  271. begin
  272.   Dispose(Selected);
  273.   veCommands.Strings.Clear;
  274.   if Assigned(Command) then
  275.   begin
  276.     New(Selected);
  277.     Selected^ := Command^;
  278.     veCommands.Strings.Add('ID=' + IntToStr(Command^.ID));
  279.     veCommands.Strings.Add('Duration=' + IntToStr(Command^.Duration));
  280.     veCommands.Strings.Add('Order=' + IntToStr(Command^.Order));
  281.     veCommands.Enabled := True;
  282.     veCommands.ItemProps['Order'].ReadOnly := True;
  283.     miDelete.Enabled := True;
  284.     btApply.Enabled := True;
  285.   end else
  286.   begin
  287.     Selected := nil;
  288.     veCommands.Enabled := False;
  289.     miDelete.Enabled := False;
  290.     btApply.Enabled := False;
  291.   end;
  292.   pbCommands.Repaint;
  293. end;
  294.  
  295. end.
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!