unit CreateShortcutUnit;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  plShortcutUtils,
  ShlObj;

{$R *.dfm}

//=============================================================================
//  指定ディレクトリ内にショートカットを作成
//  ここではデスクトップに本プログラムのショートカットを作成
//
//  添付のplShortcutUtilsユニット内の関数類を使用
//  CSIDL_DESKTOP等の定数名の使用にはusesにShlObjが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LDir : String;
begin
  //CSIDLの値からフルパスを取得
  //ショートカットを作成する場所
  LDir := GetDirectoryFromCSIDL(CSIDL_DESKTOP);

  if CreateShortCutLink(Application.ExeName, LDir, 'テストリンク') then begin
    //ショートカットの作成場所によっては，以下のコードで更新が必要
    //SendMessage(HWND_BROADCAST, WM_SETTINGCHANGE, 0, 0);
  end;
end;

//=============================================================================
//  指定ディレクトリ内のショートカットを削除
//  ここではデスクトップ上の，このプログラムのショートカットを削除
//
//  添付のplShortcutUtilsユニット内の関数類を使用
//  CSIDL_DESKTOP等の定数名の使用にはusesにShlObjが必要
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  LDir : String;
begin
  //CSIDLの値からフルパスを取得
  //削除するショートカットがある場所
  LDir := GetDirectoryFromCSIDL(CSIDL_DESKTOP);

  if DeleteShorCutLink(Application.ExeName, LDir) then begin
    //ショートカットの場所によっては，以下のコードで更新が必要
    //SendMessage(HWND_BROADCAST, WM_SETTINGCHANGE, 0, 0);
  end;
end;

end.

unit plShortcutUtils;

interface

uses
  Windows, SysUtils;

  function GetDirectoryFromCSIDL(AnFolder: Integer): string;
  function CreateShortCutLink(AszFileName: string; ADirectory: string;
    AswFileName: String): Boolean;
  function DeleteShorCutLink(AFindPath, ASearchFolder: String): Boolean;
  function FindFileShortCutLink(AFindPath, ASearchFolder: string): string;
  function GetLinkPathName(ALinkFilePath: string): string;
  function ChangeShortCutIcon(ALinkFilePath, AIconFilePath: string;
    AIconIndex: Integer): Boolean;
  function GetShortCutIconPath(ALinkFilePath: string; var AIconFilePath: string;
    var AIconIndex: Integer): Boolean;

implementation

uses
  ShlObj,
  ActiveX,
  ComObj,
  IOUtils,
  Types;

//-----------------------------------------------------------------------------
//  特殊フォルダのフルパスをCSIDL値から取得する関数
//  CSIDLの値からフルパスを取得する方法は他にもある
//
//  CoTaskMemFreeの使用にはusesにActiveXが必要
//  SHXXX名の関数の使用にはusesにShObjが必要
//-----------------------------------------------------------------------------
function GetDirectoryFromCSIDL(AnFolder: Integer): string;
var
  LBuff : array[0..MAX_PATH-1] of Char;
  Lpidl : PItemIDList;
begin
  Lpidl := nil;

  //CSIDL値から項目識別子を取得
  SHGetSpecialFolderLocation(0, AnFolder, Lpidl);
  //項目識別子からパス名を取得
  SHGetPathFromIDList(Lpidl, LBuff);
  Result := LBuff;

  CoTaskMemFree(Lpidl);
end;

//-----------------------------------------------------------------------------
//  指定場所にショートカットを作成
//
//  AszFileName : リンク元のファイルのフルパス名
//  ADirectory  : ショートカットを作成する場所(ディレクトリ名)
//  AswFileName : ショートカットに付ける名前
//                空文字の場合はリンク先のファイル名+'へのショートカット.lnk'
//
//  CreateComObjectの使用にはusesにComObjが必要
//  IShellLinkの使用にはusesにShObjが必要
//  IPersistFileの使用にはusesにActiveXが必要
//-----------------------------------------------------------------------------
function CreateShortCutLink(AszFileName: string; ADirectory: string;
  AswFileName: string): Boolean;
var
  LUnknownObject : IUnknown;
  LIShellLink    : IShellLink;
  LIPersistFile  : IPersistFile;
  LwFileName     : string;
begin
  Result := False;

  //IShellLink,IPersistFileインターフェイスのオブジェクトを生成
  LUnknownObject := CreateComObject(CLSID_SHELLLINK);
  LIShellLink    := LUnknownObject as IShellLink;
  LIPersistFile  := LUnknownObject as IPersistFile;
  if not Assigned(LIShellLink) or not Assigned(LIPersistFile) then exit;

  //リンク元の指定
  LIShellLink.SetPath(PChar(AszFileName));
  LIShellLink.SetWorkingDirectory(PChar(ExtractFilePath(AszFileName)));

  //シュートカットに付ける名前を作成
  if AswFileName <> '' then begin
    //本関数で引数で名前の指定があればそれを使用
    LwFileName := IncludeTrailingPathDelimiter(ADirectory) +
                  AswFileName + '.lnk';
  end else begin
    //名前の指定がなければデフォルトで以下にする
    LwFileName := IncludeTrailingPathDelimiter(ADirectory) +
                  ExtractFileName(AszFileName) + 'へのショートカット.lnk';
  end;
  //リンク作成
  //IPersistFile.Saveメソッドを実行すると結果が反映される
  if LIPersistFile.Save(PChar(LwFileName), False) = S_OK then begin
    Result := True;
  end;
end;

//-----------------------------------------------------------------------------
//  指定場所のショートカットを削除
//  リンク先のフルパスで探して削除する
//  拡張子が.lnkのファイルで検索すると名前が変更されていると見つからないので
//
//  AFindPath     : ショートカットの元ファイル(実行形式ファイルなど)
//  ASearchFolder : このフォルダの中のショートカットを削除
//-----------------------------------------------------------------------------
function DeleteShorCutLink(AFindPath, ASearchFolder: string): Boolean;
var
  LLinkFullPath : string;
begin
  Result := False;

  //リンク元のリンクがASerchFolderにあるか調査
  LLinkFullPath := FindFileShortCutLink(AFindPath, ASearchFolder);
  if LLinkFullPath <> '' then begin
    Result := DeleteFile(LLinkFullPath);
  end;
end;

//-----------------------------------------------------------------------------
//  指定したファイルが指定フォルダ内にあるか調査
//
//  AFindPathのファイルのショートカットがASearchFolderフォルダ内にあるかを検索
//  トリンクが作成されているかを検出する
//  ショートカットの名前が変更されている場合も検索可能
//  ショートカットがない場合は空文字，存在すればフルパス名(拡張子は.lnk)を返す
//
//  TStringDynArrayの使用にはusesにTypesが必要
//  TSearchOption, TDirectoryの使用にはusesにIOUtilsが必要
//-----------------------------------------------------------------------------
function FindFileShortCutLink(AFindPath, ASearchFolder: string): string;
var
  LPattern   : string;
  LOption    : TSearchOption;
  LFileNames : TStringDynArray;
  LFileName  : string;
begin
  Result := '';

  //ファイルの検索パターンとディレクトリの列挙モードを設定
  LPattern := '*.LNK';
  LOption  := TSearchOption.soTopDirectoryOnly;

  //ディレクトリ内のファイルのリストを取得
  LFileNames := TDirectory.GetFiles(ASearchFolder, LPattern, LOption);
  for LFileName in LFileNames do begin
    if UpperCase(AFindPath) = UpperCase(GetLinkPathName(LFileName)) then begin
      Result := LFileName;
      break;
    end;
  end;
end;

//-----------------------------------------------------------------------------
//  ショートカット(拡張子は.lnk)のリンク先のフルパスを取得
//  リンク先のファイル・フォルダの存在確認はしない
//
//  CreateComObjectの使用にはusesにComObjが必要
//  IShellLinkの使用にはusesにShObjが必要
//  IPersistFileの使用にはusesにActiveXが必要
//-----------------------------------------------------------------------------
function GetLinkPathName(ALinkFilePath: string): string;
var
  LIShellLink   : IShellLink;
  LIPersistFile : IPersistFile;
  LFileData     : TWin32FindData;
  LFilePath     : array [0..MAX_PATH - 1] of Char;
begin
  Result := '';

  //IShellLink,IPersistFileインターフェイスのオブジェクトを生成
  LIShellLink   := CreateComObject(CLSID_ShellLink) as IShellLink;
  LIPersistFile := LIShellLink as IPersistFile;

  if Succeeded(LIPersistFile.Load(PChar(ALinkFilePath), STGM_READ)) then begin
    //初期化
    FillChar(LFilePath, SizeOf(LFilePath), #0);
    //ショートカットファイルのリンク先を取得
    LIShellLink.GetPath(@LFilePath, MAX_PATH, LFileData, SLGP_UNCPRIORITY);
    //関数の戻り値にセット
    Result := LFilePath;
  end;
end;

//-----------------------------------------------------------------------------
//  ショートカットファイル(拡張子は.lnk)のアイコンを変更
//  ファイルの存在確認はしてない
//
//  ALinkFilePath : ショットカットファイルのパス名
//  AIconFilePath : アイコンファイルのパス名
//                  またはアイコンが格納されているEXEやDLLのパス名
//  AIconIndex    : アイコンのインデックス
//                  複数のアイコンが格納されているEXEやDLLの場合に指定する
//
//  CreateComObjectの使用にはusesにComObjが必要
//  IShellLinkの使用にはusesにShObjが必要
//  IPersistFileの使用にはusesにActiveXが必要
//-----------------------------------------------------------------------------
function ChangeShortCutIcon(ALinkFilePath, AIconFilePath: string;
  AIconIndex: Integer): Boolean;
var
  LIShellLink   : IShellLink;
  LIPersistFile : IPersistFile;
begin
  Result := False;

  //IShellLink,IPersistFileインターフェイスのオブジェクトを生成
  LIShellLink   := CreateComObject(CLSID_ShellLink) as IShellLink;
  LIPersistFile := LIShellLink as IPersistFile;

  if Succeeded(LIPersistFile.Load(PChar(ALinkFilePath), STGM_READ)) then begin
    //アイコンを設定
    LIShellLink.SetIconLocation(PChar(AIconFilePath), AIconIndex);
    //IPersistFile.Saveメソッドを実行すると結果が反映される
    if LIPersistFile.Save(Pchar(ALinkFilePath), False) = S_OK then begin
      Result := True;
    end;
  end;
end;

//-----------------------------------------------------------------------------
//  ショートカットファイル(拡張子は.lnk)のアイコンのパス名を取得
//  ファイルの存在確認はしてない
//
//  ALinkFilePath      : ショットカットファイルのパス名
//  var AIconFilePath : アイコンファイルのパス名を返す
//                      またはアイコンが格納されているEXEやDLLのパス名を返す
//  var AIconIndex    : EXEまたはDLL内のアイコンのインデックス番号を返す
//
//  CreateComObjectの使用にはusesにComObjが必要
//  IShellLinkの使用にはusesにShObjが必要
//  IPersistFileの使用にはusesにActiveXが必要
//-----------------------------------------------------------------------------
function GetShortCutIconPath(ALinkFilePath: string; var AIconFilePath: string;
  var AIconIndex: Integer): Boolean;
var
  LIShellLink   : IShellLink;
  LIPersistFile : IPersistFile;
  LpIconPath    : array [0..MAX_PATH - 1] of Char;
begin
  Result := False;

  //IShellLink,IPersistFileインターフェイスのオブジェクトを生成
  LIShellLink   := CreateComObject(CLSID_ShellLink) as IShellLink;
  LIPersistFile := LIShellLink as IPersistFile;

  if Succeeded(LIPersistFile.Load(PChar(ALinkFilePath), STGM_READ)) then begin
    //アイコンのパス名とインデックスを取得
    FillChar(LpIconPath, MAX_PATH, #0);
    if LIShellLink.GetIconLocation(LpIconPath, MAX_PATH, AIconIndex) = S_OK then begin
      AIconFilePath := LpIconPath;
      Result := True;
    end;
  end;
end;

end.

//=============================================================================
//  指定ディレクトリにショートカットを作成
//  ここではスタートアップに本プログラムのショートカットを作成
//
//  添付のplShortcutUtilsユニット内の関数類を使用
//  CSIDL_STARTUP等の定数名の使用にはusesにShlObjが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LDir : string;
begin
  //CSIDLの値からフルパスを取得
  //ショートカットを作成する場所
  LDir := GetDirectoryFromCSIDL(CSIDL_STARTUP);

  //ショートカットを作成
  CreateShortCutLink(Application.ExeName, LDir, 'テストリンク');
end;

//=============================================================================
//  指定ディレクトリ内のショートカットを削除
//  ここではスタートアップの，このプログラムのショートカットを削除
//
//  添付のplShortcutUtilsユニット内の関数類を使用
//  CSIDL_STARTUP等の定数名の使用にはusesにShlObjが必要
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  LDir : string;
begin
  //CSIDLの値からフルパスを取得
  //削除するショートカットがある場所
  LDir := GetDirectoryFromCSIDL(CSIDL_STARTUP);

  //ショートカットを削除
  DeleteShorCutLink(Application.ExeName, LDir);
end;

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    SpeedButton1: TSpeedButton;
    SpeedButton2: TSpeedButton;
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    Button1: TButton;
    OpenDialog1: TOpenDialog;
    OpenDialog2: TOpenDialog;
    SpinEdit1: TSpinEdit;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  plShortcutUtils,
  ShlObj;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//
//  添付のplShortcutUtilsユニット内の関数類を使用
//  CSIDL_DESKTOP等の定数名の使用にはusesにShlObjが必要
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  LDir : string;
begin
  LabeledEdit1.AutoSelect := False;
  LabeledEdit2.AutoSelect := False;
  ActiveControl := LabeledEdit1;

  //CSIDLの値からデスクトップのフルパスを取得
  //ショートカットがある場所
  LDir := GetDirectoryFromCSIDL(CSIDL_DESKTOP);

  LabeledEdit1.Text := '';
  LabeledEdit2.Text := '';
  SpinEdit1.Value := 0;

  //.lnkファイルの場合,リンク先でなく.lnkファイルそのものを取得するようにする
  //TOpenDialogは.lnkの場合，デフォルトではリンク先のファイル名を取得する
  OpenDialog1.Options    := OpenDialog1.Options + [ofNoDereferenceLinks];
  OpenDialog1.InitialDir := LDir;
  OpenDialog2.InitialDir := ExpandFileName('..\');
end;

//=============================================================================
//  アイコンを変更するショートカット(.lnk)ファイルを選択
//=============================================================================
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
  OpenDialog1.Filter := 'ショーカット (*.lnk)|*.lnk';
  if OpenDialog1.Execute then begin
    LabeledEdit1.Text := OpenDialog1.FileName;
    OpenDialog1.InitialDir := ExtractFileDir(OpenDialog1.FileName);
  end;
end;

//=============================================================================
//  新しく設定するアイコンのファイルを選択
//=============================================================================
procedure TForm1.SpeedButton2Click(Sender: TObject);
begin
  OpenDialog2.Filter := 'アイコンファイル (*.ico)|*.ico|'
                      + 'DLL ファイル (*.dll)|*.dll|'
                      + '実行ファイル (*.exe)|*.exe|'
                      + 'CPL ファイル (*.cpl)|*.cpl';
  if OpenDialog2.Execute then begin
    LabeledEdit2.Text := OpenDialog2.FileName;
    OpenDialog2.InitialDir := ExtractFileDir(OpenDialog2.FileName);
  end;
end;

//=============================================================================
//  ショートカットのアイコンを変更
//
//  添付のplShortcutUtilsユニット内の関数を使用
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  if LabeledEdit1.Text = '' then exit;

  //アイコンを変更
  ChangeShortCutIcon(LabeledEdit1.Text, LabeledEdit2.Text, SpinEdit1.Value);
end;

//=============================================================================
//  ショートカットのアイコンを元に戻す
//
//  添付のplShortcutUtilsユニット内の関数を使用
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  LIconPath  : string;
  LIconIndex : Integer;
begin
  if LabeledEdit1.Text = '' then exit;
  LIconPath := LabeledEdit2.Text;

  GetShortCutIconPath(LabeledEdit1.Text, LIconPath, LIconIndex);
  if LIconPath = '' then begin
    MessageBox(Handle, 'アイコンは変更されていません', '情報', MB_OK);
  end else begin
    //アイコンをリンク元のEXEのアプリケーションアイコンにする
    ChangeShortCutIcon(LabeledEdit1.Text, '', SpinEdit1.Value);
  end;
end;

end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    SpeedButton1: TSpeedButton;
    LabeledEdit1: TLabeledEdit;
    Button1: TButton;
    OpenDialog1: TOpenDialog;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
    FFilePath  : string;
    FIconIndex : Integer;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  plShortcutUtils,
  ShlObj,
  ShellAPI;

{$R *.dfm}

  //---------------------------------------------------------------------------
  //  shell32.dllの序数62の名前なし関数を使用するための関数の定義
  //  この関数は非公開API関数
  //
  //  usesにShellAPIが必要．
  //---------------------------------------------------------------------------
  function SH_PickIconDlg(
      Handle       : THandle;
      lpFileName   : PChar;
      var FileSize : DWORD;
      var Index    : Integer):Integer; stdcall; external 'shell32.dll' index 62;


//=============================================================================
//  フォーム生成時の処理
//
//  添付のplShortcutUtilsユニット内の関数類を使用
//  CSIDL_DESKTOP等の定数名の使用にはusesにShlObjが必要
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  LDir : string;
begin
  LabeledEdit1.AutoSelect := False;
  ActiveControl := LabeledEdit1;

  //CSIDLの値からデスクトップのフルパスを取得
  //対象のショートカットがある場所
  LDir := GetDirectoryFromCSIDL(CSIDL_DESKTOP);

  LabeledEdit1.Text := '';
  FFilePath := 'c:\Windows\system32\imageres.dll';

  //.lnkファイルの場合,リンク先でなく.lnkファイルそのものを取得するようにする
  //TOpenDialogは.lnkの場合，デフォルトではリンク先のファイル名を取得する
  OpenDialog1.Options    := OpenDialog1.Options + [ofNoDereferenceLinks];
  OpenDialog1.InitialDir := LDir;
end;

//=============================================================================
//  アイコンを変更するショートカット(.lnk)ファイルを選択
//=============================================================================
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
  OpenDialog1.Filter := 'ショーカット (*.lnk)|*.lnk';
  if OpenDialog1.Execute then begin
    LabeledEdit1.Text := OpenDialog1.FileName;
    OpenDialog1.InitialDir := ExtractFileDir(OpenDialog1.FileName);
  end;
end;

//=============================================================================
//  ショートカットのアイコンを変更
//  [アイコンの変更]ダイアログを表示してアイコンを選択
//
//  添付のplShortcutUtilsユニット内の関数を使用
//  ExtractIconの使用にはusesにShellAPIが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LpFilePath : PChar;
  LFileSize  : Cardinal;
  LhIcon     : HICON;
begin
  LFileSize  := MAX_PATH;
  LpFilePath := StrAlloc(LFileSize + 1);
  StrPCopy(LpFilePath, FFilePath);

  try
    //[アイコンの変更]ダイアログを表示
    if SH_PickIconDlg(Handle, LpFilePath, LFileSize, FIconIndex) = 1 then begin
      //アイコンを取出す
      LhIcon := ExtractIcon(hInstance, LpFilePath, FIconIndex);
      //アイコンを変更
      FFilePath := LpFilePath;
      ChangeShortCutIcon(LabeledEdit1.Text, FFilePath, FIconIndex);
      //アイコンハンドルを解放
      DestroyIcon(LhIcon);
    end;
  finally
    StrDispose(LpFilePath);
  end;
end;

//=============================================================================
//  ショートカットのアイコンを元に戻す
//  変更されていなければ何もしない
//
//  添付のplShortcutUtilsユニット内の関数を使用
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  if LabeledEdit1.Text = '' then exit;
  //アイコンを元に戻す
  ChangeShortCutIcon(LabeledEdit1.Text, '', 0);　
end;

end.