instfnc2.pas

源代码

unit InstFnc2;

{
  Inno Setup
  Copyright (C) 1997-2004 Jordan Russell
  Portions by Martijn Laan
  For conditions of distribution and use, see LICENSE.TXT.

  OLE-related installation functions

  $jrsoftware: issrc/Projects/InstFnc2.pas,v 1.18 2004/09/01 21:42:12 jr Exp $
}

interface

{$I VERSION.INC}

function CreateShellLink(const Filename, Description, ShortcutTo, Parameters,
  WorkingDir, IconFilename: String; const IconIndex, ShowCmd: Integer;
  const HotKey: Word; FolderShortcut: Boolean): String;
procedure RegisterTypeLibrary(const Filename: String);
function UnregisterTypeLibrary(const Filename: String): Boolean;

implementation

uses
  Windows, SysUtils, PathFunc, CmnFunc2, Main, Msgs, MsgIDs,
  {$IFNDEF Delphi3orHigher} OLE2, {$ELSE} ActiveX, ComObj, {$ENDIF}
  ShellAPI, ShlObj;

procedure RaiseOleError(const FunctionName: String; const ResultCode: HRESULT);
begin
  raise Exception.Create(FmtSetupMessage(msgErrorFunctionFailedWithMessage,
    [FunctionName, IntToHexStr8(ResultCode), Win32ErrorString(ResultCode)]));
end;

function IsWindowsXP: Boolean;
{ Returns True if running Windows XP or later }
begin
  Result := (WindowsVersion >= $05010000);
end;

function GetResultingFilename(const PF: IPersistFile;
  const OriginalFilename: String): String;
{ Determines the actual resulting filename. IPersistFile::Save doesn't always
  save to the specified filename; it may rename the extension to .pif if the
  shortcut points to an MS-DOS application. }
var
  CurFilename: PWideChar;
  OleResult: HRESULT;
begin
  Result := '';
  CurFilename := nil;
  OleResult := PF.GetCurFile(CurFilename);
  { Note: Prior to Windows 2000/Me, GetCurFile succeeds but returns a NULL
    pointer }
  if SUCCEEDED(OleResult) and Assigned(CurFilename) then begin
    if OleResult = S_OK then
      Result := WideCharToString(CurFilename);
    CoTaskMemFree(CurFilename);
  end;
  { If GetCurFile didn't work (e.g. not running Windows 2000/Me or later), we
    have no choice but to try to guess the filename }
  if Result = '' then begin
    if NewFileExists(OriginalFilename) then
      Result := OriginalFilename
    else if NewFileExists(PathChangeExt(OriginalFilename, '.pif')) then
      Result := PathChangeExt(OriginalFilename, '.pif')
    else begin
      { Neither exist? Shouldn't happen, but return something anyway }
      Result := OriginalFilename;
    end;
  end;
end;

function CreateShellLink(const Filename, Description, ShortcutTo, Parameters,
  WorkingDir, IconFilename: String; const IconIndex, ShowCmd: Integer;
  const HotKey: Word; FolderShortcut: Boolean): String;
{ Creates a lnk file named Filename, with a description of Description, with a
  HotKey hotkey, which points to ShortcutTo.
  NOTE! If you want to copy this procedure for use in your own application
  be sure to call CoInitialize at application startup and CoUninitialize at
  application shutdown. See the bottom of this unit for an example. But this
  is not necessary if you are using Delphi 3 and your project already 'uses'
  the ComObj RTL unit. }
const
  CLSID_FolderShortcut: TGUID = (
    D1:$0AFACED1; D2:$E828; D3:$11D1; D4:($91,$87,$B5,$32,$F1,$E9,$57,$5D));
{$IFNDEF Delphi3OrHigher}
var
  OleResult: HRESULT;
  SL: IShellLink;
  PF: IPersistFile;
  WideFilename: PWideChar;
begin
  if FolderShortcut then
    OleResult := CoCreateInstance(CLSID_FolderShortcut, nil, CLSCTX_INPROC_SERVER,
      IID_IShellLink, SL)
  else
    OleResult := E_FAIL;
  { If a folder shortcut wasn't requested, or if CoCreateInstance failed
    because the user isn't running Windows 2000/Me or later, create a normal
    shell link instead }
  if OleResult <> S_OK then begin
    FolderShortcut := False;
    OleResult := CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER,
       IID_IShellLink, SL);
    if OleResult <> S_OK then
      RaiseOleError('CoCreateInstance', OleResult);
  end;
  PF := nil;
  WideFilename := nil;
  try
    SL.SetPath(PChar(ShortcutTo));
    SL.SetArguments(PChar(Parameters));
    if WorkingDir <> '' then
      SL.SetWorkingDirectory(PChar(WorkingDir));
    if IconFilename <> '' then
      SL.SetIconLocation(PChar(IconFilename), IconIndex);
    SL.SetShowCmd(ShowCmd);
    if Description <> '' then
      SL.SetDescription(PChar(Description));
    if HotKey <> 0 then
      SL.SetHotKey(HotKey);

    OleResult := SL.QueryInterface(IID_IPersistFile, PF);
    if OleResult <> S_OK then
      RaiseOleError('IShellLink::QueryInterface', OleResult);
    { When creating a folder shortcut on 2000/Me, IPersistFile::Save will strip
      off everything past the last '.' in the filename, so we keep the .lnk
      extension on to give it something harmless to strip off. XP doesn't do
      that, so we must remove the .lnk extension ourself. }
    if FolderShortcut and IsWindowsXP then
      WideFilename := StringToOleStr(PathChangeExt(Filename, ''))
    else
      WideFilename := StringToOleStr(Filename);
    OleResult := PF.Save(WideFilename, True);
    if OleResult <> S_OK then
      RaiseOleError('IPersistFile::Save', OleResult);

    Result := GetResultingFilename(PF, Filename);
  finally
    if Assigned(WideFilename) then
      SysFreeString(WideFilename);
    if Assigned(PF) then
      PF.Release;
    SL.Release;
  end;
{$ELSE}
var
  OleResult: HRESULT;
  Obj: IUnknown;
  SL: IShellLink;
  PF: IPersistFile;
  WideFilename: WideString;
begin
  if FolderShortcut then begin
    try
      Obj := CreateComObject(CLSID_FolderShortcut);
    except
      { Folder shortcuts aren't supported prior to Windows 2000/Me. Fall back
        to creating a normal shell link. }
      Obj := nil;
    end;
  end;
  if Obj = nil then begin
    FolderShortcut := False;
    Obj := CreateComObject(CLSID_ShellLink);
  end;
  SL := Obj as IShellLink;
  SL.SetPath(PChar(ShortcutTo));
  SL.SetArguments(PChar(Parameters));
  if WorkingDir <> '' then
    SL.SetWorkingDirectory(PChar(WorkingDir));
  if IconFilename <> '' then
    SL.SetIconLocation(PChar(IconFilename), IconIndex);
  SL.SetShowCmd(ShowCmd);
  if Description <> '' then
    SL.SetDescription(PChar(Description));
  if HotKey <> 0 then
    SL.SetHotKey(HotKey);

  PF := SL as IPersistFile;
  { When creating a folder shortcut on 2000/Me, IPersistFile::Save will strip
    off everything past the last '.' in the filename, so we keep the .lnk
    extension on to give it something harmless to strip off. XP doesn't do
    that, so we must remove the .lnk extension ourself. }
  if FolderShortcut and IsWindowsXP then
    WideFilename := PathChangeExt(Filename, '')
  else
    WideFilename := Filename;
  OleResult := PF.Save(PWideChar(WideFilename), True);
  if OleResult <> S_OK then
    RaiseOleError('IPersistFile::Save', OleResult);

  Result := GetResultingFilename(PF, Filename);
  { Delphi 3 automatically releases COM objects when they go out of scope }
{$ENDIF}
end;

procedure RegisterTypeLibrary(const Filename: String);
{$IFNDEF Delphi3OrHigher}
var
  WideFilename: PWideChar;
  OleResult: HRESULT;
  TypeLib: ITypeLib;
  DocName: PWideChar;
  DocNameStr: String;
begin
  WideFilename := StringToOleStr(PathExpand(Filename));
  TypeLib := nil;
  DocName := nil;
  try
    OleResult := LoadTypeLib(WideFilename, TypeLib);
    if FAILED(OleResult) then
      RaiseOleError('LoadTypeLib', OleResult);
    OleResult := TypeLib.GetDocumentation(-1, nil, nil, nil, @DocName);
    if FAILED(OleResult) then
      RaiseOleError('ITypeLib::GetDocumentation', OleResult);
    if Assigned(DocName) then begin
      DocNameStr := PathExtractPath(OleStrToString(DocName));
      SysFreeString(DocName);
      DocName := nil;
      DocName := StringToOleStr(DocNameStr);
    end;
    OleResult := RegisterTypeLib(TypeLib, WideFilename, DocName);
    if FAILED(OleResult) then
      RaiseOleError('RegisterTypeLib', OleResult);
  finally
    if Assigned(DocName) then
      SysFreeString(DocName);
    if Assigned(TypeLib) then
      TypeLib.Release;
    SysFreeString(WideFilename);
  end;
end;
{$ELSE}
var
  WideFilename: WideString;
  OleResult: HRESULT;
  TypeLib: ITypeLib;
  DocName: WideString;
begin
  WideFilename := PathExpand(Filename);
  OleResult := LoadTypeLib(PWideChar(WideFilename), TypeLib);
  if FAILED(OleResult) then
    RaiseOleError('LoadTypeLib', OleResult);
  OleResult := TypeLib.GetDocumentation(-1, nil, nil, nil, @DocName);
  if FAILED(OleResult) then
    RaiseOleError('ITypeLib::GetDocumentation', OleResult);
  if DocName <> '' then
    DocName := PathExtractPath(DocName);
  OleResult := RegisterTypeLib(TypeLib, PWideChar(WideFilename), Pointer(DocName));
  { ^ use Pointer cast instead of PWideChar so that it passes 'nil' if DocName is empty }
  if FAILED(OleResult) then
    RaiseOleError('RegisterTypeLib', OleResult);
end;
{$ENDIF}

function UnregisterTypeLibrary(const Filename: String): Boolean;
type
  TUnRegTlbProc = function(const libID: TGUID; wVerMajor, wVerMinor: Word;
    lcid: TLCID; syskind: TSysKind): HResult; stdcall;
{$IFNDEF Delphi3OrHigher}
var
  WideFilename: PWideChar;
  TypeLib: ITypeLib;
  OleAutLib: THandle;
  UnRegTlbProc: TUnRegTlbProc;
  LibAttr: PTLibAttr;
begin
  Result := False;
  WideFilename := nil;
  TypeLib := nil;
  LibAttr := nil;
  try
    { Dynamically import UnRegisterTypeLib since older OLEAUT32.DLL versions
      don't have this function }
    OleAutLib := GetModuleHandle('OLEAUT32.DLL');
    if OleAutLib = 0 then
      Exit;
    @UnRegTlbProc := GetProcAddress(OleAutLib, 'UnRegisterTypeLib');;
    if @UnRegTlbProc = nil then
      Exit;
    WideFilename := StringToOleStr(PathExpand(Filename));
    if FAILED(LoadTypeLib(WideFilename, TypeLib)) then
      Exit;
    if FAILED(TypeLib.GetLibAttr(LibAttr)) then
      Exit;
    with LibAttr^ do
      if FAILED(UnRegTlbProc(Guid, wMajorVerNum, wMinorVerNum, LCID, SysKind)) then
        Exit;
  finally
    if Assigned(TypeLib) then begin
      if Assigned(LibAttr) then
        TypeLib.ReleaseTLibAttr(LibAttr);
      TypeLib.Release;
    end;
    if Assigned(WideFilename) then
      SysFreeString(WideFilename);
  end;
  Result := True;
end;
{$ELSE}
var
  WideFilename: WideString;
  TypeLib: ITypeLib;
  OleAutLib: THandle;
  UnRegTlbProc: TUnRegTlbProc;
  LibAttr: PTLibAttr;
begin
  Result := False;
  { Dynamically import UnRegisterTypeLib since older OLEAUT32.DLL versions
    don't have this function }
  OleAutLib := GetModuleHandle('OLEAUT32.DLL');
  if OleAutLib = 0 then
    Exit;
  @UnRegTlbProc := GetProcAddress(OleAutLib, 'UnRegisterTypeLib');;
  if @UnRegTlbProc = nil then
    Exit;
  WideFilename := PathExpand(Filename);
  if FAILED(LoadTypeLib(PWideChar(WideFilename), TypeLib)) then
    Exit;
  if FAILED(TypeLib.GetLibAttr(LibAttr)) then
    Exit;
  try
    with LibAttr^ do
      if FAILED(UnRegTlbProc(Guid, wMajorVerNum, wMinorVerNum, LCID, SysKind)) then
        Exit;
  finally
    TypeLib.ReleaseTLibAttr(LibAttr);
  end;
  Result := True;
end;
{$ENDIF}

procedure InitOle;
var
  OleResult: HRESULT;
begin
  OleResult := CoInitialize(nil);
  if FAILED(OleResult) then
    raise Exception.CreateFmt('CoInitialize failed (0x%.8x)', [OleResult]);
    { ^ doesn't use a SetupMessage since messages probably aren't loaded
      during 'initialization' section below, which calls this procedure }
end;

initialization
  InitOle;
finalization
  CoUninitialize;
end.