Delphi专题 ·

用Delphi创建桌面快捷方式及win7锁定任务栏等功能

一、实现功能

Delphi创建桌面快捷方式、右键添加发送到...、添加快速启动栏、开始菜单、程序菜单、右键菜单、win7锁定任务栏

用Delphi创建桌面快捷方式及win7锁定任务栏等功能 Delphi专题 第1张

二、参考代码

{ =================================================================
  功    能:
  创建 桌面、发送到...、快速启动栏、开始菜单、程序菜单、右键菜单 快捷方式
  参     数:
  SourceFileName:string; //源程序的位置
  ShortcutName : string;  //快捷方式的名称
  ShortcutLocation:ShortcutType;//快捷方式的建立位置
  SubDirectory : string      //程序组的名称
  返 回 值: True
  备    注:
  需要引用 Registry, ShlObj, ComObj, ActiveX, RegStr 单元
  ================================================================= }

{ =================================================================
  功 能:
  创建 桌面、发送到...、快速启动栏、开始菜单、程序菜单、右键菜单 快捷方式
  参 数:
  SourceFileName:string; //源程序的位置
  ShortcutName : string; //快捷方式的名称
  ShortcutLocation:ShortcutType;//快捷方式的建立位置
  SubDirectory : string //程序组的名称
  返 回 值: True
  www.amingstudio.com
  备 注:
  需要引用 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.

相关下载

点击下载

参与评论