Home: Code Repository: Mastering Delphi 5

Project SHCUT

Project Structure

SHCUT.DPR
SHCUTF.PAS
SHCUTF.DFM

program ShCut;

uses
  Forms,
  ShCutF in 'ShCutF.pas' {Form1};

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

unit ShCutF;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    EditName: TEdit;
    Label1: TLabel;
    Button2: TButton;
    GroupBox1: TGroupBox;
    cbDir: TCheckBox;
    cbDesktop: TCheckBox;
    cbStartMenu: TCheckBox;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses
  ComObj, ActiveX, ShlObj, Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
  AnObj: IUnknown;
  ShLink: IShellLink;
  PFile: IPersistFile;
  FileName: string;
  WFileName: WideString;
  Reg: TRegIniFile;
begin
  // access to the two interfaces of the object
  AnObj := CreateComObject (CLSID_ShellLink);
  ShLink := AnObj as IShellLink;
  PFile := AnObj as IPersistFile;
  // get the name of the application file
  FileName := ParamStr (0);
  // set the link properties
  ShLink.SetPath (PChar (FileName));
  ShLink.SetWorkingDirectory (PChar (
    ExtractFilePath (FileName)));

  // save the file in the current dir
  if cbDir.Checked then
  begin
    // using a WideString
    WFileName := ExtractFilePath (FileName) +
      EditName.Text + '.lnk';
    PFile.Save (PWChar (WFileName), False);
  end;

  // save on the desktop
  if cbDesktop.Checked then
  begin
    Reg := TRegIniFile.Create(
      'Software\MicroSoft\Windows\CurrentVersion\Explorer');
    WFileName := Reg.ReadString ('Shell Folders', 'Desktop', '') +
      '\' + EditName.Text + '.lnk';
    Reg.Free;
    PFile.Save (PWChar (WFileName), False);
  end;

  // save in the Start Menu
  if cbStartMenu.Checked then
  begin
    Reg := TRegIniFile.Create(
      'Software\MicroSoft\Windows\CurrentVersion\Explorer');
    WFileName := Reg.ReadString ('Shell Folders', 'Start Menu', '') +
      '\' + EditName.Text + '.lnk';
    Reg.Free;
    PFile.Save (PWChar (WFileName), False);
  end;
end;

// add a document to the Start menu documents list
procedure TForm1.Button2Click(Sender: TObject);
var
  ProjectFile: string;
begin
  ProjectFile := ChangeFileExt (ParamStr (0), '.dpr');
  SHAddToRecentDocs (SHARD_PATH, PChar(ProjectFile));
end;

end.

object Form1: TForm1
  Left = 222
  Top = 139
  Width = 242
  Height = 241
  Caption = 'Short Cut'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = True
  PixelsPerInch = 96
  TextHeight = 13
  object Label1: TLabel
    Left = 16
    Top = 8
    Width = 88
    Height = 13
    Caption = 'Shortcut Filename:'
  end
  object Button1: TButton
    Left = 16
    Top = 168
    Width = 97
    Height = 25
    Caption = 'Create'
    TabOrder = 0
    OnClick = Button1Click
  end
  object EditName: TEdit
    Left = 16
    Top = 24
    Width = 201
    Height = 21
    TabOrder = 1
    Text = 'Shortcut to ShCut.exe Delphi Demo'
  end
  object Button2: TButton
    Left = 120
    Top = 168
    Width = 97
    Height = 25
    Caption = 'Add Document'
    TabOrder = 2
    OnClick = Button2Click
  end
  object GroupBox1: TGroupBox
    Left = 16
    Top = 56
    Width = 201
    Height = 97
    Caption = 'Create in'
    TabOrder = 3
    object cbDir: TCheckBox
      Left = 24
      Top = 16
      Width = 97
      Height = 21
      Caption = 'Current Directory'
      Checked = True
      State = cbChecked
      TabOrder = 0
    end
    object cbDesktop: TCheckBox
      Left = 24
      Top = 40
      Width = 97
      Height = 17
      Caption = 'Desktop'
      TabOrder = 1
    end
    object cbStartMenu: TCheckBox
      Left = 24
      Top = 64
      Width = 97
      Height = 17
      Caption = 'Start Menu'
      TabOrder = 2
    end
  end
end