Marco's Web Center

Menu for Development

Site Menu
Object Pascal Handbook
Delphi Handbooks Collection
Mastering Borland Delphi 2005
(Old) White Papers
(Old)Tools
(Old) Conferences

My Other Sites
Italian Site (www.marcocantu.it)
the delphi search

Spirit of delphi

Advertising
Home My Blog Books Object Pascal Marco

Home: Code Repository: Mastering Delphi 6

Chapter 09 - Project CommDlg

Project Structure

CommDlg.dpr
program Commdlg;

uses
  Forms,
  CdlgTest in 'CdlgTest.pas' {CommDlgForm};

{$R *.RES}

begin
  Application.CreateForm(TCommDlgForm, CommDlgForm);
  Application.Run;
end.
CdlgTest.pas
unit 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.dfm
object 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