delphi 在Wise制作的安装程序中嵌入Interbase安装(下)|笨鱼技术网

public

function Install : boolean;

function PreCheck : boolean;

function GetErrorDescription(Error : MSG_NO) : string;

property WindowHandle : HWND read FHWND write FHWND;

property UninstallFile : string read FUninstallFile;

property Silent : boolean read FSilent write FSilent;

property StartAfterInstall : boolean read FStartAfterInstall write FStartAfterInstall;

property LastError : MSG_NO read FLastError;

property DestDirectory : string read FDestDirectory write FDestDirectory;

property SourceDirectory : string read FSourceDirectory write FSourceDirectory;

property IBInstallOptions : TIBInstallOptions read FIBInstallOptions write FIBInstallOptions;

property OnInstallError : TIBInstallError read FIBInstallError write FIBInstallError;

property OnInstallStatus : TIBInstallStatus read FIBInstallStatus write FIBInstallStatus;

end;

//—————————————————————————————————————————————————

procedure GetVariable(var DLLParams: ParamRec; const VarName: string; var VarValue: string); export;

procedure SetVariable(var DLLParams: ParamRec; const VarName: string; const NewValue: string); export;

function InstallInterbase(var DLLParams: ParamRec): LongBool; pascal; export;

function GetIBInstallDir(var DLLParams: ParamRec): LongBool; pascal; export;

var DLLHandle : HInst;

implementation

uses Registry, ErrorFormUnit, StatusFormUnit;

//——————————————————————————————————————————————————————————————————————————————

function FixPath(path : string) : string;

begin

if IsPathDelimiter(Path,length(path)) then result := path else result := path + '\';

end;

function GetFileVersion(filename : string; var VerBlk : VS_FIXEDFILEINFO) : boolean;

var InfoSize,puLen : DWord;

Pt,InfoPtr : Pointer;

begin

InfoSize := GetFileVersionInfoSize(PChar(filename),puLen);

fillchar(VerBlk,sizeof(VS_FIXEDFILEINFO),0);

if InfoSize > 0 then begin

GetMem(Pt,InfoSize);

GetFileVersionInfo(PChar(filename),0,InfoSize,Pt);

VerQueryValue(Pt,'\',InfoPtr,puLen);

move(InfoPtr^,VerBlk,sizeof(VS_FIXEDFILEINFO));

FreeMem(Pt);

result := true;

end else result := false;

end;

function IsNT : boolean;

var osv : TOSVERSIONINFO;

begin

fillchar(osv,sizeof(TOSVERSIONINFO),0);

osv.dwOSVersionInfoSize := sizeof(TOSVERSIONINFO);

GetVersionEx(osv);

if (osv.dwPlatformId = VER_PLATFORM_WIN32_NT) then result := true else result := false;

end;

function ServiceStart(sMachine, sService : string ) : boolean;

var schm, schs : SC_Handle;

ss : TServiceStatus;

psTemp : PChar;

dwChkP : DWord;

begin

ss.dwCurrentState := 0;

schm := OpenSCManager(PChar(sMachine),Nil,SC_MANAGER_CONNECT);

if(schm > 0)then begin

schs := OpenService(schm,PChar(sService),SERVICE_START or SERVICE_QUERY_STATUS);

if (schs > 0) then begin

psTemp := Nil;

if (StartService(schs,0,psTemp)) then begin

if (QueryServiceStatus(schs,ss)) then begin

while (SERVICE_RUNNING <> ss.dwCurrentState) do begin

dwChkP := ss.dwCheckPoint;

Sleep(ss.dwWaitHint);

if (not QueryServiceStatus(schs,ss)) then begin

break;

end;

if (ss.dwCheckPoint < dwChkP) then begin

break;

end;

CloseServiceHandle(schs);

end;

CloseServiceHandle(schm);

end;

Result := SERVICE_RUNNING = ss.dwCurrentState;

end;

function ServiceStop(sMachine, sService : string ) : boolean;

var schm, schs : SC_Handle;

ss : TServiceStatus;

dwChkP : DWord;

begin

schm := OpenSCManager(PChar(sMachine),Nil,SC_MANAGER_CONNECT);

if(schm > 0)then begin

schs := OpenService(schm,PChar(sService),SERVICE_STOP or SERVICE_QUERY_STATUS);

if(schs > 0)then begin

if (ControlService(schs,SERVICE_CONTROL_STOP,ss)) then begin

if (QueryServiceStatus(schs,ss)) then begin

while (SERVICE_STOPPED <> ss.dwCurrentState) do begin

dwChkP := ss.dwCheckPoint;

Sleep(ss.dwWaitHint);

if (not QueryServiceStatus(schs,ss))then begin

break;

end;

if (ss.dwCheckPoint < dwChkP) then begin

break;

end;

CloseServiceHandle(schs);

end;

CloseServiceHandle(schm);

end;

Result := (SERVICE_STOPPED = ss.dwCurrentState);

end;

function GetInterbaseServerDirectory : string;

var Filename : string;

Reg : TRegistry;

begin

Filename := '';

Reg := TRegistry.Create(KEY_READ);

try

Reg.RootKey := HKEY_LOCAL_MACHINE;

if Reg.KeyExists('Software\InterBase Corp\InterBase\CurrentVersion') then begin

if Reg.OpenKeyReadOnly('Software\InterBase Corp\InterBase\CurrentVersion') then begin

Filename := FixPath(Reg.ReadString('ServerDirectory'))+'ibguard.exe';

Reg.CloseKey;

end;

end else begin

if Reg.KeyExists('Software\Borland\InterBase\CurrentVersion') then begin

if Reg.OpenKeyReadOnly('Software\Borland\InterBase\CurrentVersion') then begin

Filename := FixPath(Reg.ReadString('ServerDirectory'))+'ibguard.exe';

Reg.CloseKey;

end;

finally

Reg.free;

end;

result := filename;

end;

//———————————————————————————————————————————————————————

procedure GetVariable(var DLLParams: ParamRec; const VarName: string; var VarValue: string);

var i: Integer;

szVarName: array[0..255] of char;

begin

VarValue := '';

szVarName[0] := '%';

StrPCopy(@szVarName[1],VarName);

StrCat(szVarName,'%');

for i := 0 to DLLParams.wCurrReps do begin

if (StrComp(szVarName,@DLLParams.szRepName[i * DLLParams.wRepNameWidth]) = 0) then begin

VarValue := StrPas(@DLLParams.szRepStr[i * DLLParams.wRepStrWidth]);

Exit;

end;

//————————————————————————————————————————————————————

procedure SetVariable(var DLLParams: ParamRec; const VarName: string; const NewValue: string);

var i: Integer;

szVarName: array[0..255] of char;

begin

szVarName[0] := '%';

StrPCopy(@szVarName[1],VarName);

StrCat(szVarName,'%');

for i := 0 to DLLParams.wCurrReps do begin

if (StrComp(szVarName,@DLLParams.szRepName[i * DLLParams.wRepNameWidth]) = 0) then begin

StrPCopy(@DLLParams.szRepStr[i * DLLParams.wRepStrWidth],NewValue);

Exit;

end;

StrCopy(@DLLParams.szRepName[DLLParams.wCurrReps * DLLParams.wRepNameWidth],szVarName);

StrPCopy(@DLLParams.szRepStr[DLLParams.wCurrReps * DLLParams.wRepStrWidth],NewValue);

DLLParams.wCurrReps := DLLParams.wCurrReps + 1;

end;

//————————————————————————————————————————————————————

function InterbaseVersion : cardinal;

var Filename : string;

fileinfo : VS_FIXEDFILEINFO;

begin

result := 0;

filename := GetInterbaseServerDirectory;

if FileExists(Filename) then begin

if GetFileVersion(filename,fileinfo) then begin

result := fileinfo.dwProductVersionMS;

end;

//—————————————————————————————————————————————————————

function InterbaseRunning : boolean;

begin

result := boolean(FindWindow('IB_Server','InterBase Server')

or FindWindow('IB_Guard','InterBase Guardian'));

end;

//—————————————————————————————————————————————————————

function ShutDownInterbase : boolean;

var IBSRVHandle,IBGARHandle : THandle;

begin

if IsNT then begin

ServiceStop('','InterBaseGuardian');

end else begin

IBGARHandle := FindWindow('IB_Guard','InterBase Guardian');

if IBGARHandle > 0 then begin

PostMessage(IBGARHandle,31,0,0);

PostMessage(IBGARHandle,16,0,0);

end;

IBSRVHandle := FindWindow('IB_Server','InterBase Server');

if IBSRVHandle > 0 then begin

PostMessage(IBSRVHandle,31,0,0);

PostMessage(IBSRVHandle,16,0,0);

end;

result := (boolean(FindWindow('IB_Server','InterBase Server')

or FindWindow('IB_Guard','InterBase Guardian')) = false);

end;

//—————————————————————————————————————————————————————

function StartInterbase : boolean;

var Filename : string;

begin

filename := GetInterbaseServerDirectory;

if FileExists(Filename) then begin

if IsNT then begin

ServiceStart('','InterBaseGuardian');

end else begin

WinExec(pchar(Filename),0);

end;

result := boolean(FindWindow('IB_Server','InterBase Server')

or FindWindow('IB_Guard','InterBase Guardian'));

end;

//—————————————————————————————————————————————————————

function InterbaseInstalled : boolean;

var Filename : string;

Running : boolean;

begin

Running := InterbaseRunning;

if Running = false then begin

filename := GetInterbaseServerDirectory;

if FileExists(Filename) then begin

result := true;

end else result := false;

end else result := true;

end;

//—————————————————————————————————————————————————————

function IBOptionsFromString(Str : String) : TIBInstallOptions;

begin

result := [];

if Str = '' then result := [opINTERBASE];

if (pos('A',Str) > 0) then result := result + [opIB_SERVER];

if (pos('B',Str) > 0) then result := result + [opIB_CLIENT];

if (pos('C',Str) > 0) then result := result + [opIB_CMD_TOOLS];

if (pos('D',Str) > 0) then result := result + [opIB_CMD_TOOLS_DB_MGMT];

if (pos('E',Str) > 0) then result := result + [opIB_CMD_TOOLS_USR_MGMT];

if (pos('F',Str) > 0) then result := result + [opIB_CMD_TOOLS_DB_QUERY];

if (pos('G',Str) > 0) then result := result + [opIB_GUI_TOOLS];

if (pos('H',Str) > 0) then result := result + [opIB_DOC];

if (pos('I',Str) > 0) then result := result + [opIB_EXAMPLES];

if (pos('J',Str) > 0) then result := result + [opIB_EXAMPLE_API];

if (pos('K',Str) > 0) then result := result + [opIB_EXAMPLE_DB];

if (pos('L',Str) > 0) then result := result + [opIB_DEV];

if (pos('M',Str) > 0) then result := result + [opIB_REPLICATION];

if (pos('N',Str) > 0) then result := result + [opIB_REPL_MANAGER];

if (pos('O',Str) > 0) then result := result + [opIB_REPL_SERVER];

if (pos('P',Str) > 0) then result := result + [opIB_CONNECTIVITY];

if (pos('Q',Str) > 0) then result := result + [opIB_ODBC_CLIENT];

if (pos('R',Str) > 0) then result := result + [opIB_JDBC];

if (pos('S',Str) > 0) then result := result + [opIB_JDBC_CLIENT];

if (pos('T',Str) > 0) then result := result + [opIB_JDBC_SERVER];

end;

//—————————————————————————————————————————————————————

// TIBWiseInstall class by Magnus Flysj? 2001

//—————————————————————————————————————————————————————

constructor TIBWiseInstall.Create;

var DestDir : TEXT;

DLLPath : pchar;

IBDLL : string;

begin

inherited Create;

OnInstallError := nil;

OnInstallStatus := nil;

GetMem(FIBHandle,4);

FIBHandle^ := 0;

FIBInstallOptions := [opINTERBASE];

FSourceDirectory := '';

FStartAfterInstall := false;

FUninstallFile := '';

FSilent := false;

IBDLL := '';

DLLPath := StrAlloc(255);

fillchar(DLLPath^,255,0);

try

GetModuleFilename(HInstance,DLLPath,255);

IBDLL := fixpath(ExtractFilePath(DLLPath)) + IB_INSTALL_DLL;

finally

StrDispose(DLLPath);

end;

FDLLInst := LoadLibrary(pchar(IBDLL));

if FDLLInst > 0 then begin

@Isc_install_clear_options := GetProcAddress(FDLLInst,'isc_install_clear_options');

@Isc_install_execute := GetProcAddress(FDLLInst,'isc_install_execute');

@Isc_install_get_info := GetProcAddress(FDLLInst,'isc_install_get_info');

@Isc_install_get_message := GetProcAddress(FDLLInst,'isc_install_get_message');

@Isc_install_load_external_text := GetProcAddress(FDLLInst,'isc_install_load_external_text');

@Isc_install_precheck := GetProcAddress(FDLLInst,'isc_install_precheck');

@Isc_install_set_option := GetProcAddress(FDLLInst,'isc_install_set_option');

@Isc_uninstall_execute := GetProcAddress(FDLLInst,'isc_uninstall_execute');

@Isc_uninstall_precheck := GetProcAddress(FDLLInst,'isc_uninstall_precheck');

@Isc_install_unset_option := GetProcAddress(FDLLInst,'isc_install_unset_option');

end else halt;

DestDir := StrAlloc(255);

fillchar(DestDir^,255,0);

try

if Assigned(isc_install_get_info) then begin

isc_install_get_info(isc_install_info_destination,0,DestDir,255);

FDestDirectory := DestDir;

end;

finally

StrDispose(DestDir);

end;

destructor TIBWiseInstall.Destroy;

begin

if FIBHandle^ <> 0 then isc_install_clear_options(FIBHandle);

FreeMem(FIBHandle,4);

if FDLLInst > 0 then FreeLibrary(FDLLInst);

inherited Destroy;

end;

function IB_FP_ERROR(msg: MSG_NO; data: Pointer; error_msg: TEXT): Integer; stdcall;

var IBWiseInstall : TIBWiseInstall;

Handled : boolean;

begin

Handled := true;

IBWiseInstall := TIBWiseInstall(data);

if Assigned(IBWiseInstall) then begin

if not IBWiseInstall.Silent then begin

if Assigned(IBWiseInstall.OnInstallError) then result := IBWiseInstall.OnInstallError(IBWiseInstall.FHWND,

IBWiseInstall,msg,Error_msg,Handled) else handled := false;

if handled = false then result := isc_install_fp_abort;

end else result := isc_install_fp_abort;

end;

function IB_FP_STATUS(status: integer; data: Pointer; const status_msg: TEXT): Integer; stdcall;

var IBWiseInstall : TIBWiseInstall;

begin

IBWiseInstall := TIBWiseInstall(data);

result := status;

if Assigned(IBWiseInstall) then begin

if not IBWiseInstall.Silent then begin

if Assigned(IBWiseInstall.OnInstallStatus) then

IBWiseInstall.OnInstallStatus(IBWiseInstall.FHWND,IBWiseInstall,Status,Status_Msg);

end;

procedure TIBWiseInstall.SetOptions;

begin

if Assigned(isc_install_clear_options) then isc_install_clear_options(FIBHandle);

if Assigned(isc_install_set_option) then begin

if (FIBInstallOptions = []) then isc_install_set_option(FIBHandle,INTERBASE);

if (opIB_SERVER in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_SERVER);

if (opIB_CLIENT in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_CLIENT);

if (opIB_CMD_TOOLS in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_CMD_TOOLS);

if (opIB_CMD_TOOLS_DB_MGMT in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_CMD_TOOLS_DB_MGMT);

if (opIB_CMD_TOOLS_USR_MGMT in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_CMD_TOOLS_USR_MGMT);

if (opIB_CMD_TOOLS_DB_QUERY in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_CMD_TOOLS_DB_QUERY);

if (opIB_GUI_TOOLS in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_GUI_TOOLS);

if (opIB_DOC in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_DOC);

if (opIB_EXAMPLES in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_EXAMPLES);

if (opIB_EXAMPLE_API in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_EXAMPLE_API);

if (opIB_EXAMPLE_DB in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_EXAMPLE_DB);

if (opIB_DEV in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_DEV);

if (opIB_REPLICATION in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_REPLICATION);

if (opIB_REPL_MANAGER in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_REPL_MANAGER);

if (opIB_REPL_SERVER in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_REPL_SERVER);

if (opIB_CONNECTIVITY in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_CONNECTIVITY);

if (opIB_ODBC_CLIENT in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_ODBC_CLIENT);

if (opIB_JDBC in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_JDBC);

if (opIB_JDBC_CLIENT in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_JDBC_CLIENT);

if (opIB_JDBC_SERVER in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_JDBC_SERVER);

end;

function TIBWiseInstall.PreCheck : boolean;

begin

SetOptions;

FLastError := isc_install_precheck(FIBHandle^,pchar(FSourceDirectory),pchar(FDestDirectory));

if FLastError > isc_install_success then result := false else result := true;

end;

function TIBWiseInstall.Install : boolean;

var UnIPFile : pchar;

begin

if InterbaseRunning then begin

FLastError := isc_install_server_running;

result := false;

end else begin

if PreCheck then begin

UnIPFile := StrAlloc(255);

try

Fillchar(UnIPFile^,255,0);

FLastError := isc_install_execute(FIBHandle^,pchar(FSourceDirectory),pchar(FDestDirectory),

@IB_FP_STATUS,self,@IB_FP_ERROR,self,UnIPFile);

if FLastError > isc_install_success then result := false else begin

FUninstallFile := UnIPFile;

result := true;

end;

if StartAfterInstall then StartInterbase;

finally

StrDispose(UnIPFile);

end;

end else result := false;

end;

function TIBWiseInstall.GetErrorDescription(Error : MSG_NO) : string;

var Msgtext : TEXT;

begin

Msgtext := StrAlloc(255);

Fillchar(Msgtext^,255,0);

try

isc_install_get_message(FIBHANDLE^,Error,Msgtext,255);

result := Msgtext;

finally

StrDispose(Msgtext);

end;

//——————————————————————————————————————————————————————

function IBInstallError(Handle : HWND; Caller : TIBWiseInstall; Msg: Longint;

Error_msg: string; var Handled : boolean) : integer;

var ErrMess : String;

ErrRes : integer;

Shwnd : HWND;

begin

if Assigned(StatusForm) then begin

if StatusForm.Visible then begin

Shwnd := StatusForm.Handle

end else Shwnd := Handle;

ErrMess := 'Database Installation Error '+inttostr(Msg)+#13#10+Error_msg;

ErrRes := MessageBox(Shwnd,Pchar(ErrMess),'Database Installation Error',MB_ICONERROR+MB_ABORTRETRYIGNORE);

result := isc_install_fp_abort;

Case ErrRes of

IDABORT: result := isc_install_fp_abort;

IDIGNORE: result := isc_install_fp_continue;

IDRETRY: result := isc_install_fp_retry;

end;

Handled := true;

end;

procedure IBInstallStatus(Handle : HWND; Caller : TIBWiseInstall; Status : integer; const Status_msg : string);

begin

if Assigned(StatusForm) then begin

StatusForm.Progress := Status;

StatusForm.Status := Status_msg;

StatusForm.BringToFront;

StatusForm.Show;

end;

//—————————————————————————————————————————————————————

// InstallIBServer returns IBStatus = 'Success' upon success otherwise it

// contains the error that ibinstall.dll reports.

//—————————————————————————————————————————————————————

unction InstallInterbase(var DLLParams: ParamRec): LongBool; pascal; export;

var IBWiseInstall : TIBWiseInstall;

IBInstallMode : string;

IBDestDirectory : string;

IBSourceDirectory : string;

IBOPTIONS : string;

IBStatus : string;

IBUninstallfile : string;

begin

IBWiseInstall := TIBWiseInstall.Create;

IBStatus := 'DLLError';

try

GetVariable(DLLParams,'IBINSTALLMODE',IBInstallMode);

GetVariable(DLLParams,'IBDESTDIR',IBDestDirectory);

GetVariable(DLLParams,'IBSRCDIR',IBSourceDirectory);

GetVariable(DLLParams,'IBOPTIONS',IBOPTIONS);

IBWiseInstall.WindowHandle := DLLParams.hMainWnd;

IBWiseInstall.IBInstallOptions := IBOptionsFromString(IBOPTIONS);

IBWiseInstall.Silent := (pos('S',IBInstallMode) > 0);

IBWiseInstall.StartAfterInstall := (pos('R',IBInstallMode) > 0);

if IBDestDirectory <> '' then IBWiseInstall.DestDirectory := IBDestDirectory;

IBWiseInstall.SourceDirectory := IBSourceDirectory;

IBWiseInstall.OnInstallError := IBInstallError;

IBWiseInstall.OnInstallStatus := IBInstallStatus;

StatusForm := TStatusForm.CreateParented(DLLParams.hMainWnd);

try

if IBWiseInstall.Install then begin

IBStatus := 'Success';

IBUninstallfile := IBWiseInstall.UninstallFile;

end else begin

IBStatus := IBWiseInstall.GetErrorDescription(IBWiseInstall.LastError);

end;

result := true;

except

result := false;

end;

finally

StatusForm.free;

end;

finally

SetVariable(DLLParams,'IBUIFILE',IBUninstallfile);

SetVariable(DLLParams,'IBSTATUS',IBStatus);

IBWiseInstall.free;

end;

function GetIBInstallDir(var DLLParams: ParamRec): LongBool; pascal; export;

var IBWiseInstall : TIBWiseInstall;

begin

IBWiseInstall := TIBWiseInstall.Create;

try

SetVariable(DLLParams,'IBDestDirectory',IBWiseInstall.DestDirectory);

result := true;

except

result := false;

end;

finally

IBWiseInstall.free;

end;

end.

--------------------------------------------------------------------------------

哪里有Interbase和其它更多信息？

关于WISE solutions公司的信息可以在WISE solutions公司的主页找到：

http://www.wisesolutions.com

Interbase可以免费从Borland Interbase主页下载：

http://www.borland.com/interbase/downloads/

其它关于Interbase的网页可以在这里找到：

http://www.borland.com/interbase/websites.html

更多关于IBINSTALL.DLL的API的信息可以在Interbase开发者文档中找到：

ftp://ftpc.inprise.com/pub/interbase/techpubs/ib_b60_doc.zip