unit DAO35Inst;
{==============================================================================}
interface
function InstallDAO( const tempDAOFolder: string; noRemove: boolean ): boolean;
{
This function installs all Jet/DAO DLLs it finds in the specified folder.
If the name of the folder starts with '$', the '$' is replaced by the
path of the folder the application was started from.
The DLLs are deleted after successful installation (or if they are outdated).
If the folder is empty after completion, the folder is removed also.
If you don't want the files removed, mark them as read-only.
NOTE: The correct syntax is '$|TempDAO'
}
{==============================================================================}
implementation
uses
Windows, SysUtils, FileCtrl,
Registry;
function InstallDAO( const tempDAOFolder: string; noRemove: boolean ): boolean;
var
temp,
winSys,
daoShare: string;
newShell: boolean;
function IsNewShell{}: boolean;
var
info: TOSVersionInfo;
begin
with info do begin
dwOSVersionInfoSize:= SizeOf(info);
Windows.GetVersionEx( info );
result:= (dwMajorVersion >= 4);
end {with info};
end {IsNewShell};
function OwnDir{}: string;
begin
SetLength( result, 255 );
Windows.GetModuleFileName( 0, pChar(result), 255 );
SetLength( result, StrLen(pChar(result)) );
result:= ExtractFilePath( result );
if result[Length(result)] = '/' then Delete( result, Length(result), 1 );
end {OwnDir};
function WindowsDir{}: string;
begin
SetLength( result, 255 );
Windows.GetWindowsDirectory( pChar(result), 255 );
SetLength( result, StrLen(pChar(result)) );
end {WindowsDir};
function WindowsSystemDir{}: string;
begin
SetLength( result, 255 );
Windows.GetSystemDirectory( pChar(result), 255 );
SetLength( result, StrLen(pChar(result)) );
end {WindowsSystemDir};
function CommonFilesDir{}: string;
begin
with TRegistry.Create do try
RootKey:= HKey_Local_Machine;
if OpenKey( 'Software/Microsoft/Windows/CurrentVersion', True ) then begin
if ValueExists( 'CommonFilesDir' ) then begin
result:= ReadString( 'CommonFilesDir' );
end else begin
// NOTE for D2/ D3 users: WriteString has a bug in Borland's implementation.
// Correct it to:
//
// begin
// PutData(Name, PChar(Value), Length(Value) + 1, rdString);
// end; ^^^^^
//
// This way the zero-termination is correctly passed to the
// Windows registry function.
result:= Copy(WindowsDir{},1,2) + '/Program Files/Common Files';
WriteString( 'CommonFilesDir', result );
end;
end;
finally Free end {with TRegistry};
end {CommonFilesDir};
function CopyDLL( const name, src, dst: string; forcePath, retry: boolean ): boolean;
var
temp: string;
tempLen: uint;
cur: string;
curLen: uint;
dest: string;
destLen: uint;
res: dword;
causes: string;
procedure AddCause( flag: dword; const msg: string );
begin
if (flag AND res) <> 0 then begin
if causes <> '' then causes:= causes + #13#10;
causes:= causes + msg;
end;
end {AddCause};
var
opt: dword;
begin {CopyDLL}
result:= FileExists( src + '/' + name );
if not result then Exit;
ForceDirectories( dst );
{ find file }
SetLength( cur, 255 );
curLen:= 255;
SetLength( dest, 255 );
destLen:= 255;
VerFindFile( VFFF_IsSharedFile,
pChar(name),
pChar(WindowsDir{}),
pChar(dst),
pChar(cur),
curLen,
pChar(dest),
destLen );
SetLength( cur, curLen );
SetLength( dest, destLen );
if forcePath then dest:= dst;
{ install file }
opt:= 0;
SetLength( temp, 255 );
tempLen:= 255;
res:= 0;
try
repeat
res:= Windows.VerInstallFile( opt,
pChar(name),
pChar(name),
pChar(src),
pChar(dest),
pChar(cur),
pChar(temp),
tempLen );
SetLength( temp, tempLen );
result:= (res = 0) or not retry;
if result then Break;
causes:= '';
AddCause( VIF_SrcOld, 'The new file is older than the existing file.' );
AddCause( VIF_DiffLang, 'The new file is in another language than the existing file.' );
AddCause( VIF_DiffLang, 'The new file supports a different code page than the existing file.' );
AddCause( VIF_DiffLang, 'The new file is for a different type of system than the existing file.' );
AddCause( VIF_DiffLang, 'The new file is in another language than the existing file.' );
AddCause( VIF_WriteProt, 'The existing file is write-protected.' );
AddCause( VIF_FileInUse, 'The existing file in use. Close other applications and try again.' );
AddCause( VIF_OutOfSpace, 'There is not enough free space on the target drive.' );
AddCause( VIF_AccessViolation, 'The existing file is in use, or you do not have sufficient access rights.' );
AddCause( VIF_SharingViolation, 'There was a sharing problem while performing the installation.' );
AddCause( VIF_CannotCreate, 'There was a problem creating the file.' );
AddCause( VIF_CannotDelete, 'There was a problem deleting the file.' );
AddCause( VIF_CannotRename, 'There was a problem renaming the file.' );
AddCause( VIF_CannotDeleteCur, 'There was a problem deleting the current version of the file.' );
AddCause( VIF_OutOfMemory, 'Out of memory.' );
AddCause( VIF_CannotReadSrc, 'There was a problem reading the new file.' );
AddCause( VIF_CannotReadDst, 'There was a problem reading the existing file.' );
AddCause( VIF_BuffTooSmall, 'A buffer is too small.' );
if causes = '' then causes:= 'General error.';
case Windows.MessageBox( 0
, pChar( 'There is a problem with the installation of ' + name + ':'
+ #13#10
+ #13#10 + causes )
, 'Microsoft Jet Engine Installation'
, MB_AbortRetryIgnore OR MB_IconWarning )
of
IDRetry: opt:= VIFF_ForceInstall;
IDIgnore: Break;
IDAbort: Abort;
end;
until False;
finally
if (res AND VIF_TempFile) <> 0 then DeleteFile( temp );
end;
end {CopyDLL};
procedure RegisterDLL( const path: string );
type
aDLLReg = procedure; stdcall;
var
hMod: HModule;
dllReg: aDLLReg;
begin
hMod:= LoadLibrary( pChar(path) );
if hMod <> 0 then try
dllReg:= aDLLReg( GetProcAddress( hMod, 'DllRegisterServer' ));
if Assigned(dllReg) then begin
dllReg;
end;
finally
FreeLibrary( hMod );
end;
end {RegisterDLL};
procedure RemoveDLL( const name: string );
begin
try
if not noRemove then DeleteFile( temp + '/' + name );
except end;
end {RemoveDLL};
procedure InstallSystem( const name: string; retry: boolean );
var
path: string;
begin
if CopyDLL( name, temp, winSys, False, retry ) then begin
path:= winSys + '/' + name;
if CompareText( ExtractFileExt( name ), '.dll' ) = 0
then RegisterDLL( name );
RemoveDLL( name );
end {if copied};
end {InstallSystem};
procedure InstallDAO( const name: string; retry: boolean );
var
path: string;
begin
if CopyDLL( name, temp, daoShare, True, retry ) then begin
path:= daoShare + '/' + name;
if CompareText( ExtractFileExt( path ), '.dll' ) = 0
then RegisterDLL( path );
with TRegistry.Create do try
RootKey:= HKey_Local_Machine;
if OpenKey( 'Software/Microsoft/Windows/CurrentVersion/SharedDlls', True ) then begin
if ValueExists( path )
then WriteInteger( path, ReadInteger( path ) + 1 )
else WriteInteger( path, 1 );
end;
finally Free end {with TRegistry};
RemoveDLL( name );
end {if copied};
end {InstallDAO};
begin {InstallDAO}
try
{ determine folders }
temp:= tempDAOFolder;
if temp[1] = '$' then temp:= OwnDir{} + Copy( temp,2,255 );
winSys:= WindowsSystemDir{};
newShell:= IsNewShell{};
if newShell
then daoShare:= CommonFilesDir{} + '/Microsoft Shared/DAO'
else daoShare:= WindowsDir{} + '/MSApps/DAO';
{ install core DLLs }
InstallSystem( 'MSVCRT40.dll', False ); // C runtime
InstallSystem( 'MSVCRT.dll', False ); // C runtime
InstallSystem( 'MSVCIRT.dll', False ); // C runtime
InstallSystem( 'VBAR332.dll', True ); // VBA runtime
InstallSystem( 'MSJet35.dll', True ); // Jet engine 3.5
InstallSystem( 'MSRd2x35.dll', True ); // Jet 2.x driver
InstallSystem( 'MSJInt35.dll', True ); // Localized error msgs
InstallSystem( 'MSJtEr35.dll', True ); // Error msgs
InstallSystem( 'VBAJet32.dll', True ); // VBA-Jet expression service bootstrap
InstallDAO( 'DAO350.dll', True ); // DAO 3.5
InstallDAO( 'DAO2535.tlb', True ); // DAO 3.5
{ install replication }
InstallSystem( 'MSRepl35.dll', True ); // Replication
{ install data driver DLLs }
InstallSystem( 'MSXbse35.dll', True ); // xBase driver
//InstallSystem( 'MSPdox35.dll', True ); // Paradox driver
InstallSystem( 'MSText35.dll', True ); // Text driver
InstallSystem( 'MSExcl35.dll', True ); // Excel driver
InstallSystem( 'MSLtus35.dll', True ); // Lotus 1-2-3 driver
InstallSystem( 'MSExch35.dll', True ); // Exchange driver
{ install RDO files }
InstallSystem( 'MSRDO20.dll', True ); // RDO Library
InstallSystem( 'RDOCurs.dll', True ); // RDO Batch Client Cursors
RemoveDir( temp );
result:= True;
except
result:= False;
end;
end {InstallDAO};
end {DAOInst}.