实现了Ocx的注册例程

Tom Lee先生1997年写的

unit ActXInst;

// Auto ActiveX Controls Register/Unregsiter Component
// ver 1.03
// Last Modify 1997 JUN 28
// By Tom Lee (tom@libra.aaa.hinet.net)
// http://www.aaa.hinet.net/delphi ( Chinese BIG-5 Encoding Page )
// for Delphi 3

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, MyRegistry , ComObj, ActiveX ;

type
  TOCXDirType=(dtSystem,dtWindows,dtApplication);

  TActiveXInstaller = class(TComponent)
  private
    { Private declarations }
    FActive:Boolean;
    FAllOcxCLSID:TStrings;
    FAllOcxName:TStrings;
    FAllOcxPath:TStrings;
    FAutoRegList:TStrings;
    FOCXDir:TOCXDirType;
    function InstallOcx(const sFileName: AnsiString;bSetup: boolean): boolean;
    procedure AutoRegOCX;
    procedure ClearRegInfo;
    procedure Dumb(value:TStrings);
    procedure GetRegInfo;
    procedure SetActive(value:Boolean);
    procedure SetAutoRegList(value:TStrings);
    procedure SetOCXDir(value:TOCXDirType);
  protected
    { Protected declarations }
    procedure Loaded;override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Refresh;
    function OCXListUnregister(id:integer):Boolean;
    function OCXFileRegister(FullPathFileName:String):Boolean;
    function OCXFileUnRegister(FullPathFileName:String):Boolean;
    function ShowRegDialog:Boolean;
    function ShowUnRegDialog:Boolean;
    function IsInstallOK(OCXFileName:String):Boolean;
  published
    { Published declarations }
    property Active:Boolean read FActive write SetActive default True;
    property AutoRegister:TStrings read FAutoRegList write SetAutoRegList;
    property OCXDir:TOCXDirType read FOCXDir write SetOCXDir default dtSystem;
    property OCXCLSID:TStrings read FAllOcxCLSID write Dumb;
    property OCXName:TStrings read FAllOcxName write Dumb;
    property OCXFullPathName:TStrings read FAllOcxPath write Dumb;
  end;

procedure Register;

implementation

constructor TActiveXInstaller.Create(AOwner: TComponent);
begin
     inherited Create(AOwner);
     FAllOcxCLSID:=TStringList.Create;
     FAllOcxName:=TStringList.Create;
     FAllOcxPath:=TStringList.Create;
     FAutoRegList:=TStringList.Create;
     FActive:=True;
     FOCXDir:=dtSystem;
     GetRegInfo;
end;

procedure TActiveXInstaller.Loaded;
begin
     inherited;

     if FActive then
     begin
          GetRegInfo;
          AutoRegOCX;
     end
     else
         ClearRegInfo;
end;

destructor TActiveXInstaller.Destroy;
begin
     FAllOcxCLSID.Free;
     FAllOcxName.Free;
     FAllOcxPath.Free;
     FAutoRegList.Free;
     inherited Destroy;
end;

procedure TActiveXInstaller.Refresh;
begin
     if FActive then GetRegInfo;
end;

procedure TActiveXInstaller.SetAutoRegList(value:TStrings);
begin
     FAutoRegList.Clear;
     FAutoRegList.Assign(value);
end;

procedure TActiveXInstaller.SetOCXDir(value:TOCXDirType);
begin
     if value<>FOCXDir then FOCXDir:=value;
end;

function TActiveXInstaller.OCXListUnregister(id:integer):Boolean;
begin
     if (FActive) and (id>=0) and (id<FAllOCXPath.Count) then
         Result:=InstallOcx(FAllOCXPath[id],False)
     else
         Result:=False;
end;

function TActiveXInstaller.OCXFileUnRegister(FullPathFileName:String):Boolean;
begin
     Result:=InstallOcx(FullPathFileName,False);
end;

function TActiveXInstaller.OCXFileRegister(FullPathFileName:String):Boolean;
begin
     Result:=InstallOcx(FullPathFileName,True);
end;

function TActiveXInstaller.ShowRegDialog:Boolean;
begin
     with TOpenDialog.Create(Self) do
     begin
          Title:='请选择需要注册的ActiveX控件';
          Filter:='OCX 郎 (*.OCX)|*.OCX|DLL文件(*.DLL)|*.DLL|全部文件(*.*)|*.*';
          if Execute then
              Result:=InstallOcx(FileName,True)
          else
              Result:=False;
          Free;
     end;
end;

function TActiveXInstaller.ShowUnRegDialog:Boolean;
begin
     with TOpenDialog.Create(Self) do
     begin
          Title:='请选择需要销册的ActiveX控件';
          Filter:='OCX 郎 (*.OCX)|*.OCX|DLL文件(*.DLL)|*.DLL|全部文件(*.*)|*.*';
          if Execute then
              Result:=InstallOcx(FileName,False)
          else
              Result:=False;
          Free;
     end;
end;

procedure TActiveXInstaller.SetActive(value:Boolean);
begin
     if Value<>FActive then
     begin
          FActive:=value;
          if FActive then
          begin
               GetRegInfo;
               AutoRegOCX;
          end
          else
             ClearRegInfo;
     end;
end;

procedure TActiveXInstaller.ClearRegInfo;
begin
     FAllOcxCLSID.Clear;
     FAllOcxName.Clear;
     FAllOcxPath.Clear;
end;

procedure TActiveXInstaller.GetRegInfo;
var
   tmpReg1,tmpReg2:TRegistry;
   idx:integer;
begin
     ClearRegInfo;
     // Get All CLSID
     tmpReg1 := TRegistry.Create;
     tmpReg1.Access := KEY_READ ;
     tmpReg1.RootKey := HKEY_CLASSES_ROOT;

     if tmpReg1.OpenKey('/CLSID', False) then
     begin
          tmpReg1.GetKeyNames(FAllOcxCLSID);
          FAllOcxName.Assign(FAllOcxCLSID);
          FAllOcxPath.Assign(FAllOcxCLSID);
     end;
     tmpReg1.Free;

     // Get All ActiveX Controls CLSID,Name,Full Path Name
     for idx:=FAllOcxCLSID.Count-1 downto 0 do
     begin
          tmpReg1 := TRegistry.Create;
          tmpReg1.Access := KEY_READ ;
          tmpReg1.RootKey := HKEY_CLASSES_ROOT;
          if not tmpReg1.KeyExists('/CLSID/'+FAllOcxCLSID[idx]+'/Control') then
          begin
               FAllOcxCLSID.Delete(idx);
               FAllOcxName.Delete(idx);
               FAllOcxPath.Delete(idx);
          end
          else
          begin
               tmpReg1.OpenKey('/CLSID/'+FAllOcxCLSID[idx],False);
               FAllOcxName[idx]:=tmpReg1.ReadString('');
               tmpReg2 := TRegistry.Create;
               tmpReg2.Access := KEY_READ ;
               tmpReg2.RootKey := HKEY_CLASSES_ROOT;
               tmpReg2.OpenKey('/CLSID/'+FAllOcxCLSID[idx]+'/InprocServer32',False);
               FAllOcxPath[idx]:=tmpReg2.ReadString('');
               tmpReg2.Free;
          end;
          tmpReg1.Free;
     end;
end;

procedure TActiveXInstaller.Dumb(value:TStrings);
begin
end;

function TActiveXInstaller.IsInstallOK(OCXFileName:String):Boolean;
var
   idx:integer;
begin
     for idx:=0 to FAllOcxPath.Count-1 do
     begin
          if UpperCase(ExtractFileName(FAllOcxPath[idx]))=UpperCase(OCXFileName) then
          begin
               Result:=True;
               exit;
          end;
     end;
     result:=False;
end;

procedure TActiveXInstaller.AutoRegOCX;
var
   idx1,idx2,size:integer;
   Buf:PChar;
   Dir:string;
   tmpOCXList:TStringList;
begin
     Buf:=nil;
     
     if not (csDesigning in ComponentState) then
     begin
          tmpOCXList:=TStringList.Create;
          tmpOCXList.Assign(FAutoRegList);
          for idx1:=0 to FAllOcxPath.Count-1 do
          begin
               for idx2:=tmpOCXList.Count-1 downto 0  do
               begin
                    if UpperCase(ExtractFileName(FAllOcxPath[idx1]))=UpperCase(tmpOCXList[idx2]) then
                       tmpOCXList.Delete(idx2);
               end;
          end;

          if tmpOCXList.Count>0 then
          begin
               size:=MAX_PATH;
               setlength(Dir,size);
               for idx1:=0 to tmpOCXList.Count-1 do
               begin
                    case FOCXDir of
                        dtSystem:
                        begin
                             try
                                GetMem(Buf,Size);
                                GetSystemDirectory(Buf,size);
                                Dir:= StrPas(Buf);
                             finally
                                    FreeMem(Buf);
                             end;

                             try
                                OCXFileRegister(Dir+'/'+tmpOCXList[idx1]);
                             except
                                   on E:exception do
                                      MessageDlg(tmpOCXList[idx1]+'自动注册未成功('+E.Message+')',mtWarning,[mbOk],0);
                             end;
                        end;

                        dtWindows:
                        begin
                             try
                                GetMem(Buf,Size);
                                GetWindowsDirectory(Buf,size);
                                Dir:= StrPas(Buf);
                             finally
                                    FreeMem(Buf);
                             end;

                             try
                                OCXFileRegister(Dir+'/'+tmpOCXList[idx1]);
                             except
                                   on E:exception do
                                      MessageDlg(tmpOCXList[idx1]+'自动注册未成功('+E.Message+')',mtWarning,[mbOk],0);
                             end;
                        end;

                        dtApplication:
                        begin
                             Dir:=ExtractFilePath(Application.EXEName);
                             try
                                OCXFileRegister(Dir+'/'+tmpOCXList[idx1]);
                             except
                                   on E:exception do
                                      MessageDlg(tmpOCXList[idx1]+'自动注册未成功('+E.Message+')',mtWarning,[mbOk],0);
                             end;
                        end;
                    end;
               end;
               GetRegInfo;
          end;
          tmpOCXList.Free;
     end;
end;

function TActiveXInstaller.InstallOcx(const sFileName: AnsiString;bSetup: boolean): boolean;
var
  hOcx: THandle;
  funcRegister: TDllRegisterServer;
  funcUnRegister: TDllUnRegisterServer;
begin
  Result := False;
  // Check File Exist ?
  if not FileExists(sFileName) then
    Raise EOleError.CreateFmt('%s不存在，无法载入', [sFileName]);
  // Load a ActiveX File (.OCX , .DLL )
  hOcx := LoadLibrary(pchar(sFileName));
  if hOcx < 32 then
    Raise EOleError.CreateFmt('无法载入文件，请检查%s请检查是否为.Ocx或.Dll格式', [sFileName]);
  try
    // uses DllRegisterServer get call address
    if bSetup then
    begin
      funcRegister := GetProcAddress(hOcx, 'DllRegisterServer');
      if @funcRegister = nil then
        Raise EOleError.CreateFmt('无法载入%s中的DllRegisterServer，请确认此文件为Self-Register类型的OCX控件',[sFileName]);
      // Execute DllRegisterServer
      Result := funcRegister = S_OK;
    end
    else
    begin
      funcUnRegister := GetProcAddress(hOcx, 'DllUnregisterServer');
      if @funcUnRegister = nil then
        Raise EOleError.CreateFmt('无法载入%s中的DllUnRegisterServer，请确认此文件为Self-UnRegister类型的OCX控件',[sFileName]);
      // Execute DllUnregisterServer
      Result := funcUnRegister = S_OK;
    end;
    // Prompt Error Message
    if not Result then
    begin
      if bSetup then
        Raise EOleError.CreateFmt('无法登陆注册%s', [sFileName])
      else
        Raise EOleError.CreateFmt('无法取消注册%s', [sFileName]);
    end;
  finally
    FreeLibrary(hOcx);
  end;
end;

procedure Register;
begin
  RegisterComponents('Win32', [TActiveXInstaller]);
end;

end.