ucomponentinstaller.pas

装DevExpress控件时很麻烦,总提示某某控件得先装才行。于是做了这个工具。稍改改就可以用于自己的控件安装了。

unit uComponentInstaller;

interface

{$WARN SYMBOL_PLATFORM OFF}
{$WARN UNIT_PLATFORM OFF}
{$BOOLEVAL OFF} // Unit depends on short-circuit boolean evaluation

uses
  Windows, Messages, SysUtils, Classes, Forms, Contnrs;

resourcestring
  SLogCompileError = '=========================================' + #13#10 +
                     'Error: %s' + #13#10 +
                     '=========================================';
  SLogStartCompile = '=========================================' + #13#10 +
                     'Compiling and installing:' + #13#10 +
                     '%s' + #13#10 +
                     '=========================================';
  SLogEnd          = '=========================================' + #13#10 +
                     'Finished' + #13#10 +
                     '=========================================';

  SLogInvalidPath = 'Error: %s doesn''t exist.';
  SLogInvalidZip = 'Error: %s is corrupted.';
  SLogInvalidIDE = 'Error: %s is not installed.';

  SLogErrorCopying = 'Error copying %s to %s';
  SLogErrorDeleting = 'Error deleting %s';
  SLogErrorExecuting = 'Error executing %s';
  SLogErrorCompiling = 'Error compiling %s';

  SLogCopying = 'Copying:' +  #13#10 + '     %s' + #13#10 + 'To:' + #13#10 + '     %s';
  SLogExecuting = 'Executing:' +  #13#10 + '     %s';
  SLogExtracting = 'Extracting:' +  #13#10 + '     %s' + #13#10 + 'To:' + #13#10 + '     %s';
  SLogCompiling = 'Compiling Package: %s';
  SLogInstalling = 'Installing Package: %s';
  SLogFinished = 'All the component packages have been successfully installed.' + #13#10 + 'Elapsed time: %f secs.';

type
  TSpIDEType = (ideNone, ideDelphi5, ideDelphi6, ideDelphi7, ideDelphi2005, ideDelphi2006); // [IDE-Change]

  TSpActionType = (satNone, satCopy, satCopyRun);

  TSpInstallType = (sitNotInstallable, sitInstallable, sitSearchPathOnly);

  TSpExecuteEntry = class
    Action: TSpActionType;
    Origin: string;
    Destination: string;
  end;

  TSpExecuteList = class(TObjectList)
  private
    function GetItems(Index: Integer): TSpExecuteEntry;
    procedure SetItems(Index: Integer; const Value: TSpExecuteEntry);
  public
    procedure LoadFromIni(Filename, Section: string);
    function ExecuteAll(BaseFolder: string; Log: TStrings): Boolean;
    property Items[Index: Integer]: TSpExecuteEntry read GetItems write SetItems; default;
  end;

  TSpComponentPackage = class
    Name: string; //包名
    Destination: string; //包所在目录
    SearchPath: string; //src搜索目录
    Installable: TSpInstallType;
    constructor Create; virtual;
    destructor Destroy; override;
  end;

  TSpComponentPackageList = class(TObjectList)
  private
    FDefaultInstallIDE: TSpIDEType;
    FDefaultInstallFolder: string;
    FMinimumIDE: TSpIDEType;
    function GetItems(Index: Integer): TSpComponentPackage;
    procedure SetItems(Index: Integer; const Value: TSpComponentPackage);
  public
    procedure LoadFromIni(Filename: string);
    function CompileAll(BaseFolder: string; IDE: TSpIDEType; Log: TStrings): Integer;
    property DefaultInstallIDE: TSpIDEType read FDefaultInstallIDE write FDefaultInstallIDE;
    property DefaultInstallFolder: string read FDefaultInstallFolder write FDefaultInstallFolder;
    property Items[Index: Integer]: TSpComponentPackage read GetItems write SetItems; default;
    property MinimumIDE: TSpIDEType read FMinimumIDE;
  end;

  TSpMultiInstaller = class
  protected
    FComponentPackages: TSpComponentPackageList;
    FInstalling: Boolean;
  public
    constructor Create(IniFilename: string); virtual;
    destructor Destroy; override;
    function Install(BaseFolder: string; IDE: TSpIDEType; Log: TStrings): Boolean;
    property ComponentPackages: TSpComponentPackageList read FComponentPackages;
  end;

{ Misc }
procedure SpOpenLink(URL: string);
function SpStringSearch(S, SubStr: string): Boolean;
procedure SpWriteLog(Log: TStrings; ResourceS, Arg1: string; Arg2: string = '');

{ Files }
function SpGetParameter(const ParamName: string; out ParamValue: string): Boolean;
function SpExecuteDosCommand(CommandLine, WorkDir: string; out OutputString: string): Boolean;
function SpFileOperation(Origin, Destination: string; Operation: Cardinal): Boolean;
function SpGetMyDocumentsFolder: string;
procedure SpGetWinDirs(out Windows, System, Temp: string);
function SpSelectDirectory(const Caption: string; const Root: WideString; var Directory: string): Boolean;

{ Ini and Registry }
function SpReadRegValue(Key, Name: string; out Value: string): Boolean;
function SpReadRegKey(Key: string; NamesAndValues: TStringList): Boolean;
function SpWriteRegValue(Key, Name, Value: string): Boolean;
procedure SpIniLoadStringList(L: TStringList; IniFilename, Section: string; NamePrefix: string = '');
procedure SpIniSaveStringList(L: TStringList; IniFilename, Section: string; NamePrefix: string = '');
function SpParseEntryValue(S: string; ValueList: TStringList; MinimumCount: Integer = 0): Boolean;

{ IDE }
function SpActionTypeToString(A: TSpActionType): string;
function SpStringToActionType(S: string): TSpActionType;
procedure SpIDETypeToString(A: TSpIDEType; out IDEName, IDEIniName, IDERegName: string); overload;
function SpIDETypeToString(A: TSpIDEType): string; overload;
function SpStringToIDEType(S: string): TSpIDEType;
function SpIDEDir(IDE: TSpIDEType): string;
function SpIDEDCC32Path(IDE: TSpIDEType): string;
function SpIDEInstalled(IDE: TSpIDEType): Boolean;
function SpIDESearchPath(IDE: TSpIDEType; CPPBuilderPath: Boolean = False): string;
procedure SpIDEAddToSearchPath(Directory: string; IDE: TSpIDEType);
function SpIDEBDSProjectsDir(IDE: TSpIDEType): string;
function SpIDEGetEnvironmentVars(IDE: TSpIDEType; IDEEnvVars: TStringList): Boolean;
function SpIDEExpandMacros(S: string; IDE: TSpIDEType): string;

{ Delphi Packages }
function SpGetPackageOptions(PackageFilename, BPLDir: string; out RunTime, DesignTime: Boolean; out BPLFilename, Description: string): Boolean;
function SpCompilePackage(PackageFilename, DCC, SourceSearchPath: string; IDE: TSpIDEType; IncludesL, Log: TStrings; TempDir: string = ''): Boolean;
function SpRegisterPackage(PackageFilename, BPLDir: string; IDE: TSpIDEType; Log: TStrings): Boolean;

implementation

uses
  ActiveX, ShellApi, ShlObj, IniFiles, Registry, StrUtils;

const
  rvCount = 'Count';
  rvPackageIniSectionPrefix = 'Package -';
  rvName = 'Name';
  rvZip = 'Zip';
  rvFolder = 'Folder';
  rvSearchPath = 'SearchPath';
  rvGroupIndex = 'GroupIndex';
  rvIncludes = 'Includes';
  rvInstallable = 'Installable';
  rvExecuteIniPrefix = 'Execute';
  rvBaseFolder = '$BaseFolder';
  rvOptionsIniSection = 'Options';
  rvDefaultInstallIDE = 'DefaultInstallIDE';
  rvDefaultInstallFolder = 'DefaultInstallFolder';
  rvMinimumIDE = 'MinimumIDEVersion';

//WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM
{ Helpers }

procedure SpOpenLink(URL: string);
begin
  ShellExecute(Application.Handle, 'open', PChar(URL), '', '', SW_SHOWNORMAL);
end;

function SpStringSearch(S, SubStr: string): Boolean;
begin
  S := UpperCase(S);
  SubStr := UpperCase(SubStr);
  Result := Pos(SubStr, S) > 0;
end;

procedure SpWriteLog(Log: TStrings; ResourceS, Arg1: string; Arg2: string = '');
begin
  if Assigned(Log) then begin
    Log.Add(Format(ResourceS, [Arg1, Arg2]));
    Log.Add('');
  end;
end;

//WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM
{ Files }

function SpGetParameter(const ParamName: string; out ParamValue: string): Boolean;
{ Determines whether a string was passed as a command line parameter to the
  application, and returns the parameter value if there is one.

  For example:
  File.exe /param1 c:\windows\internet files /param2 /param3
  File.exe /param1 "c:\windows\internet files" /param2 /param3
  File.exe -param1 c:\windows\internet files -param2 -param3
  File.exe -param1 "c:\windows\internet files" -param2 -param3

  SpGetParameter('param1', S) returns S = c:\windows\internet files }
var
  I: Integer;
  S: string;
begin
  Result := False;
  ParamValue := '';

  for I := 1 to ParamCount do begin
    S := ParamStr(I);
    if (S <> '') and (S[1] in ['/', '-']) then begin
      if Result then
        Break  // Next switch reached
      else begin
        Delete(S, 1, 1);
        if (S <> '') and SameText(S, ParamName) then
          Result := True;  // Set flag
      end;
    end
    else
      if Result then
        ParamValue := ParamValue + S
  end;
end;

function SpExecuteDosCommand(CommandLine, WorkDir: string; out OutputString: string): Boolean;
// Executes a DOS file, waits until it terminates and logs the output.
// DosApp param can be a file name with params.
// It can also be a command line, for example: CMD.exe /c dir D:\mp3
const
   ReadBuffer = 2400;
var
  Security: TSecurityAttributes;
  ReadPipe, WritePipe: THandle;
  Start: TStartUpInfo;
  ProcessInfo: TProcessInformation;
  Buffer: Pchar;
  BytesRead: DWord;
  Apprunning: DWord;
  PWorkDirChar: PChar;
  AExitCode: Cardinal;
begin
  Result := False;
  OutputString := '';

  Security.nlength := SizeOf(TSecurityAttributes);
  Security.binherithandle := true;
  Security.lpsecuritydescriptor := nil;

  if CreatePipe(ReadPipe, WritePipe, @Security, 0) then begin
    FillChar(ProcessInfo, SizeOf(ProcessInfo), #0);

    Buffer := AllocMem(ReadBuffer + 1);
    FillChar(Start, Sizeof(Start), #0);
    start.cb := SizeOf(start);
    start.hStdOutput := WritePipe;
    start.hStdInput := ReadPipe;
    start.dwFlags := STARTF_USESTDHANDLES + STARTF_USESHOWWINDOW;
    start.wShowWindow := SW_HIDE;

    if WorkDir = '' then PWorkDirChar := nil
    else PWorkDirChar := PChar(WorkDir);

    if CreateProcess(nil, PChar(CommandLine), @Security, @Security, True, 0, nil, PWorkDirChar, Start, ProcessInfo) then begin
      repeat
        Apprunning := WaitForSingleObject(ProcessInfo.hProcess, 1000);
        Application.ProcessMessages;
        repeat
          BytesRead := 0;
          GetExitCodeProcess(ProcessInfo.hProcess,AExitCode);
          if not PeekNamedPipe(ReadPipe,nil,0,nil,@BytesRead,nil) then
            RaiseLastWin32Error;
          Application.ProcessMessages;
          if BytesRead>0 then
          begin
            ReadFile(ReadPipe, Buffer[0], ReadBuffer, BytesRead, nil);
            Buffer[BytesRead] := #0;
            OemToAnsi(Buffer, Buffer);
            OutputString := OutputString + String(Buffer);
          end;
        until (BytesRead < ReadBuffer) and (AExitCode<>STILL_ACTIVE);
        Application.ProcessMessages;
      until (Apprunning <> WAIT_TIMEOUT);
      AExitCode := 0;
      GetExitCodeProcess(ProcessInfo.hProcess, AExitCode);
      if AExitCode = 0 then
        Result := True
      else
        Result := False;
    end;

    FreeMem(Buffer) ;
    CloseHandle(ProcessInfo.hProcess) ;
    CloseHandle(ProcessInfo.hThread) ;
    CloseHandle(ReadPipe) ;
    CloseHandle(WritePipe) ;
  end;
end;

function SpFileOperation(Origin, Destination: string; Operation: Cardinal): Boolean;
var
  F: TShFileOpStruct;
begin
   Result := False;
   // Operation can be: FO_COPY, FO_MOVE, FO_DELETE, FO_RENAME
   if not (Operation in [FO_MOVE..FO_RENAME]) then Exit;

   Origin := Origin + #0#0;
   Destination := Destination + #0#0;

   FillChar(F, SizeOf(F), #0);
   F.Wnd := Application.Handle;
   F.wFunc := Operation;
   F.pFrom := PChar(Origin);
   F.pTo := PChar(Destination);
   F.fFlags := FOF_SILENT or FOF_NOCONFIRMATION or FOF_NOCONFIRMMKDIR;
   Result := SHFileOperation(F) = 0;
end;

function SpGetMyDocumentsFolder: string;
var
  TargetPIDL: PItemIDList;
  S: string;
begin
  Result := '';
  if Succeeded(SHGetSpecialFolderLocation(Application.Handle, CSIDL_PERSONAL, TargetPIDL)) then
  begin
    SetLength(S, MAX_PATH);
    FillChar(PChar(S)^, MAX_PATH, #0);
    if SHGetPathFromIDList(TargetPIDL, PChar(S)) then begin
      SetLength(S, StrLen(PChar(S)));
      Result := IncludeTrailingPathDelimiter(S);
    end;
  end;
end;

procedure SpGetWinDirs(out Windows, System, Temp: string);
var
  S: string;
begin
  Windows := '';
  System := '';
  Temp := '';

  SetLength(S, MAX_PATH);
  if GetWindowsDirectory(PChar(S), MAX_PATH) <> 0 then begin
    SetLength(S, StrLen(PChar(S)));
    Windows := S;
  end;

  SetLength(S, MAX_PATH);
  if GetSystemDirectory(PChar(S), MAX_PATH) <> 0 then begin
    SetLength(S, StrLen(PChar(S)));
    System := S;
  end;

  SetLength(S, MAX_PATH);
  if GetTempPathA(MAX_PATH, PChar(S)) <> 0 then begin
    SetLength(S, StrLen(PChar(S)));
    Temp := S;
  end;
end;

function SpSelectDirCB(Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer stdcall;
begin
  if (uMsg = BFFM_INITIALIZED) and (lpData <> 0) then
    SendMessage(Wnd, BFFM_SETSELECTION, Integer(True), lpdata);
  result := 0;
end;

function SpSelectDirectory(const Caption: string; const Root: WideString;
  var Directory: string): Boolean;
// SelectDirectory with new UI, Edit box and 'Create Folder' button
const
  BIF_NEWDIALOGSTYLE = $0040;
  BIF_USENEWUI = (BIF_NEWDIALOGSTYLE or BIF_EDITBOX);
var
  WindowList: Pointer;
  BrowseInfo: TBrowseInfo;
  Buffer: PChar;
  OldErrorMode: Cardinal;
  RootItemIDList, ItemIDList: PItemIDList;
  ShellMalloc: IMalloc;
  IDesktopFolder: IShellFolder;
  Eaten, Flags: LongWord;
begin
  Result := False;
  if not DirectoryExists(Directory) then
    Directory := '';
  FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
  if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then
  begin
    Buffer := ShellMalloc.Alloc(MAX_PATH);
    try
      RootItemIDList := nil;
      if Root <> '' then
      begin
        SHGetDesktopFolder(IDesktopFolder);
        IDesktopFolder.ParseDisplayName(Application.Handle, nil,
          POleStr(Root), Eaten, RootItemIDList, Flags);
      end;
      with BrowseInfo do
      begin
        hwndOwner := Application.Handle;
        pidlRoot := RootItemIDList;
        pszDisplayName := Buffer;
        lpszTitle := PChar(Caption);
        ulFlags := BIF_RETURNONLYFSDIRS;
        if Win32MajorVersion >= 5 then
          ulFlags := ulFlags or BIF_USENEWUI;

        if Directory <> '' then
        begin
          lpfn := SpSelectDirCB;
          lParam := Integer(PChar(Directory));
        end;
      end;
      WindowList := DisableTaskWindows(0);
      OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
      try
        ItemIDList := ShBrowseForFolder(BrowseInfo);
      finally
        SetErrorMode(OldErrorMode);
        EnableTaskWindows(WindowList);
      end;
      Result :=  ItemIDList <> nil;
      if Result then
      begin
        ShGetPathFromIDList(ItemIDList, Buffer);
        ShellMalloc.Free(ItemIDList);
        Directory := Buffer;
      end;
    finally
      ShellMalloc.Free(Buffer);
    end;
  end;
end;

//WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM
{ Ini and Registry }

function SpDeleteRegValue(Key, Name: string): Boolean;