Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue66/Shell/FileAssocU.pas

Pascal/Delphi Source File | 2000-11-14 | 5.9 KB | 230 lines

unit FileAssocU;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  DdeMan, StdCtrls, ComCtrls, Menus, ToolWin, ActnList, ImgList, StdActns;

type
  TMainForm = class(TForm)
    System: TDdeServerConv;
    MainMenu1: TMainMenu;
    ActionList1: TActionList;
    ImageList1: TImageList;
    actNew: TAction;
    actOpen: TAction;
    actClose: TAction;
    actPrint: TAction;
    actExit: TAction;
    ToolBar1: TToolBar;
    File1: TMenuItem;
    New1: TMenuItem;
    Close1: TMenuItem;
    Close2: TMenuItem;
    N1: TMenuItem;
    N2: TMenuItem;
    Print1: TMenuItem;
    Exit1: TMenuItem;
    ToolButton1: TToolButton;
    ToolButton2: TToolButton;
    ToolButton3: TToolButton;
    ToolButton4: TToolButton;
    ToolButton5: TToolButton;
    ToolButton6: TToolButton;
    ToolButton7: TToolButton;
    dlgOpenFile: TOpenDialog;
    Edit1: TMenuItem;
    EditCopy1: TEditCopy;
    EditCut1: TEditCut;
    EditDelete1: TEditDelete;
    EditPaste1: TEditPaste;
    EditSelectAll1: TEditSelectAll;
    EditUndo1: TEditUndo;
    Undo1: TMenuItem;
    N3: TMenuItem;
    Cut1: TMenuItem;
    Copy1: TMenuItem;
    Paste1: TMenuItem;
    Delete1: TMenuItem;
    SelectAll1: TMenuItem;
    ToolButton8: TToolButton;
    ToolButton9: TToolButton;
    ToolButton10: TToolButton;
    ToolButton11: TToolButton;
    ToolButton12: TToolButton;
    ToolButton13: TToolButton;
    ToolButton14: TToolButton;
    Window1: TMenuItem;
    WindowArrange1: TWindowArrange;
    WindowCascade1: TWindowCascade;
    WindowMinimizeAll1: TWindowMinimizeAll;
    WindowTileHorizontal1: TWindowTileHorizontal;
    WindowTileVertical1: TWindowTileVertical;
    Arrange1: TMenuItem;
    Cascade1: TMenuItem;
    MinimizeAll1: TMenuItem;
    N4: TMenuItem;
    TileHorizontally1: TMenuItem;
    MinimizeAll2: TMenuItem;
    procedure SystemExecuteMacro(Sender: TObject; Msg: TStrings);
    procedure actNewExecute(Sender: TObject);
    procedure actOpenExecute(Sender: TObject);
    procedure actCloseExecute(Sender: TObject);
    procedure actCloseUpdate(Sender: TObject);
    procedure actPrintExecute(Sender: TObject);
    procedure actPrintUpdate(Sender: TObject);
    procedure actExitExecute(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  MainForm: TMainForm;

implementation

uses FileAssocU2;

{$R *.DFM}

//Turn string containing possibly many commands in
//square brackets into multiple strings, each
//containing one command, without square brackets
procedure MassageCmds(Cmds: TStrings);
var
  S: String;
  OpenCmd, CloseCmd: Integer;
begin
  S := Trim(Cmds.Text);
  Cmds.Clear;
  while Length(S) > 0 do
  begin
    OpenCmd := Pos('[', S);
    CloseCmd := Pos(']', S);
    if (OpenCmd < CloseCmd) and (OpenCmd >= 1) then
    begin
      Cmds.Add(Trim(Copy(S, OpenCmd+1, CloseCmd-OpenCmd-1)));
      Delete(S, OpenCmd, CloseCmd-OpenCmd+1);
      S := Trim(S)
    end
    else
      Break
  end;
end;

type
  TCommandType = (ctNone, ctOpen, ctPrint, ctClose, ctExit);

var
  Commands: array[TCommandType] of String = ('', 'Open', 'Print', 'Close', 'Exit');

//Return a TCommandType value corresponding to a specified command string
function StrToCommand(const Cmd: String): TCommandType;
var
  Idx: TCommandType;
begin
  for Idx := Succ(Low(TCommandType)) to High(TCommandType) do
    if CompareText(Cmd, Commands[Idx]) = 0 then
    begin
      Result := Idx;
      Exit
    end;
  Result := ctNone;
  MessageDlg(Format('Unknown DDE command "%s"', [Cmd]),
    mtError, [mbCancel], 0)
end;

//For a given command string, return the command
//type and specified filename, if present
function GetCommandAndParameter(CmdText: String; var Command: TCommandType;
  var Parameter: String): Boolean;
var
  OpenParens, CloseParens: Integer;
begin
  Result := True;
  OpenParens := Pos('(', CmdText);
  CloseParens := Pos(')', CmdText);
  if (OpenParens < CloseParens) and (OpenParens > 1) then
  begin
    Command := StrToCommand(Trim(Copy(CmdText, 1, OpenParens - 1)));
    if Command = ctNone then
      Result:= False
    else
    begin
      Parameter := Copy(CmdText, OpenParens+1, CloseParens-OpenParens-1);
      Parameter := Trim(StringReplace(Parameter, '"', '', [rfReplaceAll]));
    end
  end
end;

procedure TMainForm.SystemExecuteMacro(Sender: TObject; Msg: TStrings);
var
  I: Integer;
  Cmd: TCommandType;
  Parameter: String;
begin
  //Here is where we parse the DDE Message (or macro) and act on its commands
  MassageCmds(Msg);
  for I := 0 to Msg.Count - 1 do
    if GetCommandAndParameter(Msg[I], Cmd, Parameter) then
    begin
      case Cmd of
        ctOpen:
        begin
          dlgOpenFile.FileName := Parameter;
          actOpen.Execute
        end;
        ctPrint: actPrint.Execute;
        ctClose: actClose.Execute;
        ctExit: actExit.Execute
      end
    end
end;

procedure TMainForm.actNewExecute(Sender: TObject);
begin
  TChildForm.Create(Application, '')
end;

procedure TMainForm.actOpenExecute(Sender: TObject);
begin
  if dlgOpenFile.FileName = '' then
  begin
    if not dlgOpenFile.Execute then
      Exit
  end;
  TChildForm.Create(Application, dlgOpenFile.FileName);
  dlgOpenFile.FileName := ''
end;

procedure TMainForm.actCloseExecute(Sender: TObject);
begin
  ActiveMDIChild.Close
end;

procedure TMainForm.actCloseUpdate(Sender: TObject);
begin
  actClose.Enabled := Assigned(ActiveMDIChild)
end;

procedure TMainForm.actPrintExecute(Sender: TObject);
begin
  ShowMessageFmt('Printing "%s" not supported',
    [(ActiveMDIChild as TChildForm).FileName])
end;

procedure TMainForm.actPrintUpdate(Sender: TObject);
begin
  actPrint.Enabled := Assigned(ActiveMDIChild)
end;

procedure TMainForm.actExitExecute(Sender: TObject);
begin
  Close
end;

end.