ホーム >プログラム >Delphi 6 ローテクTips >Unicode対応のショートカットファイル(.lnk)情報の取得

ショートカットファイルのリンク先ファイルを取得したいと思いました。



uses
  ComObj, ShlObj, ActiveX;
// ShlObj.pas のコードが間違っているので修正。
type
  IShellLinkW = interface(IUnknown)
    [SID_IShellLinkW]
{*} function GetPath(pszFile: PWideChar; cchMaxPath: Integer; var pfd: TWin32FindDataW; fFlags: DWORD): HResult; stdcall;
    function GetIDList(var ppidl: PItemIDList): HResult; stdcall;
    function SetIDList(pidl: PItemIDList): HResult; stdcall;
    function GetDescription(pszName: PWideChar; cchMaxName: Integer): HResult; stdcall;
    function SetDescription(pszName: PWideChar): HResult; stdcall;
    function GetWorkingDirectory(pszDir: PWideChar; cchMaxPath: Integer): HResult; stdcall;
    function SetWorkingDirectory(pszDir: PWideChar): HResult; stdcall;
    function GetArguments(pszArgs: PWideChar; cchMaxPath: Integer): HResult; stdcall;
    function SetArguments(pszArgs: PWideChar): HResult; stdcall;
    function GetHotkey(var pwHotkey: Word): HResult; stdcall;
    function SetHotkey(wHotkey: Word): HResult; stdcall;
    function GetShowCmd(out piShowCmd: Integer): HResult; stdcall;
    function SetShowCmd(iShowCmd: Integer): HResult; stdcall;
    function GetIconLocation(pszIconPath: PWideChar; cchIconPath: Integer; out piIcon: Integer): HResult; stdcall;
    function SetIconLocation(pszIconPath: PWideChar; iIcon: Integer): HResult; stdcall;
    function SetRelativePath(pszPathRel: PWideChar; dwReserved: DWORD): HResult; stdcall;
    function Resolve(Wnd: HWND; fFlags: DWORD): HResult; stdcall;
    function SetPath(pszFile: PWideChar): HResult; stdcall;
  end;

Delphi 6のShlObj.pasのIShellLinkWの宣言は間違っています。
そのままで使用すると無言で落ちます。
なので、上記の宣言をunit内に書いて使います。
こうすることでShlObj.pasの宣言よりもこのunitの宣言の方を優先させることができます。
修正箇所は {*} 印のある一箇所だけでTWin32FindDataをTWin32FindDataWに書き換えます。
ちなみにこの構造体はFindFirstFileやFindNextFile APIで使われるものと同じで、リンク先ファイルの各種情報を得ることができます。

function gfnsFileExtGet(sFile: WideString): WideString;
{
Unicode対応ExtractFileExt。
'.'は返る。
}

var
  i: Integer;
begin
  Result := '';
  for i := Length(sFile) downto 1 do begin
    if (sFile[i] = '\') or (sFile[i] = '/') or (sFile[i] = ':') then begin
      // 拡張子なし。
      Break;
    end else if (sFile[i] = '.') then begin;
      // 拡張子あり。
      Result := Copy(sFile, i, MaxInt);
      Break;
    end;
  end;
end;


function gfnsLinkToFile(sLink: WideString): WideString;
// ショートカットファイルのリンク先ファイル名を返す。
var
  lI_ShellLink:    IShellLinkW;
  lI_PersistFile:  IPersistFile;
  l_Win32FindData: TWin32FindDataW;
  lp_Buff: PWideChar;
begin
  if (WideLowerCase(gfnsFileExtGet(sLink)) = '.lnk') then begin
    // ショートカットファイルだった。
    lI_ShellLink   := (CreateComObject(CLSID_ShellLink) as IShellLinkW);
    lI_PersistFile := (lI_ShellLink as IPersistFile);
    if (Succeeded(lI_PerSistFile.Load(PWideChar(sLink), STGM_READ))) then begin
      lI_ShellLink.Resolve(0, SLR_ANY_MATCH);
      lp_Buff := AllocMem((MAX_PATH + 1) * 2);
      try
        // ショートカットファイルの参照先を取得。
        lI_ShellLink.GetPath(lp_Buff, MAX_PATH, l_Win32FindData, SLGP_UNCPRIORITY);
        Result := WideString(lp_Buff);
      finally
        FreeMem(lp_Buff);
      end;
    end else begin
      // 失敗。
      Result := sLink;
    end;
  end else begin
    Result := sLink;
  end;
end;

2009-02-02:リンク先ファイルを正しく取得できていなかった不具合を修正。
2008-11-23: