本文整理自网络，侵删。
Delphi创建桌面快捷方式、右键添加发送到...、添加快速启动栏、开始菜单、程序菜单、右键菜单、win7锁定任务栏
{ =================================================================
功 能:
创建 桌面、发送到...、快速启动栏、开始菜单、程序菜单、右键菜单 快捷方式
参 数:
SourceFileName:string; //源程序的位置
ShortcutName : string; //快捷方式的名称
ShortcutLocation:ShortcutType;//快捷方式的建立位置
SubDirectory : string //程序组的名称
返 回 值: True
备 注:
需要引用 Registry, ShlObj, ComObj, ActiveX, RegStr 单元
================================================================= }
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs,
Registry, ShlObj, ComObj, ActiveX, RegStr, StdCtrls, ShellAPI;
type
ShortcutType = (_DESKTOP, // 桌面
_STARTMENU, // 开始菜单
_PROGRAMS, // 程序
_STARTUP, // 启动
_QUICKLAUNCH // 快捷启动栏
);
TForm1 = class(TForm)
Button1: TButton;
ComboBox1: TComboBox;
Button2: TButton;
procedure ComboBox1Change(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
function CreateShortcut(SourceFileName, ShortcutName: string;
ShortcutLocation: ShortcutType; SubDirectory: string): boolean;
public
{ Public declarations }
end;
var
Form1: TForm1;
Path: string;
implementation
{$R *.dfm}
function TForm1.CreateShortcut(SourceFileName: string; // 源程序的位置
ShortcutName: string; // 快捷方式的名称
ShortcutLocation: ShortcutType; // 快捷方式的建立位置
SubDirectory: string // 程序组的名称
): boolean;
const
REG_SHELLFOLDERS =
'Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders';
var
MyObject: IUnknown; // IUnknown是基本的COM类
MySLink: IShellLink; // 用于创建快捷方式的对象
MyPFile: IPersistFile; // 用于保存快捷方式的对象
SubDir, Directory, LinkName: string;
WFileName: WideString;
Reg: TRegistry;
begin
Result := False;
MyObject := CreateCOMObject(CLSID_ShellLink); // 建立快捷方式的COM对象
MySLink := MyObject as IShellLink;
MyPFile := MyObject as IPersistFile;
MySLink.SetPath(pchar(SourceFileName)); // 设置快捷方式源文件的位置
Reg := TRegistry.Create;
Reg.RootKey := HKEY_CURRENT_USER;
try
if Reg.OpenKey(REG_SHELLFOLDERS, False) then
begin
if SourceFileName <> '' then
if ShortcutName <> '' then
LinkName := ShortcutName
else
LinkName := ExtractFileName(SourceFileName)
Else // 当源路径是一个空值时，实际它指向“我的电脑”
LinkName := '我的电脑';
MySLink.SetDescription(pchar(LinkName)); // 设置快捷方式描述
LinkName := ChangeFileExt(LinkName, '.lnk'); // 修改扩展名
// 以下通过注册表得到快捷方式的实际建立位置
case ShortcutLocation of
_DESKTOP:
Directory := Reg.ReadString('Desktop');
_STARTMENU:
Directory := Reg.ReadString('Start Menu');
_PROGRAMS:
Directory := Reg.ReadString('Programs');
_STARTUP:
Directory := Reg.ReadString('Startup');
_QUICKLAUNCH:
Directory := Reg.ReadString('AppData') +
'\Microsoft\Internet Explorer\Quick Launch'; // 快速启动栏的路径比较特殊
end;
if Directory <> '' then
begin
if SubDirectory <> '' then
begin
SubDir := Directory + '\' + SubDirectory;
WFileName := SubDir + '\' + LinkName;
if not CreateDir(SubDir) then // 创建目录失败
begin
Result := False;
Exit;
end;
end
else
WFileName := Directory + '\' + LinkName;
if MyPFile.Save(PWChar(WFileName), True) <> S_OK then
begin
Result := False;
Exit;
end
else
Result := True;
end
else
Result := False;
end;
finally
Reg.Free; // 释放空间
end;
end;
procedure CrnPinAppToWin7Taskbar(strPath, strApp: string); // 锁定到win7任务栏
var
vShell, vFolder, vFolderItem, vItemVerbs: Variant;
vPath, vApp: Variant;
i: Integer;
str, strPinName: String;
begin
vShell := CreateOleObject('Shell.Application');
vPath := strPath;
vFolder := vShell.NameSpace(vPath);
vApp := strApp;
vFolderItem := vFolder.ParseName(vApp);
vItemVerbs := vFolderItem.Verbs;
// 以下的PinName只适用于中文版的系统
// 英文版的系统要用'Pin to Tas&kbar'
// strPinName := 'Pin to Tas&kbar';
strPinName := '锁定到任务栏(&K)';
for i := 1 to vItemVerbs.Count do
begin
str := vItemVerbs.Item(i).Name;
if SameText(str, strPinName) then
begin
// 63 63 72 75 6E 2E 63 6F 6D
vItemVerbs.Item(i).DoIt;
end;
end;
end;
procedure TForm1.ComboBox1Change(Sender: TObject);
begin
Button1.Caption := ComboBox1.Text;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Path := ExpandFileName(ParamStr(0));
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
CrnPinAppToWin7Taskbar(ExtractFileDir(Application.Exename),
ExtractFileName(Application.Exename));
end;
procedure TForm1.Button1Click(Sender: TObject);
var
SLinkType: ShortcutType;
begin
case ComboBox1.ItemIndex of
0:
SLinkType := _DESKTOP;
1:
SLinkType := _STARTMENU;
2:
SLinkType := _PROGRAMS;
3:
SLinkType := _STARTUP;
4:
SLinkType := _QUICKLAUNCH;
end;
if CreateShortcut(Path, ExtractFileName(Application.Exename), SLinkType, '')
then
Application.MessageBox(pchar('快捷方式创建成功!'), pchar('系统消息'), MB_OK)
else
Application.MessageBox(pchar('快捷方式创建失败!'), pchar('系统消息'), MB_OK);
end;
end.
相关阅读 >>
Delphi webbrowser同时访问两个网址导致程序出错的解决办法
Delphi idhttp组件+idhttpserver组件实现文件下载服务
Delphi xe berlin readprocessmemory writeprocessmemory
Delphi windows 编程[8] - wm_paint 消息
Delphi setfileattributes 功能:修改文件属性
更多相关阅读请进入《Delphi》频道 >>
