DAO高手请进?(100分)

  • 主题发起人 主题发起人 zheng
  • 开始时间 开始时间
Z

zheng

Unregistered / Unconfirmed
GUEST, unregistred user!
怎样注册“DAO350.DLL”,我使用DAODataSet,需要DAO350.DLL中的数据库对象,
只是拷贝到系统目录没用,一定要安装,我想在我的程序中注册DAO350.DLL中的
数据库对象?
 
regsvr32 dao350.dll可以用么?
 
不能,本来应该可以,但就是不行,在自己的机子上就行,别人机就不行!
 
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}.
 
厉害,不过我的也能达到同样的效果,而且简单多了,
给你写出来看看:
unit URegDAO;

interface

uses
Windows, SysUtils, Forms, Classes, StdCtrls, Controls;

type
TRegDaoForm = class(TForm)
RegB: TButton;
UnRegB: TButton;
Label1: TLabel;
procedure UnRegBClick(Sender: TObject);
procedure RegBClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
RegDaoForm: TRegDaoForm;

implementation

{$R *.DFM}

var ProcessInformation: TProcessInformation; Atom: Integer;

procedure MyCreateProcess(Reg: Boolean);
var StartupInfo: TStartupInfo;
aSize: Integer;
ShortPath: Array [0..254] of Char;
CmdLinePChar: Array [0..254] of Char;
begin
GetShortPathName('C:/Program Files/Common Files/Microsoft Shared/DAO', ShortPath, 225); //只能包含目录,不能有文件名
if Reg then
StrPCopy(CmdLinePChar, 'regsvr32.exe ' + ShortPath + '/DAO350.DLL')
else
StrPCopy(CmdLinePChar, 'regsvr32.exe /u ' + ShortPath + '/DAO350.DLL');
aSize := SizeOf(TStartupInfo);
FillChar(StartupInfo, aSize, #0);
StartupInfo.CB := aSize;
StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
StartupInfo.wShowWindow := SW_HIDE;
CreateProcess(nil, CmdLinePChar, nil, nil, True, 0, nil, nil, StartupInfo,
ProcessInformation);
{WaitForSingleObject(ProcessInformation.hProcess, INFINITE);}
end;

procedure TRegDaoForm.UnRegBClick(Sender: TObject);
begin
if ProcessInformation.hProcess <> 0 then
TerminateProcess(ProcessInformation.hProcess, 0);
MyCreateProcess(False); //本来已调入内存,但不知为何还能成功删除
DeleteFile('C:/Program Files/Common Files/Microsoft Shared/DAO/DAO350.DLL'); //若要删除的文件还在调用(或在内存中),删除操作将失败
Application.MessageBox('DAO Object 取消注册成功!', '提示', MB_ICONINFORMATION + MB_OK);
end;

procedure TRegDaoForm.RegBClick(Sender: TObject);
var {FileAttr: TSecurityAttributes;
aSize: Integer;}
Path, ToPath: String;
begin
{aSize := SizeOf(TSecurityAttributes);
FillChar(FileAttr, aSize, #0);
FileAttr.nLength := aSize;
FileAttr.lpSecurityDescriptor :=
FileAttr.bInheritHandle :=
CreateDirectory('aaa', FileAttr); //用TSecurityAttributes错,但用PSecurityAttributes则前面错,两难
}
if ProcessInformation.hProcess <> 0 then
TerminateProcess(ProcessInformation.hProcess, 0);
Path := ExtractFilePath(ExpandFileName(ParamStr(0))) + 'DAO350.DLL'; //不用“/DAO350.DLL”
ToPath := 'C:/Program Files/Common Files/Microsoft Shared/DAO/' + 'DAO350.DLL';
CreateDir('C:/Program Files/Common Files/Microsoft Shared');
CreateDir('C:/Program Files/Common Files/Microsoft Shared/DAO');
CopyFile(PChar(Path), PChar(ToPath), True);
MyCreateProcess(True);
Application.MessageBox('DAO Object 注册成功!', '提示', MB_ICONINFORMATION + MB_OK);
end;

procedure TRegDaoForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if ProcessInformation.hProcess <> 0 then
TerminateProcess(ProcessInformation.hProcess, 0);
end;
end.
 
dyf:
怎样判断dao35是否已经安装!
 
zheng:如果还想接着讨论请定期提前自己的帖子,如果不想继续讨论请结束帖子。
 
多人接受答案了。
 
后退
顶部