Delphi 建立快捷方式

unit Unit1 ;

interface

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

type
TForm1 = class (TForm )
Button1 : TButton ;
Button2 : TButton ;
Button3 : TButton ;
Button4 : TButton ;
procedure Button1Click (Sender : TObject ) ;
procedure Button2Click (Sender : TObject ) ;
procedure Button3Click (Sender : TObject ) ;
procedure Button4Click (Sender : TObject ) ;
end ;

var
Form1 : TForm1 ;

implementation

{$R *.dfm}

uses
ShlObj , ActiveX , ComObj ; {该函数使用的单元}

{函数说明:}
{第一个参数是要建立快捷方式的文件, 这是必须的; 其他都是可选参数}
{第二个参数是快捷方式名称, 缺省使用参数一的文件名}
{第三个参数是指定目的文件夹, 缺省目的是桌面; 如果有第四个参数, 该参数将被忽略}
{第四个参数是用常数的方式指定目的文件夹; 该系列常数定义在 ShlObj 单元, CSIDL_ 打头}
function CreateShortcut (Exe : string ; Lnk : string = '' ; Dir : string = '' ; ID : Integer = - 1 ) : Boolean ;
var
IObj : IUnknown ;
ILnk : IShellLink ;
IPFile : IPersistFile ;
PIDL : PItemIDList ;
InFolder : array [0 .. MAX_PATH ] of Char ;
LinkFileName : WideString ;
begin
Result : = False ;
if not FileExists (Exe ) then Exit ;
if Lnk = '' then Lnk : = ChangeFileExt ( ExtractFileName (Exe ) , '' ) ;

IObj : = CreateComObject (CLSID_ShellLink ) ;
ILnk : = IObj as IShellLink ;
ILnk . SetPath ( PChar (Exe ) ) ;
ILnk . SetWorkingDirectory ( PChar ( ExtractFilePath (Exe ) ) ) ;

if (Dir = '' ) and (ID = - 1 ) then ID : = CSIDL_DESKTOP ;
if ID > - 1 then
begin
SHGetSpecialFolderLocation ( 0 , ID , PIDL ) ;
SHGetPathFromIDList (PIDL , InFolder ) ;
LinkFileName : = Format ( '%s\%s.lnk' , [InFolder , Lnk ] ) ;
end else
begin
Dir : = ExcludeTrailingPathDelimiter (Dir ) ;
if not DirectoryExists (Dir ) then Exit ;
LinkFileName : = Format ( '%s\%s.lnk' , [Dir , Lnk ] ) ;
end ;

IPFile : = IObj as IPersistFile ;
if IPFile . Save ( PWideChar (LinkFileName ) , False ) = 0 then Result : = True ;
end ; {CreateShortcut 函数结束}


{测试 1: 把当前程序在桌面上建立快捷方式}
procedure TForm1 . Button1Click (Sender : TObject ) ;
begin
CreateShortcut (Application . ExeName ) ;
end ;

{测试 2: 在桌面上建立快捷方式, 同时指定快捷方式名称}
procedure TForm1 . Button2Click (Sender : TObject ) ;
begin
CreateShortcut (Application . ExeName , 'NewLinkName' ) ;
end ;

{测试 3: 在 C:\ 下建立快捷方式}
procedure TForm1 . Button3Click (Sender : TObject ) ;
begin
CreateShortcut (Application . ExeName , '' , 'C:\' ) ;
end ;

{测试 3: 在开始菜单的程序文件夹下建立快捷方式}
procedure TForm1 . Button4Click (Sender : TObject ) ;
begin
CreateShortcut (Application . ExeName , '' , '' , CSIDL_PROGRAMS ) ;
end ;

end .