mainform.pas

《Delphi COM深入编程》原书光盘

unit MainForm;

interface

uses
  SysUtils, Windows, Registry, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, ActiveX, ShlObj, ExtCtrls, Menus,
  ShellAPI, ComCtrls, CommCtrl;

type
  TfrmMain = class(TForm)
    Panel1: TPanel;
    Panel2: TPanel;
    btnNew: TButton;
    btnOpen: TButton;
    btnSave: TButton;
    Label1: TLabel;
    Label2: TLabel;
    ecTarget: TEdit;
    btnFindTarget: TButton;
    Label3: TLabel;
    ecStartIn: TEdit;
    Label4: TLabel;
    Label5: TLabel;
    btnChangeIcon: TButton;
    cbRun: TComboBox;
    OpenTarget: TOpenDialog;
    Label6: TLabel;
    Label7: TLabel;
    ecDescription: TEdit;
    ecArguments: TEdit;
    OpenIcon: TOpenDialog;
    hkShortcut: THotKey;
    ecLinkName: TEdit;
    GroupBox1: TGroupBox;
    imgIcon: TImage;
    UpDown1: TUpDown;
    procedure btnNewClick(Sender: TObject);
    procedure btnFindTargetClick(Sender: TObject);
    procedure btnChangeIconClick(Sender: TObject);
    procedure UpDown1Click(Sender: TObject; Button: TUDBtnType);
    procedure btnSaveClick(Sender: TObject);
    procedure btnOpenClick(Sender: TObject);
    procedure ecTargetChange(Sender: TObject);
  private
    { Private declarations }
    FLinkFile: string;
    FLocation: Integer;
    FTarget: string;
    FDescription: string;
    FArguments: string;
    FIconFile: string;
    FIconIndex: Integer;
    FStartIn: string;
    FShortcut: Word;
    FRun: Integer;
    FLoading: Boolean;
    procedure SetFields;
    procedure CreateShortcut(const ALinkFile: WideString; AFolder: Integer);
    procedure LoadShortcut(const ALinkFile: WideString);
    procedure SaveShortcut(const ALinkFile: WideString);
    procedure ShowIcon;
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

uses
  ComObj, NewLinkForm;

{$R *.DFM}

const
  RunCommands: array[0 .. 2] of Integer =
    (SW_SHOWNORMAL, SW_SHOWMINIMIZED, SW_SHOWMAXIMIZED);

procedure TfrmMain.CreateShortcut(const ALinkFile: WideString;
  AFolder: Integer);
var
  ShellLink: IShellLink;
  PersistFile: IPersistFile;
  ItemIDList : PItemIDList;
  Dir: array[0 .. MAX_PATH] of char;
begin
  ShellLink := CreateComObject(CLSID_ShellLink) as IShellLink;
  PersistFile := ShellLink as IPersistFile;

  // Find the startup folder
  OleCheck(SHGetSpecialFolderLocation(0, AFolder, ItemIDList));
  if SHGetPathFromIDList(ItemIDList, Dir) then begin
    FLinkFile := string(Dir) + '\' + ALinkFile + '.lnk';
    OleCheck(PersistFile.Save(PWideChar(WideString(FLinkFile)), True));
  end;
end;

procedure TfrmMain.LoadShortcut(const ALinkFile: WideString);
var
  ShellLink: IShellLink;
  PersistFile: IPersistFile;
  AStr: array[0 .. MAX_PATH] of char;
  FindData: TWin32FindData;
  ShowCmd: Integer;
begin
  FLoading := True;
  try
    ShellLink := CreateComObject(CLSID_ShellLink) as IShellLink;
    PersistFile := ShellLink as IPersistFile;
    OleCheck(PersistFile.Load(PWideChar(ALinkFile), STGM_READ));

    // Gather information from shortcut
    FLinkFile := ALinkFile;
    OleCheck(ShellLink.GetPath(AStr, MAX_PATH, FindData, SLGP_SHORTPATH));
    FTarget := AStr;
    OleCheck(ShellLink.GetArguments(AStr, MAX_PATH));
    FArguments := AStr;
    OleCheck(ShellLink.GetDescription(AStr, MAX_PATH));
    FDescription := AStr;
    OleCheck(ShellLink.GetWorkingDirectory(AStr, MAX_PATH));
    FStartIn := AStr;
    OleCheck(ShellLink.GetIconLocation(AStr, MAX_PATH, FIconIndex));
    FIconFile := AStr;
    if FIconFile = '' then
      FIconFile := FTarget;
    OleCheck(ShellLink.GetShowCmd(ShowCmd));
    FRun := ShowCmd - 1;
    OleCheck(ShellLink.GetHotKey(FShortcut));

    // Display the information
    SetFields;
  finally
    FLoading := False;
  end;
end;

procedure TfrmMain.SaveShortcut(const ALinkFile: WideString);
var
  ShellLink: IShellLink;
  PersistFile: IPersistFile;
  HotKey: Word;
  HKMod: Byte;
begin
  ShellLink := CreateComObject(CLSID_ShellLink) as IShellLink;
  PersistFile := ShellLink as IPersistFile;
  OleCheck(PersistFile.Load(PWideChar(ALinkFile), STGM_SHARE_DENY_WRITE));

  // Assign hotkey
  HotKey := hkShortcut.HotKey;
  HKMod := 0;
  if hkCtrl in hkShortcut.Modifiers then
    HKMod := HKMod or HOTKEYF_CONTROL;
  if hkShift in hkShortcut.Modifiers then
    HKMod := HKMod or HOTKEYF_SHIFT;
  if hkAlt in hkShortcut.Modifiers then
    HKMod := HKMod or HOTKEYF_ALT;
  if hkExt in hkShortcut.Modifiers then
    HKMod := HKMod or HOTKEYF_EXT;
  HotKey := (HKMod shl 8) + HotKey;

  // Set parameters
  OleCheck(ShellLink.SetPath(PChar(ecTarget.Text)));
  OleCheck(ShellLink.SetIconLocation(PChar(FIconFile), FIconIndex));
  OleCheck(ShellLink.SetDescription(PChar(ecDescription.Text)));
  OleCheck(ShellLink.SetWorkingDirectory(PChar(ecStartIn.Text)));
  OleCheck(ShellLink.SetArguments(PChar(ecArguments.Text)));
  OleCheck(ShellLink.SetHotkey(HotKey));
  OleCheck(ShellLink.SetShowCmd(RunCommands[cbRun.ItemIndex]));

  // Save shortcut
  OleCheck(PersistFile.Save(PWideChar(ALinkFile), True));
end;

procedure TfrmMain.ShowIcon;
begin
  UpDown1.Max := ExtractIcon(hInstance, PChar(FIconFile),
    UINT(-1)) - 1;
    
  imgIcon.Picture.Icon.Handle := ExtractIcon(hInstance,
    PChar(FIconFile), FIconIndex);
end;

procedure TfrmMain.btnNewClick(Sender: TObject);
var
  frmNewShortcut: TfrmNewShortcut;
begin
  frmNewShortcut := TfrmNewShortcut.Create(nil);
  try
    if frmNewShortcut.ShowModal = mrOk then begin
      FLocation := frmNewShortcut.Folder;
      FLinkFile := frmNewShortcut.ecName.Text;
      CreateShortcut(FLinkFile, FLocation);

      // Enable fields and buttons
      UpDown1.Enabled := True;
      ecTarget.Enabled := True;
      ecDescription.Enabled := True;
      ecArguments.Enabled := True;
      ecStartIn.Enabled := True;
      hkShortcut.Enabled := True;
      cbRun.Enabled := True;
      btnFindTarget.Enabled := True;
      btnChangeIcon.Enabled := True;
      btnSave.Enabled := True;

      // Blank out fields
      FTarget := '';
      FDescription := '';
      FArguments := '';
      FIconFile := '';
      FIconIndex := 0;
      FStartIn := '';
      FShortcut := 0;
      FRun := 0;
      SetFields;
    end;
  finally
    frmNewShortcut.Free;
  end;
end;

procedure TfrmMain.SetFields;
var
  H: Byte;
  Modifier: THKModifiers;
begin
  ecLinkName.Text := FLinkFile;
  ecTarget.Text := FTarget;
  ecDescription.Text := FDescription;
  ecArguments.Text := FArguments;
  ecStartIn.Text := FStartIn;
  cbRun.ItemIndex := FRun;

  H := Hi(FShortcut);
  Modifier := [];
  if (H and HOTKEYF_ALT) = HOTKEYF_ALT then
    Include(Modifier, hkAlt);
  if (H and HOTKEYF_CONTROL) = HOTKEYF_CONTROL then
    Include(Modifier, hkCtrl);
  if (H and HOTKEYF_EXT) = HOTKEYF_EXT then
    Include(Modifier, hkExt);
  if (H and HOTKEYF_SHIFT) = HOTKEYF_SHIFT then
    Include(Modifier, hkShift);
  hkShortcut.HotKey := FShortcut;
  hkShortcut.Modifiers := Modifier;

  ShowIcon;
  ActiveControl := ecTarget;
end;

procedure TfrmMain.btnFindTargetClick(Sender: TObject);
begin
  if OpenTarget.Execute then begin
    ecTarget.Text := OpenTarget.FileName;
    FIconFile := ecTarget.Text;
    FIconIndex := 0;
    UpDown1.Max := ExtractIcon(hInstance, PChar(FIconFile),
      UINT(-1)) - 1;
    UpDown1.Position := 0;

    ShowIcon;
  end;
end;

procedure TfrmMain.btnChangeIconClick(Sender: TObject);
begin
  if OpenIcon.Execute then begin
    FIconFile := OpenIcon.FileName;
    FIconIndex := 0;
    UpDown1.Max := ExtractIcon(hInstance, PChar(FIconFile),
      UINT(-1)) - 1;
    UpDown1.Position := 0;

    ShowIcon;
  end;
end;

procedure TfrmMain.UpDown1Click(Sender: TObject; Button: TUDBtnType);
begin
  FIconIndex := UpDown1.Position;
  ShowIcon;
end;

procedure TfrmMain.btnSaveClick(Sender: TObject);
begin
  // Make sure the user specified a target
  if ecTarget.Text = '' then begin
    ShowMessage('Please specify a target file before saving.');
    exit;
  end;

  SaveShortcut(FLinkFile);
end;

procedure TfrmMain.btnOpenClick(Sender: TObject);
begin
  if OpenTarget.Execute then begin
    LoadShortcut(OpenTarget.FileName);
  end;
end;

procedure TfrmMain.ecTargetChange(Sender: TObject);
begin
  if not FLoading then begin
    FIconFile := ecTarget.Text;
    FIconIndex := 0;

    ShowIcon;
  end;
end;

end.