ucomponentinstaller.pas

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

var
  R: TRegistry;
begin
  Result := False;
  R := TRegistry.Create;
  try
    R.RootKey := HKEY_CURRENT_USER;
    if R.OpenKey(Key, False) then
      if R.ValueExists(Name) then
        Result := R.DeleteValue(Name);
  finally
    R.Free;
  end;
end;

function SpReadRegValue(Key, Name: string; out Value: string): Boolean;
var
  R: TRegistry;
begin
  Result := False;
  Value := '';
  R := TRegistry.Create;
  try
    R.RootKey := HKEY_CURRENT_USER;
    if R.OpenKey(Key, False) then
      if R.ValueExists(Name) then begin
        Value := R.ReadString(Name);
        Result := True;
      end;
  finally
    R.Free;
  end;
end;

function SpReadRegKey(Key: string; NamesAndValues: TStringList): Boolean;
var
  R: TRegistry;
  Names: TStringList;
  I: Integer;
begin
  Result := False;
  if not Assigned(NamesAndValues) then Exit;
  NamesAndValues.Clear;

  R := TRegistry.Create;
  Names := TStringList.Create;
  try
    R.RootKey := HKEY_CURRENT_USER;
    if R.OpenKey(Key, False) then begin
      R.GetValueNames(Names);
      for I := 0 to Names.Count - 1 do
        if R.ValueExists(Names[I]) then
          NamesAndValues.Values[Names[I]] := R.ReadString(Names[I]);
      Result := True;
    end;
  finally
    R.Free;
    Names.Free;
  end;
end;

function SpWriteRegValue(Key, Name, Value: string): Boolean;
var
  R: TRegistry;
begin
  Result := False;
  R := TRegistry.Create;
  try
    R.RootKey := HKEY_CURRENT_USER;
    if R.OpenKey(Key, True) then begin
      R.WriteString(Name, Value);
      Result := True;
    end;
  finally
    R.Free;
  end;
end;

procedure SpIniLoadStringList(L: TStringList; IniFilename, Section: string; NamePrefix: string = '');
var
  F: TMemIniFile;
  I, C: integer;
begin
  if not Assigned(L) then Exit;
  F := TMemIniFile.Create(IniFilename);
  try
    L.Clear;
    C := F.ReadInteger(Section, NamePrefix + rvCount, -1);
    for I := 0 to C - 1 do
      L.Add(F.ReadString(Section, NamePrefix + inttostr(I), ''));
  finally
    F.Free;
  end;
end;

procedure SpIniSaveStringList(L: TStringList; IniFilename, Section: string; NamePrefix: string = '');
var
  F: TMemIniFile;
  I: integer;
begin
  if not Assigned(L) then Exit;
  F := TMemIniFile.Create(IniFilename);
  try
    F.EraseSection(Section);
    if L.Count > 0 then begin
      F.WriteInteger(Section, NamePrefix + rvCount, L.Count);
      for I := 0 to L.Count - 1 do
        F.WriteString(Section, NamePrefix + IntToStr(I), L[I]);
      F.UpdateFile;
    end;
  finally
    F.Free;
  end;
end;

function SpParseEntryValue(S: string; ValueList: TStringList; MinimumCount: Integer = 0): Boolean;
begin
  ValueList.Clear;
  ValueList.CommaText := S;
  if MinimumCount < 1 then
    Result := ValueList.Count >= MinimumCount
  else
    Result := True;
end;

//WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM
{ IDE }

const
  ActionTypes: array [TSpActionType] of string = ('none', 'copy', 'copyandrun');
  // [IDE-Change]
  IDETypes: array [TSpIDEType] of string = ('None', 'D5', 'D6', 'D7', 'D9', 'D10');
  IDENameTypes: array [TSpIDEType] of string = ('None', 'Delphi 5', 'Delphi 6', 'Delphi 7', 'Delphi 2005', 'Developer Studio 2006');
  IDERegNameTypes: array [TSpIDEType] of string = ('None', 'Delphi\5.0', 'Delphi\6.0', 'Delphi\7.0', 'BDS\3.0', 'BDS\4.0');

function SpActionTypeToString(A: TSpActionType): string;
begin
  Result := ActionTypes[A];
end;

function SpStringToActionType(S: string): TSpActionType;
var
  A: TSpActionType;
begin
  Result := satNone;
  S := LowerCase(S);
  for A := Low(ActionTypes) to High(ActionTypes) do
    if AnsiCompareText(S, ActionTypes[A]) = 0 then begin
      Result := A;
      Exit;
    end;
end;

procedure SpIDETypeToString(A: TSpIDEType; out IDEName, IDEIniName, IDERegName: string); overload;
begin
  IDEName := IDENameTypes[A];
  IDEIniName := IDETypes[A];
  IDERegName := IDERegNameTypes[A];
end;

function SpIDETypeToString(A: TSpIDEType): string; overload;
begin
  Result := IDETypes[A];
end;

function SpStringToIDEType(S: string): TSpIDEType;
var
  A: TSpIDEType;
begin
  Result := ideNone;
  for A := Low(IDETypes) to High(IDETypes) do
    if AnsiCompareText(S, IDETypes[A]) = 0 then begin
      Result := A;
      Exit;
    end;
end;

function SpIDEDir(IDE: TSpIDEType): string;
var
  N, I, R: string;
begin
  SpIDETypeToString(IDE, N, I, R);
  SpReadRegValue('SOFTWARE\Borland\' + R, 'RootDir', Result);
end;

function SpIDEDCC32Path(IDE: TSpIDEType): string;
var
  N, I, R: string;
begin
  SpIDETypeToString(IDE, N, I, R);
  SpReadRegValue('SOFTWARE\Borland\' + R, 'App', Result);
  if Result <> '' then
    Result := IncludeTrailingPathDelimiter(ExtractFilePath(Result)) + 'dcc32.exe';
end;

function SpIDEInstalled(IDE: TSpIDEType): Boolean;
begin
  if IDE = ideNone then
    Result := False
  else
    Result := FileExists(SpIDEDCC32Path(IDE));
end;

function SpIDESearchPath(IDE: TSpIDEType; CPPBuilderPath: Boolean = False): string;
var
  N, I, R: string;
begin
  Result := '';
  if IDE = ideNone then Exit;

  SpIDETypeToString(IDE, N, I, R);
  if (IDE >= ideDelphi2006) and CPPBuilderPath then
    SpReadRegValue('SOFTWARE\Borland\' + R + '\CppPaths', 'SearchPath', Result) // 'SearchPath' with no space for C++Builder 2006 and above
  else
    SpReadRegValue('SOFTWARE\Borland\' + R + '\Library', 'Search Path', Result);
end;

procedure SpIDEAddToSearchPath(Directory: string; IDE: TSpIDEType);
var
  S, N, I, R: string;
begin
  Directory := SpIDEExpandMacros(ExcludeTrailingPathDelimiter(Directory), IDE);

  // Add the directory to the Delphi search path registry entry
  S := SpIDESearchPath(IDE, False);

  if (S <> '') and (Directory <> '') then
    if not SpStringSearch(S, Directory) then begin
      if S[Length(S)] <> ';' then
        S := S + ';';
      S := S + Directory;
      SpIDETypeToString(IDE, N, I, R);
      SpWriteRegValue('SOFTWARE\Borland\' + R + '\Library', 'Search Path', S);
    end;

  // Add the directory to the C++Builder search path registry entry
  if IDE >= ideDelphi2006 then begin
    S := SpIDESearchPath(IDE, True);
    if (S <> '') and (Directory <> '') then
      if not SpStringSearch(S, Directory) then begin
        if S[Length(S)] <> ';' then
          S := S + ';';
        S := S + Directory;
        SpIDETypeToString(IDE, N, I, R);
        SpWriteRegValue('SOFTWARE\Borland\' + R + '\CppPaths', 'SearchPath', S) // 'SearchPath' with no space for C++Builder 2006 and above
      end;
  end;
end;

function SpIDEBDSProjectsDir(IDE: TSpIDEType): string;
var
  Aux1, Aux2, R, MyDocs: string;
begin
  Result := '';
  if IDE > ideDelphi7 then begin
    // $(BDSPROJECTSDIR) = ...\My Documents\Borland Studio Projects
    // Unfortunately 'Borland Studio Projects' string is localized in the
    // French, German and Japanese versions of the IDE.
    // This macro can be overrided by adding a string value called
    // 'DefaultProjectsDirectory' containing a different directory to:
    // HKCU\Software\Borland\BDS\4.0\Globals
    SpIDETypeToString(IDE, Aux1, Aux2, R);
    SpReadRegValue('SOFTWARE\Borland\' + R + '\Globals', 'DefaultProjectsDirectory', Result);
    if not DirectoryExists(Result) then begin
      // The IDE user can override it on the Environment Options menu,
      // the value is stored on the 'BDSPROJECTSDIR' key name on:
      // HKCU\Software\Borland\BDS\3.0\Environment Variables
      SpReadRegValue('SOFTWARE\Borland\' + R + '\Environment Variables', 'BDSPROJECTSDIR', Result);
      if not DirectoryExists(Result) then begin
        // Check if it's My Documents\Borland Studio Projects
        MyDocs := SpGetMyDocumentsFolder;
        Result := MyDocs + 'Borland Studio Projects'; // English
        if not DirectoryExists(Result) then begin
          Result := MyDocs + 'Borland Studio-Projekte'; // German
          if not DirectoryExists(Result) then begin
            Result := MyDocs + 'Projets Borland Studio'; // French
            if not DirectoryExists(Result) then
              Result := '';
          end;
        end;
      end;
    end;
  end;
end;

function SpIDEGetEnvironmentVars(IDE: TSpIDEType; IDEEnvVars: TStringList): Boolean;
var
  Aux1, Aux2, R: string;
begin
  SpIDETypeToString(IDE, Aux1, Aux2, R);
  Result := SpReadRegKey('SOFTWARE\Borland\' + R + '\Environment Variables', IDEEnvVars);
end;

function SpIDEExpandMacros(S: string; IDE: TSpIDEType): string;
// Replace $(Delphi), $(BDS), $(BDSPROJECTSDIR) macros and
// IDE Environment Variables Overrides with real directories
var
  I: Integer;
  IDEDir: string;
  BDSProjectsDir: string;
  L: TStringList;
begin
  Result := S;
  if IDE = ideNone then Exit;

  L := TStringList.Create;
  try
    // Get the Environment Variables Overrides
    SpIDEGetEnvironmentVars(IDE, L);

    // Add the default $(Delphi), $(BDS) and $(BDSPROJECTSDIR) macros
    // if there're no overrides for them
    IDEDir := SpIDEDir(IDE);
    I := L.IndexOfName('Delphi');
    if I = -1 then L.Values['Delphi'] := IDEDir;
    if IDE >= ideDelphi2005 then begin
      I := L.IndexOfName('BDS');
      if I = -1 then L.Values['BDS'] := IDEDir;
      BDSProjectsDir := SpIDEBDSProjectsDir(IDE);
      if BDSProjectsDir <> '' then
        L.Values['BDSPROJECTSDIR'] := BDSProjectsDir;
    end;

    // Replace all
    for I := 0 to L.Count - 1 do
      Result := StringReplace(Result, '$(' + L.Names[I] + ')', ExcludeTrailingPathDelimiter(L.ValueFromIndex[I]), [rfReplaceAll, rfIgnoreCase]);
  finally
    L.Free;
  end;
end;

//WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM
{ Delphi Packages }

function SpGetPackageOptions(PackageFilename, BPLDir: string; out RunTime, DesignTime: Boolean; out BPLFilename, Description: string): Boolean;
var
  L: TStringList;
  P, P2: Integer;
  BPLSuffix: string;
begin
  Result := False;
  RunTime := False;
  DesignTime := False;

  Description := '';
  BPLFilename := BPLDir + ChangeFileExt(ExtractFileName(PackageFilename), '.bpl');
  BPLSuffix := '';
  if FileExists(PackageFilename) then begin
    L := TStringList.Create;
    try
      L.LoadFromFile(PackageFilename);
      P := Pos('{$RUNONLY}', L.Text);
      if P > 0 then
        RunTime := True;
      P := Pos('{$DESIGNONLY}', L.Text);
      if P > 0 then
        DesignTime := True;
      P := Pos('{$DESCRIPTION ''', L.Text); // {$DESCRIPTION 'Package Description'}
      if P > 0 then begin
        P := P + Length('{$DESCRIPTION ''');
        P2 := PosEx('''}', L.Text, P);
        if P2 > 0 then
          Description := Copy(L.Text, P, P2 - P);
      end;
      P := Pos('{$LIBSUFFIX ''', L.Text); // {$LIBSUFFIX '100'}  //  file100.bpl
      if P > 0 then begin
        P := P + Length('{$LIBSUFFIX ''');
        P2 := PosEx('''}', L.Text, P);
        if P2 > 0 then begin
          BPLSuffix := Copy(L.Text, P, P2 - P);
          // Rename BPL filename to include the suffix
          P := LastDelimiter('.', BPLFilename);
          if P > 0 then
            BPLFilename := Copy(BPLFilename, 1, P - 1) + BPLSuffix + Copy(BPLFilename, P, MaxInt);
        end;
      end;

      Result := True;
    finally
      L.Free;
    end;
  end;
end;

procedure SpReadIncludePackages(PackageFilename: string;SL: TStrings);
var
  L: TStringList;
  P,i,j: integer;
  s: string;
begin
  SL.Clear;
  if FileExists(PackageFilename) then begin
    L := TStringList.Create;
    try
      L.LoadFromFile(PackageFilename);
        P := Pos('requires', LowerCase(L.Text));
        if P=0 then Exit;
        S := Copy(L.Text,p+length('requires'),Length(l.Text));
        P := Pos(';', s);
        if P=0 then Exit;
        Delete(s,p,Length(s));
        S := StringReplace(s,',',#13,[rfReplaceAll, rfIgnoreCase]);
      SL.Text := LowerCase(S);
      for i:=SL.Count-1 downto 0 do
      begin
        SL[i] := Trim(SL[i]);
        if SL[i]='' then SL.Delete(i);
      end;
    finally
      l.Free;
    end;
  end;
end;

function SpIsDesignTimePackage(PackageFilename: string): Boolean;
var
  L: TStringList;
  P: Integer;
begin
  Result := False;

  if FileExists(PackageFilename) then begin
    L := TStringList.Create;
    try
      L.LoadFromFile(PackageFilename);
      P := Pos('{$DESIGNONLY}', L.Text);
      if P > 0 then
        Result := True;
    finally
      L.Free;
    end;
  end;
end;

function SpCompilePackage(PackageFilename, DCC, SourceSearchPath: string; IDE: TSpIDEType;
  IncludesL, Log: TStrings; TempDir: string = ''): Boolean;
// PackageFilename = full path of the package, e.g. 'C:\MyCompos\Compo\Packages\D7Runtime.dpk
// DCC = full path of dcc32.exe, e.g. 'C:\Program Files\Borland\Delphi7\Bin\dcc32.exe
// SourceSearchPath = source directory of the component package to add to the Library Search Path