Marco Web Center |
Home: Code Repository: Mastering Delphi 5Project COMMDLG
Project StructureCOMMDLG.DPRprogram Commdlg; uses Forms, Cdlgtest in 'CDLGTEST.PAS' {CommDlgForm}; {$R *.RES} begin Application.CreateForm(TCommDlgForm, CommDlgForm); Application.Run; end. CDLGTEST.PASunit Cdlgtest; interface uses Windows, Classes, Graphics, Forms, Controls, Menus, StdCtrls, Dialogs; type TCommDlgForm = class(TForm) OpenDialog1: TOpenDialog; SaveDialog1: TSaveDialog; FontDialog1: TFontDialog; ColorDialog1: TColorDialog; MainMenu1: TMainMenu; Memo1: TMemo; Open1: TMenuItem; TextFiles1: TMenuItem; Anynewfile1: TMenuItem; MultipleSelection1: TMenuItem; Save1: TMenuItem; TextFile1: TMenuItem; AnyFile1: TMenuItem; Font1: TMenuItem; OnlyTrueType1: TMenuItem; NoEffects1: TMenuItem; NoStyle1: TMenuItem; Apply1: TMenuItem; Color1: TMenuItem; Standard1: TMenuItem; FullOpen1: TMenuItem; NoFullOpen1: TMenuItem; Help1: TMenuItem; AboutCommonDialogsTest1: TMenuItem; PrinterSetupDialog1: TPrinterSetupDialog; FindDialog1: TFindDialog; ReplaceDialog1: TReplaceDialog; Print1: TMenuItem; Print2: TMenuItem; PrinterSetup1: TMenuItem; Search1: TMenuItem; Search2: TMenuItem; Replace1: TMenuItem; PrintDialog1: TPrintDialog; procedure TextFiles1Click(Sender: TObject); procedure Anynewfile1Click(Sender: TObject); procedure MultipleSelection1Click(Sender: TObject); procedure TextFile1Click(Sender: TObject); procedure AnyFile1Click(Sender: TObject); procedure OnlyTrueType1Click(Sender: TObject); procedure NoEffects1Click(Sender: TObject); procedure NoStyle1Click(Sender: TObject); procedure Apply1Click(Sender: TObject); procedure Standard1Click(Sender: TObject); procedure FullOpen1Click(Sender: TObject); procedure NoFullOpen1Click(Sender: TObject); procedure AboutCommonDialogsTest1Click(Sender: TObject); procedure Print2Click(Sender: TObject); procedure PrinterSetup1Click(Sender: TObject); procedure Search2Click(Sender: TObject); procedure Replace1Click(Sender: TObject); procedure FindDialog1Find(Sender: TObject); procedure ReplaceDialog1Replace(Sender: TObject); procedure ReplaceDialog1Find(Sender: TObject); procedure FontDialogApply(Sender: TObject; Wnd: HWND); private { Private declarations } public { Public declarations } end; var CommDlgForm: TCommDlgForm; implementation {$R *.DFM} procedure TCommDlgForm.TextFiles1Click(Sender: TObject); begin with OpenDialog1 do begin Filter := 'Text File (*.txt)|*.txt'; DefaultExt := 'txt'; Filename := ''; Options := [ofHideReadOnly, ofFileMustExist, ofPathMustExist]; if Execute then if ofExtensionDifferent in Options then MessageDlg ('Not a file with the .TXT extension', mtError, [mbOK], 0) else Memo1.Lines.LoadFromFile (FileName); end; end; procedure TCommDlgForm.Anynewfile1Click(Sender: TObject); begin with OpenDialog1 do begin Filter := 'Any File (*.*)|*.*'; FileName := ''; Options := []; if Execute then Memo1.Lines.LoadFromFile (FileName); end; end; procedure TCommDlgForm.MultipleSelection1Click(Sender: TObject); var i: Integer; begin with OpenDialog1 do begin Filter := 'Text File (*.txt)|*.txt|Any File (*.*)|*.*'; Filename := ''; Options := [ofAllowMultiSelect, ofPathMustExist, ofCreatePrompt]; if Execute then for i := 0 to Files.Count - 1 do if MessageDlg ('Open file ' + Files.Strings [i] + '?', mtConfirmation, [mbYes, mbNo], 0) = IDYES then Memo1.Lines.LoadFromFile (Files.Strings [i]); end; end; procedure TCommDlgForm.TextFile1Click(Sender: TObject); begin with SaveDialog1 do begin Filter := 'Text File (*.txt)|*.txt'; DefaultExt := 'txt'; Filename := ''; Options := [ofHideReadOnly, ofPathMustExist]; if Execute then if ofExtensionDifferent in Options then MessageDlg ('Not a txt extension', mtError, [mbOK], 0) else Memo1.Lines.SaveToFile (FileName); end; end; procedure TCommDlgForm.AnyFile1Click(Sender: TObject); begin with SaveDialog1 do begin Filter := 'Any File (*.*)|*.*'; Filename := ''; Options := [ofPathMustExist]; if Execute then Memo1.Lines.SaveToFile (FileName); end; end; procedure TCommDlgForm.OnlyTrueType1Click(Sender: TObject); begin with FontDialog1 do begin Options := [fdEffects, fdTrueTypeOnly, fdForceFontExist]; if Execute then Memo1.Font := Font; end; end; procedure TCommDlgForm.NoEffects1Click(Sender: TObject); begin with FontDialog1 do begin Options := [fdForceFontExist]; if Execute then Memo1.Font := Font; end; end; procedure TCommDlgForm.NoStyle1Click(Sender: TObject); begin with FontDialog1 do begin Options := [fdEffects, fdNoOEMFonts, fdNoStyleSel, fdNoSizeSel, fdForceFontExist]; if Execute then Memo1.Font := Font; end; end; procedure TCommDlgForm.Apply1Click(Sender: TObject); begin with FontDialog1 do begin OnApply := FontDialogApply; Options := [fdEffects, fdForceFontExist]; Execute; OnApply := nil; end; end; procedure TCommDlgForm.Standard1Click(Sender: TObject); begin with ColorDialog1 do begin Options := []; if Execute then Memo1.Color := Color; end; end; procedure TCommDlgForm.FullOpen1Click(Sender: TObject); begin with ColorDialog1 do begin Options := [cdFullOpen]; if Execute then Memo1.Color := Color; end; end; procedure TCommDlgForm.NoFullOpen1Click(Sender: TObject); begin with ColorDialog1 do begin Options := [cdPreventFullOpen]; if Execute then Memo1.Color := Color; end; end; procedure TCommDlgForm.AboutCommonDialogsTest1Click(Sender: TObject); begin MessageDlg ('The ''Common Dialogs Test'' application has been written' + Chr(13) + 'for the book "Mastering Delphi" by Marco Cantù', mtInformation, [mbOk], 0); end; procedure TCommDlgForm.Print2Click(Sender: TObject); begin PrintDialog1.Execute; end; procedure TCommDlgForm.PrinterSetup1Click(Sender: TObject); begin PrinterSetupDialog1.Execute; end; procedure TCommDlgForm.Search2Click(Sender: TObject); begin FindDialog1.Execute; end; procedure TCommDlgForm.Replace1Click(Sender: TObject); begin ReplaceDialog1.Execute; end; procedure TCommDlgForm.FindDialog1Find(Sender: TObject); var FoundPos, InitPos: Integer; begin {search in the text after the current selection} InitPos := Memo1.SelStart + Memo1.SelLength; FoundPos := Pos (FindDialog1.FindText, Copy (Memo1.Text, InitPos + 1, Length (Memo1.Text) - InitPos)); if FoundPos > 0 then begin {activate the component, and select the text} Memo1.SetFocus; Memo1.SelStart := InitPos + FoundPos - 1; Memo1.SelLength := Length(FindDialog1.FindText); end else begin MessageDlg ('Text not found', mtInformation, [mbOK], 0); end; end; procedure TCommDlgForm.ReplaceDialog1Replace(Sender: TObject); var FoundPos, InitPos: Integer; begin {search in the text after the current selection} InitPos := Memo1.SelStart + Memo1.SelLength; FoundPos := Pos (ReplaceDialog1.FindText, Copy (Memo1.Text, InitPos + 1, Length (Memo1.Text) - InitPos)); if FoundPos > 0 then begin {activate the component, and select the text} Memo1.SetFocus; Memo1.SelStart := InitPos + FoundPos - 1; Memo1.SelLength := Length (ReplaceDialog1.FindText); Memo1.SelText := ReplaceDialog1.ReplaceText; end else begin MessageDlg ('Text not found', mtInformation, [mbOK], 0); end; end; procedure TCommDlgForm.ReplaceDialog1Find(Sender: TObject); begin FindDialog1.FindText := ReplaceDialog1.FindText; FindDialog1Find (ReplaceDialog1); end; procedure TCommDlgForm.FontDialogApply(Sender: TObject; Wnd: HWND); begin Memo1.Font := FontDialog1.Font; end; end. CDLGTEST.DFMobject CommDlgForm: TCommDlgForm Left = 119 Top = 153 Width = 532 Height = 355 Caption = 'Common Dialogs Test' Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clBlack Font.Height = -11 Font.Name = 'MS Sans Serif' Font.Style = [] Menu = MainMenu1 OldCreateOrder = True PixelsPerInch = 96 TextHeight = 13 object Memo1: TMemo Left = 0 Top = 0 Width = 524 Height = 309 Align = alClient Font.Charset = DEFAULT_CHARSET Font.Color = clBlack Font.Height = -13 Font.Name = 'Times New Roman' Font.Style = [] ParentFont = False ScrollBars = ssBoth TabOrder = 0 end object OpenDialog1: TOpenDialog Left = 96 Top = 16 end object SaveDialog1: TSaveDialog Left = 96 Top = 64 end object FontDialog1: TFontDialog Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -13 Font.Name = 'System' Font.Style = [] MinFontSize = 0 MaxFontSize = 0 Left = 168 Top = 16 end object ColorDialog1: TColorDialog Ctl3D = True Left = 312 Top = 16 end object MainMenu1: TMainMenu Left = 32 Top = 16 object Open1: TMenuItem Caption = '&Open' object TextFiles1: TMenuItem Caption = 'Existing &Text Files...' OnClick = TextFiles1Click end object Anynewfile1: TMenuItem Caption = '&Any file...' OnClick = Anynewfile1Click end object MultipleSelection1: TMenuItem Caption = '&Multiple Selection...' OnClick = MultipleSelection1Click end end object Save1: TMenuItem Caption = '&Save' object TextFile1: TMenuItem Caption = '&Text File...' OnClick = TextFile1Click end object AnyFile1: TMenuItem Caption = '&Any File...' OnClick = AnyFile1Click end end object Font1: TMenuItem Caption = '&Font' object OnlyTrueType1: TMenuItem Caption = 'Only &TrueType...' OnClick = OnlyTrueType1Click end object NoEffects1: TMenuItem Caption = 'No &Effects...' OnClick = NoEffects1Click end object NoStyle1: TMenuItem Caption = 'No &Style...' OnClick = NoStyle1Click end object Apply1: TMenuItem Caption = '&Apply...' OnClick = Apply1Click end end object Color1: TMenuItem Caption = '&Color' object Standard1: TMenuItem Caption = '&Standard...' OnClick = Standard1Click end object FullOpen1: TMenuItem Caption = '&Full Open...' OnClick = FullOpen1Click end object NoFullOpen1: TMenuItem Caption = '&No Full Open...' OnClick = NoFullOpen1Click end end object Print1: TMenuItem Caption = '&Print' object Print2: TMenuItem Caption = '&Print...' OnClick = Print2Click end object PrinterSetup1: TMenuItem Caption = 'Printer &Setup...' OnClick = PrinterSetup1Click end end object Search1: TMenuItem Caption = '&Search' object Search2: TMenuItem Caption = '&Search...' OnClick = Search2Click end object Replace1: TMenuItem Caption = '&Replace...' OnClick = Replace1Click end end object Help1: TMenuItem Caption = '&Help' object AboutCommonDialogsTest1: TMenuItem Caption = 'About Common Dialogs Test...' OnClick = AboutCommonDialogsTest1Click end end end object PrinterSetupDialog1: TPrinterSetupDialog Left = 248 Top = 64 end object FindDialog1: TFindDialog Options = [frDown, frMatchCase, frDisableMatchCase, frDisableUpDown, frDisableWholeWord] OnFind = FindDialog1Find Left = 376 Top = 16 end object ReplaceDialog1: TReplaceDialog Options = [frDown, frMatchCase, frDisableMatchCase, frDisableWholeWord] OnFind = ReplaceDialog1Find OnReplace = ReplaceDialog1Replace Left = 376 Top = 64 end object PrintDialog1: TPrintDialog Options = [poPrintToFile, poPageNums, poSelection, poWarning] Left = 248 Top = 16 end end
|
||
© Copyright Marco Cantù, 1995-2020, All rights reserved |