(*-----------------------------------
ショートカットファイル処理ユニット

02/02/11    作成
2005/07/27  Arguments系の処理を追加した
2006/10/13(金) 00:44
・getAdvShortcut.pasを加えて
  MSOffice2003のショートカットリンク先等を追随できるようになった
//-----------------------------------*)
unit ShortCutFile;

interface

uses
  Windows, SysUtils, Classes, Registry, ShlObj, ActiveX, DdeMan,
  ComObj,
  
  getAdvShortcut,
  SystemUnit,
  FileList,
  FileUnit,
  FileNameUnit,
  XPtest;

type
  {↓ショートカットファイルで指定する"実行時の大きさ"の値}
  TShowCommand = (scNormalWindow, scMinimize, scMaxmize, scUnknown);

  {↓ショートカットファイルの情報を取得するクラス}
  TShortcutFile = class(TObject)
  private
    ShellLink:IShellLink;
    PersistFile:IPersistFile;
    FilePath:array[0..MAX_PATH] of char;
    WorkDir:array[0..MAX_PATH] of char ;
    wsz:Array[0..MAX_PATH] of WideChar;
    pwHotKey:Word;
    pShowCmd:integer;
    pfd:TWin32FindData;

    FWorkFolder: String; //TFileName;
    FLinkFileName: String; //TFileName;
    FShowCommand: TShowCommand;
    FHotKey: Word;
    FArguments: String;
  protected
  public
    constructor Create(FileName: TFileName);
    destructor Destroy; override;
  published
    property LinkFileName: String read FLinkFileName;
    property WorkFolder: String read FWorkFolder;
    property HotKey: Word read FHotKey;
    property ShowCommand: TShowCommand read FShowCommand;
    property Arguments: String read FArguments;
  end;

procedure testTShortcutFile;

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, ArgsStr: String);
procedure UnSetSendToShortcut(MsgBoxHandle: HWnd; ShortcutFileTitle, 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 2 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;

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 上に同じ
等々です。定数で指定します。
//----------------------------------- }
function SHSystemFolderDir(ShellFolder: Integer): String;
var
  lpszPath: array[0..MAX_PATH] of Char;
begin
  SHGetSpecialFolderPath(HANDLE_FLAG_INHERIT, lpszPath, ShellFolder, False);
  Result := lpszPath;
end;
//IE4をShell統合でインストールしたWin95,NT4かWin98,2000以降が
//必要だということです。

{-------------------------------
//ショートカットファイルが存在するかどうか調べます
機能:       指定されたフォルダ(例えばスタートアップフォルダとか)
            に実行ファイルのショートカットファイルがあるかどうかを
            調べます。
引数説明:   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;
//------------------------------


//(*-----------------------------------
//テストコード
//※%User%にはログイン名を記述すること
//※TClockがインストールしてスタートアップに入っている状態で
//  テストすることにする
procedure testTShortcutFile;
var
  ShortcutFile: TShortcutFile;
  Value: String;
begin
  ForceDirectories('C:\Temp');
  CreateShortcutFile(ParamStr(0), 'C:\Temp\TestApplitation.lnk', '', 'C:\Temp');

  ShortcutFile := TShortcutFile.Create(
    'C:\Temp\TestApplitation.lnk');

  Check(ParamStr(0), GetLongFileName(ShortcutFile.LinkFileName));
  Check('C:\Temp', ShortcutFile.WorkFolder);
  ApiMsgBox(0, ShortcutFile.LinkFileName, '', MB_OK);
  ApiMsgBox(0, ShortcutFile.WorkFolder, '', MB_OK);

  ShortcutFile.Free;

  Value := ShortCutFileExists(
    'C:\Temp', ParamStr(0));

  Check('C:\Temp\TestApplitation.lnk', Value);
  ApiMsgBox(0, Value, '', MB_OK);

  DeleteFile('C:\Temp\TestApplitation.lnk');

  Value := ShortCutFileExists(
    'C:\Temp', ParamStr(0));

  Check('', Value);
  ApiMsgBox(0, Value, '', MB_OK);
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のないアプリでも正しく動作する
--------------------------------}
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';
    {↑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(PChar(strMacro),False);
   //↓ファイルの作成を確認して移動
   ExitSourceFileName := SHSystemFolderDir(CSIDL_COMMON_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フォルダから削除
備考:       Short
履歴:       2004/10/10
            2005/05/17 SendToフォルダのサブフォルダにも対応した
//------------------------------}
procedure SetSendToShortcut(MsgBoxHandle: HWnd; ShortcutFileTitle, ArgsStr: String);
var
  ShortcutFilePath: String;
begin
  ShortcutFilePath :=
    ShortCutFileExists(SHSystemFolderDir(CSIDL_SENDTO), 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';

      {↓ショートカット作成用フォルダを作成する}
      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, ArgsStr: String);
var
  ShortcutFilePath: String;
begin
  ShortcutFilePath :=
    ShortCutFileExists(SHSystemFolderDir(CSIDL_SENDTO), 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.