regunit.pas

TxQuery is an SQL engine implemented in a TDataSet descendant component, that can parse SQL syntax,

unit RegUnit;

interface

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

type
  TfrmReg = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    OpenDialog1: TOpenDialog;
    Label1: TLabel;
    Edit1: TEdit;
    Button4: TButton;
    Label2: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmReg: TfrmReg;

implementation

{$R *.DFM}

resourcestring
  SAbout = 'Turbo Register Server -- COM Server Registration utility.' +
    #13#10'Version 1.0.  Copyright (c) 2000 Inprise Corporation'#13#10;
  SFileNotFound = 'File "%s" not found';
  SCantFindProc = '%s procedure not found in "%s"';
  SRegFail = 'Call to %s failed in "%s"';
  SLoadFail = 'Failed to load "%s"';
  SRegSuccessful = 'Call to %s was successful!';
  SRegStr = 'registered';
  SUnregStr = 'unregistered';
  STlbName = 'Type library name: %s';
  STlbGuid = 'Type library GUID: %s';
  STlbRegSuccessful = 'Type library successfully %s!';
  SCantUnregTlb = 'The version of OLEAUT32.DLL on this machine does not ' +
    'support type library unregistration.';
  SNeedFileExt = 'You must specify a file extension for "%s"';
  SExeRegSuccessful = '%s successfully called.';
  SExeRegUnsuccessful = '%s failed.';
  SSuccessfulRegistration = 'Successfull registered OLD DB Provider';
  SSuccessfulUnRegistration = 'Successfull Unregistered OLD DB Provider';

type
  TRegType = (rtAxLib, rtTypeLib, rtExeLib);
  TRegAction = (raReg, raUnreg);
  TRegProc = function : HResult; stdcall;
  TUnRegTlbProc = function (const libID: TGUID; wVerMajor, wVerMinor: Word;
    lcid: TLCID; syskind: TSysKind): HResult; stdcall;

const
  ProcName: array[TRegAction] of PChar = (
    'DllRegisterServer', 'DllUnregisterServer');
  ExeFlags: array[TRegAction] of string = (' /regserver', ' /unregserver');

var
  RegType: TRegType = rtExeLib;
  RegAction: TRegAction = raReg;
  QuietMode: Boolean = False;
  FileName: string;
  RegProc: TRegProc;
  LibHandle: THandle;
  OleAutLib: THandle;
  UnRegTlbProc: TUnRegTlbProc;

procedure OutputStr(S: string);
begin
  if not QuietMode then
  begin
    CharToOEM(PChar(S), PChar(S));
    ShowMessage(S);
  end;
end;

function DecodeOptions: Boolean;
var
  i: Integer;
  FileStart: Boolean;
  Param, FileExt: string;
begin
  Result := False;
  if ParamCount = 0 then Exit;
  FileName := '';
  for i := 1 to ParamCount do
  begin
    Param := ParamStr(i);
    FileStart := not (Param[1] in ['-', '/']);
    if FileStart then
    begin
      if FileName = '' then FileName := Param
      else FileName := FileName + ' ' + Param;
      // strip open and/or close quote if present
      if (FileName[1] = '"') then
      begin
        if (FileName[Length(FileName)] = '"') then
          FileName := Copy(FileName, 2, Length(FileName) - 2)
        else if FileName[1] = '"' then Delete(FileName, 1, 1);
      end;
    end
    else
    begin
      if Length(Param) < 2 then Exit;
      case Param[2] of
        'U', 'u': RegAction := raUnreg;
        'Q', 'q': QuietMode := True;
        'T', 't': RegType := rtTypeLib;
      end;
    end;
  end;
  FileExt := ExtractFileExt(FileName);
  if FileExt = '' then raise Exception.CreateFmt(SNeedFileExt, [FileName]);
  if RegType <> rtTypeLib then
  begin
    if CompareText(FileExt, '.TLB') = 0 then RegType := rtTypeLib
    else if CompareText(FileExt, '.EXE') = 0 then RegType := rtExeLib
    else RegType := rtAxLib;
  end;
  Result := True;
end;

procedure RegisterAxLib;
begin
  LibHandle := LoadLibrary(PChar(FileName));
  if LibHandle = 0 then raise Exception.CreateFmt(SLoadFail, [FileName]);
  try
    @RegProc := GetProcAddress(LibHandle, ProcName[RegAction]);
    if @RegProc = Nil then
      raise Exception.CreateFmt(SCantFindProc, [ProcName[RegAction],
        FileName]);
    if RegProc <> 0 then
      raise Exception.CreateFmt(SRegFail, [ProcName[RegAction], FileName]);
    OutputStr(Format(SRegSuccessful, [ProcName[RegAction]]))
  finally
    FreeLibrary(LibHandle);
  end;
end;

procedure RegisterTLB;
const
  RegMessage: array[TRegAction] of string = (SRegStr, SUnregStr);
var
  WFileName, DocName: WideString;
  TypeLib: ITypeLib;
  LibAttr: PTLibAttr;
  DirBuffer: array[0..MAX_PATH] of char;
begin
  if ExtractFilePath(FileName) = '' then
  begin
    GetCurrentDirectory(SizeOf(DirBuffer), DirBuffer);
    FileName := '\' + FileName;
    FileName := DirBuffer + FileName;
  end;
  if not FileExists(FileName) then
    raise Exception.CreateFmt(SFileNotFound, [FileName]);
  WFileName := FileName;
  OleCheck(LoadTypeLib(PWideChar(WFileName), TypeLib));
  OutputStr(Format(STlbName, [WFileName]));
  OleCheck(TypeLib.GetLibAttr(LibAttr));
  try
    OutputStr(Format(STlbGuid, [GuidToString(LibAttr^.Guid)]) + #13#10);
    if RegAction = raReg then
    begin
      OleCheck(TypeLib.GetDocumentation(-1, nil, nil, nil, @DocName));
      DocName := ExtractFilePath(DocName);
      OleCheck(RegisterTypeLib(TypeLib, PWideChar(WFileName), PWideChar(DocName)));
    end
    else begin
      OleAutLib := GetModuleHandle('OLEAUT32.DLL');
      if OleAutLib <> 0 then
        @UnRegTlbProc := GetProcAddress(OleAutLib, 'UnRegisterTypeLib');
      if @UnRegTlbProc = nil then raise Exception.Create(SCantUnregTlb);
      with LibAttr^ do
        OleCheck(UnRegTlbProc(Guid, wMajorVerNum, wMinorVerNum, LCID, SysKind));
    end;
  finally
    TypeLib.ReleaseTLibAttr(LibAttr);
  end;
  OutputStr(Format(STlbRegSuccessful, [RegMessage[RegAction]]));
end;

procedure RegisterEXE;
var
  SI: TStartupInfo;
  PI: TProcessInformation;
  RegisterExitCode: BOOL;
begin
  FillChar(SI, SizeOf(SI), 0);
  SI.cb := SizeOf(SI);
  RegisterExitCode := Win32Check(CreateProcess(PChar(FileName), PChar(FileName + ExeFlags[RegAction]),
    nil, nil, True, 0, nil, nil, SI, PI));
  CloseHandle(PI.hThread);
  CloseHandle(PI.hProcess);
  if RegisterExitCode then
    OutputStr(Format(SExeRegSuccessful, [PChar(FileName + ExeFlags[RegAction])]))
  else
    OutputStr(Format(SExeRegUnsuccessful, [PChar(FileName + ExeFlags[RegAction])]));
end;

procedure DORegistration;
begin
  try
    if not DecodeOptions then
      raise Exception.Create(SAbout);
    if not FileExists(FileName) then
      raise Exception.CreateFmt(SFileNotFound, [FileName]);
    case RegType of
      rtAxLib: RegisterAxLib;
      rtTypeLib: RegisterTLB;
      rtExeLib: RegisterEXE;
    end;
  except
    on E:Exception do OutputStr(E.Message);
  end;
end;

procedure TfrmReg.Button1Click(Sender: TObject);
begin
   FileName:= Edit1.Text;
   if not FileExists(FileName) then Exit;
   FileName:= Edit1.Text;
   if not FileExists(FileName) then Exit;
   RegType:= rtAxLib;
   RegAction:= raReg;
   DoRegistration;
   ShowMessage(SSuccessfulRegistration);
end;

procedure TfrmReg.FormCreate(Sender: TObject);
begin
   Edit1.Text:=ExpandFileName('FFxProv.Dll');
end;

procedure TfrmReg.Button4Click(Sender: TObject);
begin
   OpenDialog1.FileName:= Edit1.Text;
   if not OpenDialog1.Execute then Exit;
   Edit1.Text:= OpenDialog1.FileName;
end;

procedure TfrmReg.Button2Click(Sender: TObject);
begin
   FileName:= Edit1.Text;
   if not FileExists(FileName) then Exit;
   RegType:= rtAxLib;
   RegAction:= raUnReg;
   DoRegistration;
   ShowMessage(SSuccessfulUnRegistration);
end;

procedure TfrmReg.Button3Click(Sender: TObject);
begin
   Close;
end;

end.