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 5

Project SHCUT

Project Structure


SHCUT.DPR

program ShCut;

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

{$R *.RES}

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

SHCUTF.PAS

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.

SHCUTF.DFM

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