home *** CD-ROM | disk | FTP | other *** search
/ PC Expert 29 / Pce29cd.iso / RUNIMAGE / DELPHI40 / DEMOS / EXPERTS / DLG.PAS < prev    next >
Pascal/Delphi Source File  |  1998-06-16  |  11KB  |  419 lines
  1.  
  2. unit Dlg;
  3.  
  4. interface
  5.  
  6. uses
  7.   SysUtils, Windows, Messages, Classes, Graphics, Controls,
  8.   Forms, Dialogs, ExtCtrls, StdCtrls, Buttons, ToolIntf, ComCtrls;
  9.  
  10. type
  11.  
  12.   { These are the set of flags which determine the type of dialog to create }
  13.   TDlgAttr = (daNothing, daMultPg, daBtnsH, daBtnsV);
  14.   TDlgAttrs = set of TDlgAttr;
  15.  
  16.   TDlgExpert = class(TForm)
  17.     Sample: TPaintBox;
  18.     CancelBtn: TButton;
  19.     PrevButton: TButton;
  20.     NextButton: TButton;
  21.     PageControl: TPageControl;
  22.     Style: TTabSheet;
  23.     Label1: TLabel;
  24.     rbSinglePage: TRadioButton;
  25.     rbMultPg: TRadioButton;
  26.     Pages: TTabSheet;
  27.     Label3: TLabel;
  28.     PageNames: TMemo;
  29.     Buttons: TTabSheet;
  30.     Label2: TLabel;
  31.     RadioButton1: TRadioButton;
  32.     rbBtnsV: TRadioButton;
  33.     rbBtnsH: TRadioButton;
  34.     procedure SamplePaint(Sender: TObject);
  35.     procedure FormCreate(Sender: TObject);
  36.     procedure FormDestroy(Sender: TObject);
  37.     procedure StyleClick(Sender: TObject);
  38.     procedure BtnClick(Sender: TObject);
  39.     procedure CancelClick(Sender: TObject);
  40.     procedure PrevClick(Sender: TObject);
  41.     procedure NextClick(Sender: TObject);
  42.   private
  43.     { Private declarations }
  44.     Definition: TDlgAttrs;
  45.     DrawBitmap: TBitmap;
  46.     SourceBuffer: PChar;
  47.     procedure RefreshButtons;
  48.     procedure FmtWrite(Stream: TStream; Fmt: PChar; const Args: array of const);
  49.     function DoFormCreation(const FormIdent: string): TForm;
  50.     function CreateSource(const UnitIdent, FormIdent: string): TMemoryStream;
  51.     function CreateForm(const FormIdent: string): TMemoryStream;
  52.   public
  53.     { Public declarations }
  54.   end;
  55.  
  56. procedure DialogExpert(ToolServices: TIToolServices);
  57. var
  58.   DlgExpert: TDlgExpert;
  59.  
  60. implementation
  61.  
  62. uses Proxies, VirtIntf, IStreams, ExConst;
  63.  
  64. {$R *.DFM}
  65.  
  66. const
  67.   { page numbers }
  68.   pgStyle       = 0;  { multi vs. single page dialog }
  69.   pgPages       = 1;  { page names }
  70.   pgButtons     = 2;  { button layouts }
  71.  
  72.   SourceBufferSize = 1024;
  73.  
  74.  
  75. { TDlgExpert }
  76.  
  77. { Paint the sample pane based on the currently selected options }
  78. procedure TDlgExpert.SamplePaint(Sender: TObject);
  79. var
  80.   X, Y: Integer;
  81. begin
  82.   { always paint the background dialog }
  83.   DrawBitmap.Handle := CreateGrayMappedRes(HInstance, 'DIALOG');
  84.   Sample.Canvas.Draw(0, 0, DrawBitmap);
  85.  
  86.   if daMultPg in Definition then
  87.   begin
  88.     DrawBitmap.Handle := CreateGrayMappedRes(HInstance, 'MULTPG');
  89.     Sample.Canvas.Draw(4, 16, DrawBitmap);
  90.   end;
  91.  
  92.   if daBtnsV in Definition then
  93.   begin
  94.     DrawBitmap.Handle := CreateGrayMappedRes(HInstance, 'BTNSV');
  95.     X := 75;
  96.     Y := 22;
  97.  
  98.     if daMultPg in Definition then
  99.     begin
  100.       Dec(X, 2);
  101.       Inc(Y, 4);
  102.     end;
  103.  
  104.     Sample.Canvas.Draw(X, Y, DrawBitmap);
  105.   end;
  106.  
  107.   if daBtnsH in Definition then
  108.   begin
  109.     DrawBitmap.Handle := CreateGrayMappedRes(HInstance, 'BTNSH');
  110.     X := 50;
  111.     Y := 55;
  112.  
  113.     if daMultPg in Definition then Dec(Y, 4);
  114.  
  115.     Sample.Canvas.Draw(X, Y, DrawBitmap);
  116.   end;
  117. end;
  118.  
  119. procedure TDlgExpert.FormCreate(Sender: TObject);
  120. begin
  121.   DrawBitmap := TBitmap.Create;
  122.   PrevClick(Self);
  123.   RefreshButtons;
  124. end;
  125.  
  126. procedure TDlgExpert.FormDestroy(Sender: TObject);
  127. begin
  128.   DrawBitmap.Free;
  129. end;
  130.  
  131. procedure TDlgExpert.StyleClick(Sender: TObject);
  132. begin
  133.   if rbMultPg.Checked then Include(Definition, daMultPg)
  134.   else Exclude(Definition, daMultPg);
  135.   SamplePaint(Self);
  136. end;
  137.  
  138. procedure TDlgExpert.BtnClick(Sender: TObject);
  139. begin
  140.   if rbBtnsV.Checked then Include(Definition, daBtnsV)
  141.   else Exclude(Definition, daBtnsV);
  142.   if rbBtnsH.Checked then Include(Definition, daBtnsH)
  143.   else Exclude(Definition, daBtnsH);
  144.   SamplePaint(Self);
  145. end;
  146.  
  147. procedure TDlgExpert.CancelClick(Sender: TObject);
  148. begin
  149.   Close;
  150. end;
  151.  
  152. procedure TDlgExpert.PrevClick(Sender: TObject);
  153. begin
  154.   case PageControl.ActivePage.PageIndex of
  155.     pgStyle: Exit;
  156.     pgPages: PageControl.ActivePage := PageControl.Pages[pgStyle];
  157.     pgButtons: if (daMultPg in Definition) then
  158.       PageControl.ActivePage := PageControl.Pages[pgPages]
  159.       else PageControl.ActivePage := PageControl.Pages[pgStyle];
  160.   end;
  161.   RefreshButtons;
  162. end;
  163.  
  164. procedure TDlgExpert.NextClick(Sender: TObject);
  165. begin
  166.   case PageControl.ActivePage.PageIndex of
  167.     pgStyle: if (daMultPg in Definition) then
  168.       PageControl.ActivePage := PageControl.Pages[pgPages]
  169.       else PageControl.ActivePage := PageControl.Pages[pgButtons];
  170.     pgPages: PageControl.ActivePage := PageControl.Pages[pgButtons];
  171.     pgButtons:
  172.       begin
  173.         ModalResult := mrOK;
  174.         Exit;
  175.       end;
  176.   end;
  177.   RefreshButtons;
  178. end;
  179.  
  180. procedure TDlgExpert.RefreshButtons;
  181. begin
  182.   PrevButton.Enabled := PageControl.ActivePage.PageIndex > 0;
  183.   if PageControl.ActivePage.PageIndex = pgButtons then
  184.     NextButton.Caption := LoadStr(sFinish)
  185.   else
  186.     NextButton.Caption := LoadStr(sNext);
  187. end;
  188.  
  189. { Create the dialog defined by the user }
  190. function TDlgExpert.DoFormCreation(const FormIdent: string): TForm;
  191. var
  192.   BtnPos: TPoint;
  193.   PgCtrl: TPageControl;
  194.   I: Integer;
  195. begin
  196.   Result := TForm.Create(nil);
  197.   Proxies.CreateSubClass(Result, 'T' + FormIdent, TForm);
  198.   with Result do
  199.   begin
  200.     BorderStyle := bsDialog;
  201.     Width := 400;
  202.     Height := 250;
  203.     Position := poScreenCenter;
  204.     Name := FormIdent;
  205.     Caption := FormIdent;
  206.  
  207.     { create controls }
  208.     if daMultPg in Definition then
  209.     begin
  210.       PgCtrl := TPageControl.Create(Result);
  211.       with PgCtrl do
  212.       begin
  213.         Parent := Result;
  214.         Name := 'PageControl1';
  215.         Align := alClient;
  216.       end;
  217.  
  218.       if PageNames.Lines.Count > 0 then
  219.         for I := 0 to PageNames.Lines.Count - 1 do
  220.           with TTabSheet.Create(Result) do
  221.           begin
  222.             PageControl := PgCtrl;
  223.             Caption := PageNames.Lines[I];
  224.             Name := Format('TabSheet%d', [I + 1]);
  225.           end;
  226.     end;
  227.  
  228.     if (daBtnsH in Definition) or (daBtnsV in Definition) then
  229.     begin
  230.  
  231.       { get the starting point for the buttons }
  232.       if daBtnsH in Definition then
  233.         BtnPos := Point(ClientWidth - (77 * 3) - (5 * 3),
  234.           ClientHeight - 27 - 5)
  235.       else
  236.         BtnPos := Point(ClientWidth - 77 - 5, 30);
  237.  
  238.       { finalize positions }
  239.       if daMultPg in Definition then
  240.       begin
  241.         Dec(BtnPos.X, 5);
  242.         if daBtnsV in Definition then Inc(BtnPos.Y, 5)
  243.         else Dec(BtnPos.Y, 5);
  244.       end;
  245.  
  246.       { OK }
  247.       with TButton.Create(Result) do
  248.       begin
  249.         Parent := Result;
  250.         Left := BtnPos.X;
  251.         Top := BtnPos.Y;
  252.         Height := 25;
  253.         Width := 75;
  254.         Caption := LoadStr(sOKButton);
  255.         Name := 'Button1';
  256.         Default := True;
  257.         ModalResult := mrOk;
  258.       end;
  259.  
  260.       { move the next button position }
  261.       if daBtnsH in Definition then Inc(BtnPos.X, 75 + 5)
  262.       else Inc(BtnPos.Y, 25 + 5);
  263.  
  264.       { Cancel }
  265.       with TButton.Create(Result) do
  266.       begin
  267.         Parent := Result;
  268.         Left := BtnPos.X;
  269.         Top := BtnPos.Y;
  270.         Height := 25;
  271.         Width := 75;
  272.         Name := 'Button2';
  273.         Caption := LoadStr(sCancelButton);
  274.         Cancel := True;
  275.         ModalResult := mrCancel;
  276.       end;
  277.  
  278.       { move the next button position }
  279.       if daBtnsH in Definition then Inc(BtnPos.X, 75 + 5)
  280.       else Inc(BtnPos.Y, 25 + 5);
  281.  
  282.       { Help }
  283.       with TButton.Create(Result) do
  284.       begin
  285.         Parent := Result;
  286.         Left := BtnPos.X;
  287.         Top := BtnPos.Y;
  288.         Height := 25;
  289.         Width := 75;
  290.         Name := 'Button3';
  291.         Caption := LoadStr(sHelpButton);
  292.       end;
  293.     end;
  294.   end;
  295. end;
  296.  
  297. procedure TDlgExpert.FmtWrite(Stream: TStream; Fmt: PChar;
  298.   const Args: array of const);
  299. begin
  300.   if (Stream <> nil) and (SourceBuffer <> nil) then
  301.   begin
  302.     StrLFmt(SourceBuffer, SourceBufferSize, Fmt, Args);
  303.     Stream.Write(SourceBuffer[0], StrLen(SourceBuffer));
  304.   end;
  305. end;
  306.  
  307. function TDlgExpert.CreateSource(const UnitIdent, FormIdent: string): TMemoryStream;
  308. const
  309.   CRLF = #13#10;
  310. var
  311.   I: Integer;
  312. begin
  313.   SourceBuffer := StrAlloc(SourceBufferSize);
  314.   try
  315.     Result := TMemoryStream.Create;
  316.     try
  317.  
  318.       { unit header and uses clause }
  319.       FmtWrite(Result,
  320.         'unit %s;' + CRLF + CRLF +
  321.         'interface' + CRLF + CRLF +
  322.         'uses'#13#10 +
  323.         '  SysUtils, Windows, Messages, Classes, Graphics, Controls,'#13#10 +
  324.         '  StdCtrls, ExtCtrls, Forms', [UnitIdent]);
  325.  
  326.       { additional units that may be needed }
  327.       if daMultPg in Definition then FmtWrite(Result, ', ComCtrls', [nil]);
  328.  
  329.       FmtWrite(Result, ';' + CRLF + CRLF, [nil]);
  330.  
  331.       { begin the class declaration }
  332.       FmtWrite(Result,
  333.         'type'#13#10 +
  334.         '  T%s = class(TForm)'#13#10, [FormIdent]);
  335.  
  336.       { add variable declarations }
  337.       if (daBtnsH in Definition) or (daBtnsV in Definition) then
  338.       begin
  339.         FmtWrite(Result,
  340.           '    Button1: TButton;' + CRLF +
  341.           '    Button2: TButton;' + CRLF +
  342.           '    Button3: TButton;' + CRLF, [nil]);
  343.        end;
  344.  
  345.       if daMultPg in Definition then
  346.       begin
  347.         FmtWrite(Result, '    PageControl1: TPageControl;' + CRLF, [nil]);
  348.         if PageNames.Lines.Count > 0 then
  349.           for I := 0 to PageNames.Lines.Count - 1 do
  350.             FmtWrite(Result, '    TabSheet%d: TTabSheet;'#13#10, [I + 1]);
  351.       end;
  352.  
  353.       FmtWrite(Result,
  354.         '  end;' + CRLF + CRLF +
  355.         'var' + CRLF +
  356.         '  %s: T%s;' + CRLF + CRLF +
  357.         'implementation' + CRLF + CRLF +
  358.         '{$R *.DFM}' + CRLF + CRLF, [FormIdent, FormIdent]);
  359.  
  360.       FmtWrite(Result, 'end.' + CRLF, [nil]);
  361.       Result.Position := 0;
  362.  
  363.     except
  364.       Result.Free;
  365.       raise;
  366.     end;
  367.  
  368.   finally
  369.     StrDispose(SourceBuffer);
  370.   end;
  371. end;
  372.  
  373. function TDlgExpert.CreateForm(const FormIdent: string): TMemoryStream;
  374. var
  375.   DlgForm: TForm;
  376. begin
  377.   DlgForm := DoFormCreation(FormIdent);
  378.   try
  379.     Result := TMemoryStream.Create;
  380.     Result.WriteComponentRes(FormIdent, DlgForm);
  381.     Result.Position := 0;
  382.   finally
  383.     DlgForm.Free;
  384.   end;
  385. end;
  386.  
  387. procedure DialogExpert(ToolServices: TIToolServices);
  388. var
  389.   D: TDlgExpert;
  390.   SourceStream, FormStream: TIMemoryStream;
  391.   UnitIdent, FormIdent: string;
  392.   FileName: string;
  393. begin
  394.   if ToolServices = nil then Exit;
  395.   if ToolServices.GetNewModuleName(UnitIdent, FileName) then
  396.   begin
  397.     D := TDlgExpert.Create(Application);
  398.     try
  399.       if D.ShowModal = mrOK then
  400.       begin
  401.         UnitIdent := AnsiLowerCase(UnitIdent);
  402.         UnitIdent[1] := Upcase(UnitIdent[1]);
  403.         FormIdent := 'Form' + Copy(UnitIdent, 5, 255);
  404.         FormStream := TIMemoryStream.Create(D.CreateForm(FormIdent));
  405.         SourceStream := TIMemoryStream.Create(D.CreateSource(UnitIdent,
  406.           FormIdent));
  407.         ToolServices.CreateModule(FileName, SourceStream, FormStream,
  408.           [cmAddToProject, cmShowSource, cmShowForm, cmUnNamed,
  409.           cmMarkModified]);
  410.       end;
  411.     finally
  412.       D.Free;
  413.     end;
  414.   end;
  415. end;
  416.  
  417. end.
  418.  
  419.