(*--▽---------------------------▼-- ショートカットファイル処理ユニット 02/02/11 作成 2005/07/27 Arguments系の処理を追加した 2006/10/13(金) 00:44 ・getAdvShortcut.pasを加えて MSOffice2003のショートカットリンク先等を追随できるようになった 2011/12/06(火) ・TShortcutFileがUnicodeString対応で誤動作していたので Createを書き直して対応できるようにした //--▲---------------------------△--*) unit ShortcutFile; interface uses Windows, SysUtils, Classes, Registry, ShlObj, ActiveX, DdeMan, ComObj, // getAdvShortcut, SystemUnit, FileList, FileUnit, FileNameUnit, StringUnit, SpecialFolderPathUnit, XPtest, uses_end; type {↓ショートカットファイルで指定する"実行時の大きさ"の値} TShowCommand = (scNormalWindow, scMinimize, scMaxmize, scUnknown); {↓ショートカットファイルの情報を取得するクラス} TShortcutFile = class(TObject) private ShellLink: IShellLink; PersistFile: IPersistFile; FShowCmd: Integer; Win32FindData:TWin32FindData; FWorkDir: String; //TFileName; FLinkFileName: String; //TFileName; FShowCommand: TShowCommand; FHotKey: Word; FArguments: String; protected public constructor Create(FileName: String); destructor Destroy; override; published property LinkFileName: String read FLinkFileName; property WorkDir: String read FWorkDir; property HotKey: Word read FHotKey; property ShowCommand: TShowCommand read FShowCommand; property Arguments: String read FArguments; end; function SystemFolderDir(ShellFolder: string): string; //function SHSystemFolderDir(ShellFolder: Integer): String; function ShortCutFileExists(FolderName, ExeFileName: String; SubFolder: Boolean = False; ArgumentsStr: String = ''): String; function CreateShortcutFile(SourceName, ShortcutLinkFileName: String; Args: String=''; WorkDir: String=''; Description: String=''; IconPath: String=''; IconIndex: Integer=0; ShowWnd: Integer=SW_SHOWNORMAL): Boolean; function CreateShortcutFileDDE(SourceName, ShortcutLinkFileName: String): Boolean; procedure SetSendToShortcut(MsgBoxHandle: HWnd; ShortcutFileTitle: String; ArgsStr: String = ''); procedure UnSetSendToShortcut(MsgBoxHandle: HWnd; ShortcutFileTitle: String; ArgsStr: String = ''); implementation { TShortcutFile } {------------------------------- //ショートカットファイルクラス 機能: ShortcutFileの情報を取得します 引数説明: FileName:ShortcutFileを指定して生成します プロパティ: LinkFileName:リンク先ファイル名 WorkFolder:作業ディレクトリ名 HotKey:ショートカットキー APIの値そのまま ShowCommand:実行時の大きさ TShowCommand型 備考: Formの無いプログラムでは動作しません 履歴: 2002/02/11 2005/07/27 Argumentsも追加した //--▼----------------------▽--} (*---------------------------------------- constructor TShortcutFile.Create(FileName: TFileName); var Buffer: string; begin if not FileExists(ChangeFileExt(FileName,'.lnk')) then raise Exception.Create('ファイルが存在しません'); inherited Create; if InitProc <> nil then TProcedure(InitProc); ShellLink := CreateComObject(CLSID_ShellLink) As IShellLink; try OleCheck(ShellLink.QueryInterface(IPersistFile,PersistFile)); Assert(Assigned(PersistFile)); MultiByteToWideChar(CP_ACP,0,PChar(FileName),-1,wsz,MAX_PATH); OleCheck(PersistFile.Load(wsz,0)); case 1 of 1: begin OleCheck(ShellLink.GetPath(FilePath,MAX_PATH,pfd,SLGP_SHORTPATH)); FLinkFileName := FilePath; OleCheck(ShellLink.GetWorkingDirectory(WorkDir,MAX_PATH)); FWorkFolder := WorkDir; SetLength(Buffer, MAX_PATH); OleCheck(ShellLink.GetArguments(PChar(Buffer), MAX_PATH)); FArguments := PChar(Buffer); end; 2: begin // getExecData(FileName, FLinkFileName, FWorkFolder, FArguments); end; end; OleCheck(ShellLink.GetShowCmd(pShowCmd)); case pShowCmd of 1: FShowCommand := scNormalWindow; 7: FShowCommand := scMinimize; 3: FShowCommand := scMaxmize; else FShowCommand := scUnknown; end; //ショートカットファイルの実行時の大きさを読みとる // 1なら『通常のウィンドウ』 // 7なら『最小化』 // 3なら『最大化』 //他は無いです。 OleCheck(ShellLink.GetHotKey(pwHotkey)); FHotKey := pwHotKey; except on EOleSysError do raise Exception.Create('OLEエラーが発生しました'); end; end; //----------------------------------------*) type TLinkFileInfo =packed record Filename : string; //リンクしているファイル名 WorkDir : string; //作業ディレクトリ Arguments : string; //コマンドライン引数 Hotkey : Word; //設定されているホットキー ShowCmd : Integer; //実行時の表示状態 end; function GetInfofromLinkFile(LinkFilename: string):TLinkFileInfo; var ShellLink :IShellLink; PersistFile :IPersistFile; WFilename :Widestring; Win32FindData :TWin32FindData; S, Work, Arg :string; Hot :Word; Cmd :Integer; begin if LowerCase(ExtractFileExt(LinkFilename)) <>'.lnk' then Exit; ShellLink :=CreateComObject(CLSID_ShellLink) as IShellLink; PersistFile :=ShellLink as IPersistFile; //Unicodeにキャスト WFilename :=LinkFilename; if Succeeded(PerSistFile.Load(PWChar(WFilename), STGM_READ)) then begin ShellLink.Resolve(0, SLR_ANY_MATCH); SetLength(S, MAX_PATH); SetLength(Work, MAX_PATH); SetLength(Arg, MAX_PATH); //ショートカットファイルの参照先を取得 ShellLink.GetPath(PChar(S), MAX_PATH, Win32FindData, SLGP_UNCPRIORITy); //作業ディレクトリを取得 ShellLInk.GetWorkingDirectory(PChar(Work), MAX_PATH); //コマンドライン引数を取得 ShellLink.GetArguments(PChar(Arg), MAX_PATH); //ホットキーを取得 ShellLink.GetHotkey(Hot); //実行時の表示状態を取得 ShellLink.GetShowCmd(Cmd); //関数の戻り値にセット with Result do begin Filename :=S; WorkDir :=Work; Arguments :=Arg; Hotkey :=Hot; ShowCmd :=Cmd; end; end; end; constructor TShortcutFile.Create(FileName: String); var // Buffer: string; // S, Work, Arg :string; // Hot :Word; Cmd :Integer; begin if LowerCase(ExtractFileExt(FileName)) <>'.lnk' then begin raise Exception.Create('ファイルが存在しません'); end; inherited Create; if InitProc <> nil then TProcedure(InitProc); ShellLink := CreateComObject(CLSID_ShellLink) As IShellLink; PersistFile := ShellLink as IPersistFile; if Succeeded(PersistFile.Load(PChar(FileName), STGM_READ)) then begin ShellLink.Resolve(0, SLR_ANY_MATCH); SetLength(FLinkFileName, MAX_PATH); SetLength(FWorkDir, MAX_PATH); SetLength(FArguments, MAX_PATH); //ショートカットファイルの参照先を取得 ShellLink.GetPath(PChar(FLinkFileName), MAX_PATH, Win32FindData, SLGP_UNCPRIORITy); //作業ディレクトリを取得 ShellLInk.GetWorkingDirectory(PChar(FWorkDir), MAX_PATH); //コマンドライン引数を取得 ShellLink.GetArguments(PChar(FArguments), MAX_PATH); //ホットキーを取得 ShellLink.GetHotkey(FHotKey); //実行時の表示状態を取得 ShellLink.GetShowCmd(Cmd); FLinkFileName := string(PChar(FLinkFileName)); FWorkDir := string(PChar(FWorkDir)); FArguments := string(PChar(FArguments)); // FWorkFolder := WorkDir; // FArguments := Arg; // FHotKey := Hot; case Cmd of 1: FShowCommand := scNormalWindow; 7: FShowCommand := scMinimize; 3: FShowCommand := scMaxmize; else FShowCommand := scUnknown; end; end; end; destructor TShortcutFile.Destroy; begin inherited; end; //--△----------------------▲-- //------------------------------- //システムディレクトリのパスを返す関数：レジストリ版 {最後に\はつきません} { uses Registryが必要 ShellFolder引数に指定できる文字列はレジストリにかかれてある通りで > SendTo　　Start Menu　　Startup　　Recent　　Favorites　　Desktop　 等々です。文字列で指定してください。 } function SystemFolderDir(ShellFolder: string): string; var Regini: TRegIniFile; begin Regini := TRegIniFile.Create( 'Software\MicroSoft\Windows\CurrentVersion\Explorer'); Result := Regini.ReadString('Shell Folders',ShellFolder,''); Regini.Free; end; //------------------------------- //システムディレクトリのパスを返す関数：シェルAPI版 {最後に\はつきません} { ----------------------------------- uses ShlObjが必要 ShellFolder引数に指定できる数値は CSIDL_PROGRAMS Program Files CSIDL_PERSONAL マイドキュメント CSIDL_FAVORITES お気に入り CSIDL_STARTUP スタートアップ CSIDL_RECENT 最近使ったファイル CSIDL_SENDTO 送る CSIDL_BITBUCKET ごみ箱 CSIDL_STARTMENU スタートメニュー CSIDL_DESKTOPDIRECTORY デスクトップ CSIDL_DESKTOP 上に同じ 等々です。定数で指定します。 IE4をShell統合でインストールしたWin95,NT4かWin98,2000以降が 必要だということです。 2012/07/14(土) ・SpecialFolderPathUnitの関数を使うようにする。 //----------------------------------- } //function SHSystemFolderDir(ShellFolder: Integer): String; //var // lpszPath: array[0..MAX_PATH] of Char; //begin // SHGetSpecialFolderPath(HANDLE_FLAG_INHERIT, lpszPath, ShellFolder, False); // Result := lpszPath; //end; {------------------------------- //ショートカットファイルが存在するかどうか調べます 機能: 指定されたフォルダ(例えばスタートアップフォルダとか) に実行ファイルのショートカットファイルがあるかどうかを調べます。 引数説明: FolderName:検索するフォルダ(終端\は有り無しどちらもOK) ExeFileName:この実行ファイルのショートカットファイルを検索する 戻り値: ショートカットファイルのフルパス名が入る ヌル文字が戻るならファイルは存在しない 備考: 履歴: 2002/02/11 2005/05/17 SubFolder検索オプションを追加 2005/07/27 ArgumentsStrオプションを追加 //--▼----------------------▽--} function ShortCutFileExists(FolderName, ExeFileName: String; SubFolder: Boolean = False; ArgumentsStr: String = ''): String; var FileList1: TFileList; FileNameStrList: TStringList; ShortCutFile: TShortcutFile; ResultFileListFlag: Boolean; i: Integer; begin Result := ''; FileList1 := TFileList.Create(nil); try FileNameStrList := TStringList.Create; try FileList1.DestStrings := FileNameStrList; FileList1.Directory := FolderName; if SubFolder then begin ResultFileListFlag := FileList1.SubFolderList; end else begin ResultFileListFlag := FileList1.List; end; if ResultFileListFlag then begin for i := 0 to FileNameStrList.Count-1 do begin if SameText(ExtractFileExt(FileNameStrList[i]), '.lnk') then begin ShortCutFile := TShortcutFile.Create(FileNameStrList[i]); try if (CheckSameFileName(ShortCutFile.LinkFileName,ExeFileName)) then begin {↓起動引数チェックがヌル文字なら比較しない} if ArgumentsStr = '' then begin Result := FileNameStrList[i]; Exit; end else {↓起動引数チェックがヌルじゃないなら起動引数を比較する} if (ShortCutFile.Arguments = ArgumentsStr) then begin Result := FileNameStrList[i]; Exit; end; end; finally ShortCutFile.Free; end; end; end; end; finally FileNameStrList.Free; end; finally FileList1.Free; end; Result := ''; end; //--△----------------------▲-- {------------------------------- //ショートカットファイルを作成します 機能: 普通のファイルでもフォルダでもショートカットを作成します 引数説明: SourceName ショートカットにリンクする対象ファイル ShortcutFileName 作成するショートカットファイル フルパスで指定してください 生成されるShortcutFileは自動的に 拡張子.lnkが付加/変更されます。 Args 実行時引数 WorkDir 作業ディレクトリ Description アイコンの説明 Win2000などで有効 IconPath, IconIndex アイコンパスとアイコンIndex ExeやDLL Iconファイルを指定。 ShowWnd SW_SHOWNORMAL/SW_SHOWMINNOACTIVE/SW_MAXIMIZE の3種類が指定可能 戻り値: true:成功 false:失敗 備考: uses FileCtrl, ShlObj, ActiveX, ComObjを追加 SourceNameにショートカットファイル自体を指定すると 作成されるのはそのショートカットファイルのコピーになるので Iconその他すべての引数指定は無効になります。 デフォルト値が指定してある引数は省略可能 履歴: 2000/12/25 2004/10/10 Formのないアプリでも正しく動作する 2012/07/14(土) ・ 終端処理をUnicode化するためにStringUnit.IncludeLastStrを使用 --------------------------------} function CreateShortcutFile(SourceName, ShortcutLinkFileName: String; Args: String=''; WorkDir: String=''; Description: String=''; IconPath: String=''; IconIndex: Integer=0; ShowWnd: Integer=SW_SHOWNORMAL): Boolean; var UnknownObject : IUnknown; ShellLink : IShellLink; PersistFile : IPersistFile; begin Result := False; if not FileFolderExists(SourceName) then Exit; if not (CheckUNCPath(ShortcutLinkFileName) or CheckDrivePath(ShortcutLinkFileName)) then Exit; if InitProc <> nil then TProcedure(InitProc); try UnknownObject := CreateComObject(CLSID_ShellLink); ShellLink := UnknownObject as IShellLink; ShellLink.SetPath(PChar( SourceName )); {↑ターゲットファイル} ShellLink.SetArguments(PChar(Args)); {↑引数指定} ShellLink.SetWorkingDirectory(PChar(WorkDir)); {↑作業フォルダ} ShellLink.SetDescription(PChar(Description)); {↑Win2000用ショートカットの説明} ShellLink.SetIconLocation(PChar(IconPath), IconIndex); {↑アイコンの指定} ShellLink.SetShowCmd(ShowWnd); {↑実行時の大きさ指定} // if not AnsiSameText(ExtractFileExt(ShortcutLinkFileName),'.lnk') then // ShortcutLinkFileName := ShortcutLinkFileName + '.lnk'; ShortcutLinkFileName := IncludeLastStr(ShortcutLinkFileName, '.lnk', ccIgnoreCase); {↑ShortcutFileNameが'.lnk'拡張子ではない場合'.lnkを付属させる'} PersistFile := UnknownObject as IPersistFile; if Assigned(PersistFile) then begin PersistFile.Save(PWChar(WideString( ShortcutLinkFileName)),False); end else raise Exception.Create('シェルのエラー'); Result := true; except Result := false; end; end; {------------------------------- //ショートカットファイルを作成します 機能: 普通のファイルでもフォルダでもショートカットを作成します 引数説明: SourceName ショートカットにリンクする対象ファイル ShortcutFileName 作成するショートカットファイル フルパスで指定してください ShortcutFileは自動的に拡張子.lnkに変更されます。 戻り値: true:成功 false:失敗 備考: uses DdeManを追加 DDE通信が遅いのですぐにショートカットファイルが作成されない 可能性があります。Sleep(1000)などを入力してください。 Formのないプログラムでも動作します。 IDEでのデバッグ実行では動作しない時もあるようです 履歴: 2001/11/23 2004/10/10 Formのないアプリだからか？なんか動作が不安定。 --------------------------------} function CreateShortcutFileDDE(SourceName, ShortcutLinkFileName: String): Boolean; var DDEClientConv1: TDDEClientConv; strMacro, strExeFile, strShortcutName: String; ExitSourceFileName: String; begin Result := False; strExeFile := SourceName; strShortcutName := ChangeFileExt(ExtractFileName(ShortcutLinkFileName), ''); DDEClientConv1 := TDdeClientConv.Create(nil); try if not DDEClientConv1.SetLink('PROGMAN','PROGMAN') then begin raise Exception.Create('DDE通信失敗'); exit; end; //↓DDEによってAllUserプログラムフォルダにショートカットファイル作成 strMacro := '[AddItem("' + strExeFile + '","' + strShortcutName + '")]'; DDEClientConv1.ExecuteMacro(PAnsiChar(strMacro),False); //↓ファイルの作成を確認して移動 // ExitSourceFileName := SHSystemFolderDir(CSIDL_COMMON_PROGRAMS)+'\'+strShortcutName+'.lnk'; ExitSourceFileName := IncludeLastPathDelim(GetSpecialFolderPath(sfAllUserCommon_Programs)) + strShortcutName + '.lnk'; if FileExists(ExitSourceFileName) then MoveFile(PChar(ExitSourceFileName), PChar(ShortcutLinkFileName)); if (Assigned(DDEClientConv1)) then begin DDEClientConv1.CloseLink; end; finally DDEClientConv1.Free; end; Result := True; end; {--------------------------------------- SendToフォルダにアプリのショートカットを配置/削除する処理 機能: SetSendToShortcut: SendToフォルダに登録 UnSetSendToShortcut:SendToフォルダから削除 備考: 履歴: 2004/10/10 2005/05/17 ・ SendToフォルダのサブフォルダにも対応した ShortcutFileTitleに[サブフォルダ名\サブフォルダ名\タイトル] とすると、SendToのサブフォルダでもショートカットを作成することができる }//(*----------------------------------- procedure SetSendToShortcut(MsgBoxHandle: HWnd; ShortcutFileTitle: String; ArgsStr: String = ''); var ShortcutFilePath: String; begin // ShortcutFilePath := // ShortCutFileExists(SHSystemFolderDir(CSIDL_SENDTO), ParamStr(0), True, ArgsStr); ShortcutFilePath := ShortCutFileExists(GetSpecialFolderPath(sfUserSendTo), ParamStr(0), True, ArgsStr); if ShortcutFilePath = '' then begin {↓Sendtoフォルダにショートカットがない場合} if Windows.MessageBox(MsgBoxHandle, PChar( '"送る"フォルダに登録がありません。'+#10+ 'ショートカットを作成しますか？'), PChar(ShortcutFileTitle), MB_YESNO or MB_DEFBUTTON1) = IDYES then begin // ShortcutFilePath := // IncludeTrailingPathDelimiter(SHSystemFolderDir(CSIDL_SENDTO)) + // ShortcutFileTitle + '.lnk'; ShortcutFilePath := IncludeTrailingPathDelimiter(GetSpecialFolderPath(sfUserSendTo)) + ShortcutFileTitle + '.lnk'; {↓ショートカット作成用フォルダを作成する} if not DirectoryExists(ExtractFileDir(ShortcutFilePath)) then begin ForceDirectories(ExtractFileDir(ShortcutFilePath)); end; CreateShortcutFile(ParamStr(0), ShortcutFilePath); if FileExists(ShortcutFilePath) then begin Windows.MessageBox(MsgBoxHandle, PChar( '"送る"フォルダにショートカットを作成しました'), PChar(ShortcutFileTitle), MB_OK or MB_DEFBUTTON1); end else begin Windows.MessageBox(MsgBoxHandle, PChar( 'ショートカット作成に失敗しました'), PChar(ShortcutFileTitle), MB_OK or MB_DEFBUTTON1); end; end; end; end; procedure UnSetSendToShortcut(MsgBoxHandle: HWnd; ShortcutFileTitle: String; ArgsStr: String = ''); var ShortcutFilePath: String; begin // ShortcutFilePath := // ShortCutFileExists(SHSystemFolderDir(CSIDL_SENDTO), ParamStr(0), True, ArgsStr); ShortcutFilePath := ShortCutFileExists(GetSpecialFolderPath(sfUserSendTo), ParamStr(0), True, ArgsStr); if ShortcutFilePath <> '' then begin {↓Sendtoフォルダにショートカットがない場合} if Windows.MessageBox(MsgBoxHandle, PChar( '"送る"フォルダの'+#10+ 'ショートカットを削除しますか？'), PChar(ShortcutFileTitle), MB_YESNO or MB_DEFBUTTON1) = IDYES then begin DeleteFile(ShortcutFilePath); Windows.MessageBox(MsgBoxHandle, PChar( '"送る"フォルダからショートカットを削除しました'), PChar(ShortcutFileTitle), MB_OK or MB_DEFBUTTON1); end; end; end; //------------------------------------*) end.