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 QCommDlg

Project Structure

QCommDlg.dpr
program QCommDlg;

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

{$R *.res}

begin
  Application.CreateForm(TCommDlgForm, CommDlgForm);
  Application.Run;
end.
CdlgTest.pas
unit Cdlgtest;

interface

uses
  Qt, Classes, QGraphics, QForms, QControls,
  QMenus, QStdCtrls, QDialogs, QTypes;

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;
    Standard1: TMenuItem;
    Help1: TMenuItem;
    AboutCommonDialogsTest1: TMenuItem;
    FindDialog1: TFindDialog;
    ReplaceDialog1: TReplaceDialog;
    Search1: TMenuItem;
    Search2: TMenuItem;
    Replace1: TMenuItem;
    Others1: TMenuItem;
    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 Standard1Click(Sender: TObject);
    procedure FullOpen1Click(Sender: TObject);
    procedure NoFullOpen1Click(Sender: TObject);
    procedure AboutCommonDialogsTest1Click(Sender: TObject);
    procedure Search2Click(Sender: TObject);
    procedure Replace1Click(Sender: TObject);
    procedure FindDialog1Find(Sender: TObject);
    procedure ReplaceDialog1Replace(Sender: TObject);
    procedure ReplaceDialog1Find(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  CommDlgForm: TCommDlgForm;

implementation

{$R *.xfm}

procedure TCommDlgForm.TextFiles1Click(Sender: TObject);
begin
  with OpenDialog1 do
  begin
    Filter := 'Text File (*.txt)|*.txt';
    DefaultExt := 'txt';
    Filename := '';
    Options := [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];
    if Execute then
      for i := 0 to Files.Count - 1 do
        if MessageDlg ('Open file ' + Files.Strings [i] + '?',
            mtConfirmation, [mbYes, mbNo], 0) = mrYes 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 := [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
    if Execute then
      Memo1.Font := Font;
  end;
end;

procedure TCommDlgForm.NoEffects1Click(Sender: TObject);
begin
  with FontDialog1 do
  begin
    if Execute then
      Memo1.Font := Font;
  end;
end;

procedure TCommDlgForm.NoStyle1Click(Sender: TObject);
begin
  with FontDialog1 do
  begin
    if Execute then
      Memo1.Font := Font;
  end;
end;

procedure TCommDlgForm.Standard1Click(Sender: TObject);
begin
  with ColorDialog1 do
  begin
    if Execute then
      Memo1.Color := Color;
  end;
end;

procedure TCommDlgForm.FullOpen1Click(Sender: TObject);
begin
  with ColorDialog1 do
  begin
    if Execute then
      Memo1.Color := Color;
  end;
end;

procedure TCommDlgForm.NoFullOpen1Click(Sender: TObject);
begin
  with ColorDialog1 do
  begin
    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.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;

end.
CdlgTest.xfm
object CommDlgForm: TCommDlgForm
  Left = 119
  Top = 153
  Width = 532
  Height = 355
  ActiveControl = Memo1
  Caption = 'Common Dialogs Test'
  Color = clButton
  Font.Color = clBlack
  Font.Height = 11
  Font.Name = 'MS Sans Serif'
  Font.Pitch = fpVariable
  Font.Style = []
  Font.Weight = 40
  Menu = MainMenu1
  ParentFont = False
  PixelsPerInch = 96
  TextHeight = 13
  TextWidth = 6
  object Memo1: TMemo
    Left = 0
    Top = 0
    Width = 532
    Height = 332
    Align = alClient
    Font.Color = clBlack
    Font.Height = 13
    Font.Name = 'Times New Roman'
    Font.Pitch = fpVariable
    Font.Style = []
    Font.Weight = 40
    ParentFont = False
    ScrollBars = ssBoth
    TabOrder = 0
  end
  object OpenDialog1: TOpenDialog
    Title = 'Open'
    Left = 96
    Top = 16
  end
  object SaveDialog1: TSaveDialog
    Title = 'Save As'
    Left = 96
    Top = 64
  end
  object FontDialog1: TFontDialog
    Font.Color = clText
    Font.Height = 13
    Font.Name = 'System'
    Font.Pitch = fpVariable
    Font.Style = []
    Font.Weight = 40
    Left = 168
    Top = 16
  end
  object ColorDialog1: TColorDialog
    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 Others1: TMenuItem
      Caption = 'Others'
      object Font1: TMenuItem
        Caption = '&Font'
        OnClick = OnlyTrueType1Click
      end
      object Standard1: TMenuItem
        Caption = '&Color...'
        OnClick = Standard1Click
      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 FindDialog1: TFindDialog
    Options = [frDown, frMatchCase, frDisableMatchCase, frDisableUpDown, frDisableWholeWord]
    Title = 'Find'
    OnFind = FindDialog1Find
    Left = 376
    Top = 16
  end
  object ReplaceDialog1: TReplaceDialog
    Options = [frDown, frMatchCase, frDisableMatchCase, frDisableWholeWord]
    Title = 'Replace'
    OnFind = ReplaceDialog1Find
    OnReplace = ReplaceDialog1Replace
    Left = 376
    Top = 64
  end
end