关于dll ( 积分: 50 )

如何把和数据库的连接模块写成DLL的形式（DATABASE SQLSEVER 2000） 要可以动态改变连接

如何把和数据库的连接模块写成DLL的形式（DATABASE SQLSEVER 2000） 要可以动态改变连接

在DLL中把连接模块定义成一个对象，然后用DLL导出对象的方法导出这个对象。

能说说怎样从DLL 中导出对象吗？谢了

用udl算了!

看看下面的iADO.dll

library IADO;
uses
SysUtils,
DB,
ADODB,
dbclient,
Provider,
activex;

Tobj = class
private
ADOConnection1: TADOConnection;
Q1: TADOQuery;
Q2: TADOQuery;
// CDS1: TClientDataSet;
DSP1: TDataSetProvider;
public
constructor CREATE();
destructor DESTROY;
override;
procedure OPENSQL(S: pchar);
procedure EXECSQL(S: string);
function GFI(S: string): INTEGER;
function GFS(S: pchar): pchar;
function savedat(dat: olevariant;
sTable: pchar): integer;
end;

var obj: Tobj;
function GETPYM(CH: pchar): pchar;
stdcall;
external 'imsg.dll' name 'getpym';
function GETSQLCONSTR(): PCHAR;
stdcall;
external 'imsg.dll' name 'getsqlconstr';
procedure msg(s: PCHAR);
stdcall;
external 'imsg.dll' name 'msg';
//procedure writefile(sFchar;schar);STDCALL;external 'IWriteFile.dll' name 'writefile';
function GETINIkey(IniFile: PCHAR;
MAINKEY: PCHAR;
SUBKEY: PCHAR): PCHAR;
stdcall;
external 'imsg.dll' name 'getinikey';
function TOBJ.GFI(S: string): INTEGER;
begin
if Q1.FIELDBYNAME(S).IsNull then
RESULT := 0
else
RESULT := Q1.FIELDBYNAME(S).ASINTEGER;
end;

function TOBJ.GFS(S: pchar): pchar;
begin
getmem(result, length(Q1.FIELDBYNAME(S).asstring) + 1);
if Q1.FIELDBYNAME(S).IsNull then
RESULT := ''
else
strcopy(RESULT, pchar(Q1.FIELDBYNAME(S).asstring));
end;

procedure TOBJ.OPENSQL(S: pchar);
begin
Q1.Close;
Q1.SQL.Clear;
Q1.SQL.Add(S);
Q1.Open;
end;

procedure TOBJ.EXECSQL(S: string);
begin
Q1.Close;
Q1.SQL.Clear;
Q1.SQL.Add(S);
Q1.ExecSQL;
end;

function isPrivate(lid: integer;
lPRIVILAGE: pchar): integer;
stdcall;
var sq: string;
begin
if obj = nil then
obj := Tobj.CREATE();
sq := 'select sp.被选择 FROM T_STAFF_PRIVILAGE sp,t_operator o,T_PRIVILAGE p ';
sq := sq + 'where o.i_id=' + inttostr(lID);
sq := sq + ' and p.名称=' + chr(39) + lPRIVILAGE + chr(39);
sq := sq + ' and o.角色ID=sp.角色ID';
sq := sq + ' and sp.权限ID=p.i_ID';
obj.OPENSQL(pchar(Sq));
if obj.q1.Eof then
begin
result := -1;
// '开发者，没有为' + s_privilige + '配角色、权力！！';
exit
end;
result := 0;
if obj.q1.fieldbyname('被选择').AsBoolean then
result := 1
end;

function getdat(lmainSQL: pchar): olevariant;
stdcall;
begin
if obj = nil then
begin
obj := Tobj.CREATE();
end;
obj.openSQL(lmainSQL);
result := OBJ.DSP1.DATA;
// obj.Free;
end;

function tobj.savedat(dat: olevariant;
sTable: pchar): integer;
var iErr: integer;
begin
// opensql('select * from '+sTable);
dsp1.ApplyUpdates(Dat, 0, iErr);
// dsp1.ResolveToDataSet:=true;
result := iErr;
end;

function savedat(sTable: pchar;
dat: olevariant): integer;
stdcall;
//var obj: Tobj;
begin
if obj = nil then
obj := Tobj.CREATE();
result := obj.savedat(Dat, sTable);
// obj.Free;
end;

function iseof(lmainSQL: pchar): boolean;
stdcall;
begin
result := true;
if obj = nil then
obj := Tobj.CREATE();
obj.OpenSQL(lmainSQL);
if not obj.q1.Eof then
result := false;
end;

procedure nEXECSQL(lmainSQL: pchar);
stdcall;
begin
if obj = nil then
obj := Tobj.CREATE();
obj.EXECSQL(lmainSQL);
end;

function GetID(lmainSQL: pchar): INTEGER;
stdcall;
begin
//这个函数是有要求的 select i_id as id
result := 0;
if obj = nil then
obj := Tobj.CREATE();
obj.OpenSQL(lmainSQL);
if not obj.q1.Eof then
result := OBJ.gfi('ID');
end;

function GetfI(lmainsql: pchar;
lfieldname: pchar): INTEGER;
stdcall;
begin
result := 0;
if obj = nil then
obj := Tobj.CREATE();
obj.OpenSQL(lmainSQL);
if not obj.q1.Eof then
result := OBJ.gfi(lfieldname);
end;

function Getfs(lmainsql: pchar;
lfieldname: pchar): pchar;
stdcall;
var s: string;
p: pchar;
begin
if obj = nil then
obj := Tobj.CREATE();
obj.OpenSQL(lmainSQL);
s := obj.Q1.FieldByName(lfieldname).AsString;
GetMem(result, length(s) + 1);
if not obj.q1.Eof then
strcopy(result, pchar(s))
else
strcopy(result, '');
end;


procedure init_date(var m: tmydate);
stdcall;
var s: string;
begin
if obj = nil then
obj := Tobj.CREATE();
s := ' select * from VIEW_Init_Date';
obj.OpenSQL('select * from VIEW_Init_Date');
m.today := obj.GFS('today');
m.tormorrow := obj.GFS('tormorrow');
m.yestoday := obj.GFS('yestoday');
m.thismonthfirstday := obj.GFS('thismonthfirstday');
m.thismonthlastday := obj.GFS('thismonthlastday');
m.nextmonthFirstday := obj.GFS('nextmonthFirstday');
m.YearFirstday := obj.GFS('YearFirstday');
end;

procedure auto_rebrush_py_code(
ltable: pchar;
lidField: pchar;
lfield: pchar;
lpyfield: pchar);
stdcall;
var s: string;
p: pchar;
begin
if obj = nil then
obj := Tobj.CREATE();
s := ' select ' + lidfield + ',' + lfield + ' from ' + ltable;
obj.OpenSQL(pchar(s));
while not obj.Q1.Eofdo
begin
s := obj.gfs(lfield);
if s <> '' then
begin
p := GETPYM(pchar(s));
s := 'update ' + ltable + ' set ' + lpyfield + '=' + chr(39) + p + chr(39) + ' where ' + lidfield + '=' + obj.GFS(lidfield);
obj.Q2.Close;
obj.Q2.SQL.Clear;
obj.Q2.SQL.Add(S);
obj.Q2.ExecSQL;
end;
obj.Q1.Next
end;
end;

constructor Tobj.CREATE();
begin

CoInitialize(nil);
ADOConnection1 := TADOConnection.Create(nil);
ADOConnection1.ConnectED := FALSE;
ADOConnection1.LoginPrompt := FALSE;
// ADOConnection1.ConnectionString :='Provider=SQLOLEDB.1;Persist Security Info=False;User ID=SA;Initial Catalog=PM;Data Source=.';// 聊天server 无法读出文件！ getsqlconstr();
// ADOConnection1.ConnectionString := getsqlconstr();
ADOConnection1.ConnectionString := getinikey('./NetUpdate.ini', '连接', 'constr');
Q1 := TADOQuery.Create(nil);
Q1.Connection := ADOConnection1;
Q2 := TADOQuery.Create(nil);
Q2.Connection := ADOConnection1;
DSP1 := TDataSetProvider.Create(nil);
DSP1.DataSet := Q1;
dsp1.Options := [poAllowMultiRecordUpdates];
// CDS1:= TClientDataSet.Create(NIL);
// CDS1.ProviderName :=DSP1;

if not ADOConnection1.Connected then
begin
ADOConnection1.Connected := TRUE;
end;

end;

destructor Tobj.DESTROY;
begin
couninitialize;
//coInitialize;
FreeAndNil(DSP1);
FreeAndNil(Q1);
FreeAndNil(Q2);
ADOConnection1.Connected:=false;
FreeAndNil(ADOConnection1);
// Initialize;
inherited;
end;

procedure CloseDBLink();
stdcall;
begin
if OBJ <> nil then
OBJ.Free;
end;

{$R *.res}
exports
getdat name 'getdat',
iseof name 'iseof',
getid name 'getid',
GetFI name 'getfi',
GetFS name 'getfs',
savedat name 'savedat',
CloseDBLink name 'closedblink',
isPrivate name 'isprivate',
nexecsql name 'nexecsql',
init_date name 'init_date',
auto_rebrush_py_code name 'auto_rebrush_py_code';
begin

end.

能把imsg.dll 解释一下吗？

可以啊
library IMSG;
uses windows, Classes, SysUtils, inifiles;
type TAPP = record
sName,
sVer,
sDeginer,
sEmail,
sTel,
sPath,
sDate,
sMemo,
sCaption,
sConStr: pchar;
end;
tlpapp = ^tapp;
function app_path(): pchar;
stdcall;
begin
getmem(result, 255);
strcopy(result, pchar(ExtractFilepath(paramstr(0))));
//也可以paramstr(0)
end;

procedure app_path2(p: pchar);
stdcall;
begin
strcopy(p, pchar(ExtractFilepath(paramstr(0))));
//也可以paramstr(0)
end;

function GETINIkey(IniFile: PCHAR;
MAINKEY: PCHAR;
SUBKEY: PCHAR): PCHAR;
stdcall;
//export;
var
myini: Tinifile;
s: string;
begin
// curpath:=extractfilepath(Application.exename);
Myini := TInifile.Create(IniFile);
// result := PCHAR(Myini.readString(mainkey, subkey, ''));
s := Myini.readString(mainkey, subkey, '');
getmem(result, length(s) + 1);
strcopy(result, pchar(s));
myini.Free;
end;

procedure writeINIkey(IniFile: PCHAR;
MAINKEY: PCHAR;
SUBKEY: PCHAR;
value: pchar);
stdcall;
//export;
var
myini: Tinifile;
begin
Myini := TInifile.Create(IniFile);
Myini.WriteString(mainkey, subkey, value);
myini.Free;
end;

function GETmdbCONSTR(): PCHAR;
stdcall;
//export;
var IniFile: PCHAR;
MAINKEY: PCHAR;
provider: PCHAR;
datasource: PCHAR;
s: string;
begin
IniFile := './config.ini';
MAINKEY := 'ACCES数据库连接';
provider := 'Provider';
datasource := 'Data Source';
s := '';
s := s + 'Provider=' + GETINIkey(IniFile, MAINKEY, provider);
s := s + ' data source=' + GETINIkey(IniFile, MAINKEY, datasource);
getmem(result, length(s) + 1);
strcopy(result, pchar(s));
end;

procedure MSG(S: PCHAR);
stdcall;
begin
// messagebox(0, s, '提示', mb_ok + MB_ICONASTERISK);
messagebox(GetActiveWindow(), s, '提示', mb_ok + MB_ICONASTERISK);
end;

function GETSQLCONSTR(): PCHAR;
stdcall;
//export;
var IniFile: PCHAR;
MAINKEY: PCHAR;
DbServerIP: PCHAR;
DBName: PCHAR;
USERID: PCHAR;
LogPass: PCHAR;
s: string;
begin
IniFile := './config.ini';
MAINKEY := 'sqlserver数据库连接';
DBSERVERIP := 'SQLCA_ServerName';
DBNAME := 'SQLCA_Database';
USERID := 'SQLCA_LogId';
LOGPASS := 'SQLCA_LogPass';
s := 'Provider=SQLOLEDB.1;Persist Security Info=False;Password=' + GETINIkey(IniFile, MAINKEY, LOGPASS) + ';User ID=' + GETINIkey(IniFile, MAINKEY, userID) + ';Initial Catalog=' + GETINIkey(IniFile, MAINKEY, dbname) + ';Data Source=' + GETINIkey(IniFile, MAINKEY, dbserverip);
// result := pchar('Provider=SQLOLEDB.1;Persist Security Info=False;User ID=' + GETINIkey(IniFile, MAINKEY, userID) + ';Initial Catalog=' + GETINIkey(IniFile, MAINKEY, dbname) + ';Data Source=' + GETINIkey(IniFile, MAINKEY, dbserverip));
getmem(result, 255);
if GETINIkey(IniFile, '访问', 'DB') = 'ACCESS' then
strcopy(result, GETmdbCONSTR())
else
strcopy(result, pchar(s));
end;

procedure app_INIT(var A: tapp);
stdcall;
var IniFile: PCHAR;
MAINKEY: PCHAR;
begin
IniFile := './config.ini';
mainkey := 'Application';
a.sName := '';
a.sVer := 'V 2.0';
a.sDeginer := '张世平';
a.sEmail := 'zsp586@sohu.com';
a.sTel := '13708782004';
a.sPath := app_path();
a.sDate := '2004-8-16';
a.sMemo := '--';
a.sCaption := GETINIkey(inifile, mainkey, 'sCaption');
a.sConStr := GETSQLCONSTR();
end;

procedure app_INIT_way2(A: tlpapp);
stdcall;
var IniFile: PCHAR;
MAINKEY: PCHAR;
begin
IniFile := './config.ini';
mainkey := 'Application';
with a^do
begin
sName := '';
sVer := 'V 2.0';
sDeginer := '张世平';
sEmail := 'zsp586@sohu.com';
sTel := '13708782004';
sPath := app_path();
sDate := '2004-8-16';
sMemo := '--';
sCaption := GETINIkey(inifile, mainkey, 'sCaption');
sConStr := GETSQLCONSTR();
end;

end;

function its(i: integer): pchar;
stdcall;
//inttostr
begin
result := pchar(inttostr(i));
end;

function sti(s: pchar): integer;
stdcall;
//strtoint
begin
result := strtoint(s);
end;


function Ask(s: pchar): boolean;
stdcall;
begin
result := false;
if messagebox(GetActiveWindow(), s, '提示', mb_YESNO + MB_ICONQUESTION) = idYes then
result := true;
end;

function Iif(mBool: Boolean;
mDataA, mDataB: Variant): Variant;
stdcall;
begin
if mBool then
Result := mDataA
else
Result := mDataB;
end;
{ Iif }

{* 获取本机的计算机名称}
function GetLocalName(): pchar;
stdcall;
var
CNameBuffer: PChar;
fl_loaded: Boolean;
CLen: ^DWord;
begin
GetMem(CNameBuffer, 255);
New(CLen);
CLen^ := 255;
fl_loaded := GetComputerName(CNameBuffer, CLen^);
if fl_loaded then
result := CNameBuffer
else
result := '未知';
// FreeMem(CNameBuffer, 255);
Dispose(CLen);
end;

function ISdate(STR: pchar): BOOLEAN;
stdcall;
begin
RESULT := TRUE;
try
strtodatetime(str);
except
result := false;
// Application.MessageBox('请输合法的日期数,格式:xxxx年xx月xx日', '提示信息', mb_iconerror);
end;
end;

//判断是否为整数
function ISInt(STR: pchar): BOOLEAN;
stdcall;
begin
RESULT := TRUE;
try
strtoint(str);
except
result := false;
// Application.MessageBox('请输入整型数!', '提示信息', mb_iconerror);
end;
end;

//判断是否为实数
function ISfloat(STR: pchar): BOOLEAN;
stdcall;
begin
RESULT := TRUE;
try
strtofloat(str);
except
RESULT := false;
// Application.MessageBox('请输入实型数!', '提示信息', mb_iconerror);
end;
end;

{计算每月天数}

procedure delay(ii: integer);
stdcall;
var
CT: LONGINT;
begin
CT := GETTICKCOUNT div 1000;
while ((GETTICKCOUNT div 1000) < (CT + ii))do
begin

end;

end;

procedure delayF(ii: integer);
var
CT: LONGINT;
begin
CT := GETTICKCOUNT;
while GETTICKCOUNT < (CT + II)do
begin

end;

end;

function RMB(NN: real): pchar;
var
HZ, NS, NW, NA, N1, N2: string;
LA, X, Nk: integer;
begin
if NN > 9999999999999.99 then
begin
// MSG('金额溢出.', mtError, [mbOk], 0);
messagebox(0, '金额溢出!', '提示', mb_ok + MB_ICONASTERISK);
HZ := '';
Result := pchar(HZ);
exit;
end;
if NN = 0 then
begin
HZ := '零元';
result := pchar(HZ);
exit;
end;
NS := '零壹贰叁肆伍陆柒捌玖';
NW := '分角元拾佰仟万拾佰仟亿拾佰仟万';
NN := StrToFloat(FormatFloat('0.00', NN));
//这句是经过网友jycjd调试得出的结果
NA := FloatToStr(NN * 100);
LA := length(NA);
X := 1;
HZ := '';
while X <= LAdo
begin
NK := Ord(NA[x]) - Ord('0');
N1 := Copy(NS, NK * 2 + 1, 2);
N2 := Copy(NW, LA * 2 + 1 - X * 2, 2);
if (NK = 0) and ((N2 = '亿') or (N2 = '万') or (N2 = '元')) then
begin
if copy(HZ, Length(HZ) - 1, 2) = '零' then
HZ := copy(HZ, 1, length(HZ) - 2);
if copy(HZ, Length(HZ) - 1, 2) = '亿' then
if N2 = '元' then
begin
N1 := N2;
N2 := '零';
end
else
N2 := ''
else
begin
N1 := N2;
N2 := '零';
end
end
else
if NK = 0 then
begin
if copy(HZ, length(HZ) - 1, 2) = '零' then
N1 := '';
if N2 = '分' then
begin
if copy(HZ, length(HZ) - 1, 2) = '零' then
HZ := copy(HZ, 1, length(HZ) - 2) + '整'
else
HZ := HZ + '整';
N1 := '';
end;
N2 := '';
end;
HZ := HZ + N1 + N2;
X := X + 1
end;
Result := pchar(HZ);
end;

{ 获取指定汉字的拼音索引字母，如：“汉”的索引字母是“H”.}
function GetPYIndexChar(hzchar: string): char;
begin
case WORD(hzchar[1]) shl 8 + WORD(hzchar[2]) of
$B0A1..$B0C4: result := 'A';
$B0C5..$B2C0: result := 'B';
$B2C1..$B4ED: result := 'C';
$B4EE..$B6E9: result := 'D';
$B6EA..$B7A1: result := 'E';
$B7A2..$B8C0: result := 'F';
$B8C1..$B9FD: result := 'G';
$B9FE..$BBF6: result := 'H';
$BBF7..$BFA5: result := 'J';
$BFA6..$C0AB: result := 'K';
$C0AC..$C2E7: result := 'L';
$C2E8..$C4C2: result := 'M';
$C4C3..$C5B5: result := 'N';
$C5B6..$C5BD: result := 'O';
$C5BE..$C6D9: result := 'P';
$C6DA..$C8BA: result := 'Q';
$C8BB..$C8F5: result := 'R';
$C8F6..$CBF9: result := 'S';
$CBFA..$CDD9: result := 'T';
$CDDA..$CEF3: result := 'W';
$CEF4..$D188: result := 'X';
$D1B9..$D4D0: result := 'Y';
$D4D1..$D7F9: result := 'Z';
else
result := char(32);
end;
end;

{返回字符窜的拼音码}
function GETPYM(CH: pchar): pchar;
stdcall;
var
I: Integer;
PY: string;
s: string;
begin
s := '';
I := 1;
while I <= Length(CH)do
begin
PY := Copy(CH, I, 1);
if PY >= Chr(128) then
begin
Inc(I);
PY := PY + Copy(CH, I, 1);
s := s + GetPYIndexChar(PY);
end
else
s := s + PY;
Inc(I);
end;
getmem(result, length(s) + 1);
strcopy(RESULT, pchar(s));
end;

function FiveZeroFormat(i: integer): pchar;
var j: integer;
s: string;
begin
j := length(trim(inttostr(i)));
s := '';
if j = 1 then
s := '0000' + trim(inttostr(i));
if j = 2 then
s := '000' + trim(inttostr(i));
if j = 3 then
s := '00' + trim(inttostr(i));
if j = 4 then
s := '0' + trim(inttostr(i));
if j = 5 then
s := trim(inttostr(i));
result := pchar(s);
end;

function myspace(s: pchar;
i: integer): pchar;
var j: integer;
ts: string;
begin
ts := '';
if i < 1 then
begin
result := '';
exit;
end;
if length(s) > i then
begin
result := '';
exit;
end;
for j := 0 to i - length(s)do
ts := ts + ' ';
result := pchar(ts);
end;


function CoCreateGuid(out guid: TGUID): HResult;
stdcall;
external 'ole32.dll' name 'CoCreateGuid';
function GetGuid(): pchar;STDCALL;
var x: tGUID;
S: string;
I: INTEGER;
begin
cocreateguid(x);
result :=pchar( GUIDToString(X));
end;

exports
writeINIkey name 'writeinikey',
GetLocalName name 'getlocalname',
iif name 'iif',
GETINIkey name 'getinikey',
getsqlconstr name 'getsqlconstr',
getmdbconstr name 'getmdbconstr',
app_init name 'app_init',
app_init_way2 name 'app_init_way2',
isint name 'isint',
app_path name 'app_path',
app_path2 name 'app_path2',
isfloat name 'isfloat',
isdate name 'isdate',
delay name 'delay',
MSG NAME 'msg',
ask name 'ask',
its name 'its',
sti name 'sti',
GETPYM name 'getpym',
GetGuid NAME 'GetGuid';
begin
end.