isParadox:=(pos('.db',tempTableName)>0) and (tempTableName[length(tempTableName)]='b');
isDbase:=pos('.dbf',tempTableName)>0;
end
else
begin
isParadox:=TableType=ttParadox;
isDbase:=TableType=ttDbase;
end;
if isparadox or isDbase then
begin
bExclusive:=Exclusive;
bActive:=Active;
DisableControls;
// Close;
Exculsive:=true;
end
else
begin
StatusMsg:='无效的数据表类型。';
Exit;
end;
if isParadox then
begin
if wwMemAvail(Sizeof(CRTblDesc)) then
begin
StatusMsg:='内存不足，压缩表失败。';
end
else
begin
GetMem(pTblDesc,Sizeof(CRTblDesc));
fillchar(pTblDesc^,Sizeof(CRTblDesc),0);
with pTblDesc^ do
begin
strCopy(szTblName,Tablename);
strCopy(szTblType,szParadox);
Active:=True;
Check(DbiGetCursorProps(handle,Props));//检测是否右口令保护
bProtected:=props.bProtected;
Active:=False;
bPack:=True;
end;
Screen.Cursor:=crHourGlass;
SetDBFlag(dbfOpened,True);
rslt:=DBIdoRestructure(DBHandle,1,pTblDesc,nil,nil,nil,False);
if rslt<>DBIERR_NONE then
begin
DBiGetErrorString(rslt,SzErrMsg);
StatusMsg:=SzErrMsg;
end
else
Result:=True;
SetDBFlag(dbfOpened,False);
FreeMem(pTblDesc,Sizeof(CRTlDesc));
Screen.Cursor:=crDefault;
end;
end
else
if isDbase then
begin
Screen.Cursor:=crHourGlass;
OPen;
rslt:=dbiPacktable(DBHandle,Handle,nil,nil,True);
Screen.Cursor:=crDefault;
if rslt<>DBIERR_NONE then
begin
DBiGetERRorString(rslt,szErrMsg);
StatusMSg:=SzErrMsg;
end
else
Result:=True;
end;
Close;
Exculsive:=bExclusive;
Active:=bActive;
EnableControls;
end;}
{procedure CompactDb(DbName, NewDbName: string);
var
dao: OLEVariant;
begin
dao := CreateOleObject('DAO.DBEngine.35');
dao.CompactDatabase(DbName, NewDbName);
end;}
//修复Access表
procedure RepairDb(DbName: string);
var
Dao: OLEVariant;
begin
Dao := CreateOleObject('DAO.DBEngine.35');
Dao.RepairDatabase(DbName);
end;
//通过注册表创建ODBC配置[创建在系统DSN页下]
function CreateODBCCfgInRegistry(ODBCSourceName:WideString; ServerName, DataBaseDescription:String):boolean;
var
Reg: TRegistry;
LPT_systemDir:array [1..255] of char;
P:Pchar;
DriverString:String;
begin
Reg := TRegistry.Create;
Reg.RootKey := HKEY_LOCAL_MACHINE;
try
try
if not Reg.KeyExists('\Software\ODBC\ODBC.INI\'+trim(ODBCSourceName)) then
begin
//创建并打开主键。
if Reg.OpenKey('\Software\ODBC\ODBC.INI\'+trim(ODBCSourceName),True) then
begin
//写入键值
Reg.WriteString('DataBase', ODBCSourceName);
Reg.WriteString('Description',Trim(DataBaseDescription));
GetSystemDirectory(@LPT_systemDir,255) ;
P:=@LPT_systemDir;
DriverString:=StrCat(P,Pchar('\SQLSRV32.DLL')) ;
Reg.WriteString('Driver', DriverString);
Reg.WriteString('LastUser', 'Administrator');
Reg.WriteString('Server', trim(ServerName));
Reg.WriteString('Trusted_Connection', 'Yes');
reg.CloseKey;
end;
//加入ODBCDataSource
if Reg.OpenKey('\Software\ODBC\ODBC.INI\ODBC Data Sources\',True) then
begin
Reg.DeleteValue(ODBCSourceName);
Reg.WriteString(ODBCSourceName, 'SQL Server');
Reg.CloseKey;
end;
end;
Result:=True;
except
Result:=False;
end;
finally
Reg.Free;
end;
end;
function ADOConnectSysBase(Const Adocon:TadoConnection):boolean;
{* 用Ado连接SysBase数据库函数}
begin
with Adocon do
begin
Close;
LoginPrompt:=False; //若数据库不存在时，进行判断。。。。。。
ConnectionString:='Provider=MSDASQL.1;'+
'Password="";'+
'Persist Security Info=True;'+
'Data Source=Sy_Finalact';
try
KeepConnection:=True;
Screen.Cursor:=crHourGlass;
Connected:=True;
Open;
Screen.Cursor:=crDefault;
ADOConnectSysBase:=True;
except
ADOConnectSysBase:=False;
end;
end;
end;
//Ado连接数据库函数
function ADOConnectLocalDB(Const Adocon:TAdoConnection;Const Dbname,DBServerName:String;ValidateMode:Integer):boolean;
begin
with Adocon do
begin
Close;
LoginPrompt:=False; //若数据库不存在时，进行判断。。。。。。
if ValidateMode=0 then//使用Windows NT验证模式
ConnectionString:='Provider=SQLOLEDB.1;'+
'Password="";'+
'Integrated Security=SSPI;'+ //集成安全
'Persist Security Info=False;'+
'User ID=sa;Initial Catalog='+''''+dbname+''''+';'+
'Data Source='+''''+DBServerName+'''';
if ValidateMode=1 then//使用SQL SERVER验证模式
ConnectionString:='Provider=SQLOLEDB.1;'+
'Password="";'+
'Persist Security Info=True;'+
'User ID=sa;Initial Catalog='+''''+Dbname+''''+';'+
'Data Source='+''''+DBServerName+'''';
try
KeepConnection:=True;
Screen.Cursor:=crHourGlass;
Connected:=True;
Open;
Screen.Cursor:=crDefault;
ADOConnectLocalDB:=True;
except
ADOConnectLocalDB:=False;
end;
end;
end;
//Ado与ODBC共同连接数据库函数
function ADOODBCConnectLocalDB(Const Adocon:TAdoConnection;Const Dbname:String;ValidateMode:Integer):boolean;
begin
with Adocon do
begin
Close;
LoginPrompt:=False; //若数据库不存在时，进行判断。。。。。。
if ValidateMode=0 then//使用Windows NT验证模式
ConnectionString:='Provider=MSDASQL.1;'+
'Password="";'+
'Persist Security Info=False;'+
'User ID=sa;Data Source='+''''+DBName+''''+';'+
'Initial Catalog='+''''+DBname+'''';
if ValidateMode=1 then//使用SQL SERVER验证模式
ConnectionString:='Provider=MSDASQL.1;'+
'Password="";'+
'Persist Security Info=True;'+
'User ID=sa;Data Source='+''''+DBName+''''+';'+
'Initial Catalog='+''''+DBname+'''';
try
KeepConnection:=True;
Screen.Cursor:=crHourGlass;
Connected:=True;
Open;
Screen.Cursor:=crDefault;
ADOODBCConnectLocalDB:=True;
except
ADOODBCConnectLocalDB:=False;
end;
end;
end;
///在指定的数据库中建立表
function CreatTable(LpDataBaseName,LpTableName,LpSentence:string):Boolean;//建立新表
Var
CreatTableQuery:TQuery;
SQLsentence:string;
Successed:Boolean;//成功否
begin
Successed:=False;
SQLsentence:='CREATE TABLE "'+ LpTableName +'" ' + LpSentence;
CreatTableQuery:=TQuery.Create(nil);
try
try
with CreatTableQuery do
begin
UniDirectional:=True;
Active:=False;
Sql.Clear;
DataBaseName := LpDataBaseName; //数据库名
Sql.Add(SQLsentence);
ExecSQL;
Successed:=True;
end;
except
MessageBox(Application.Handle,Pchar(' 在建立数据库 '+Trim(LpDataBaseName)+' 中的 '+Trim(LpTableName)+' 表出错，建立未能成功 ！'),'建立失败',0+16);
Successed:=False;
end;
finally
CreatTableQuery.Free;//释放建立的Query
if Successed then
Result:=True//建立成功
else
Result:=False;//建立失败
end;
end;
//在指定的表中新填字段
function AddField(LpFieldName:string; LpDataType: TFieldType; LpSize: Word):string;//建立新表
var
Sentence,SQLsentence : string;
begin
Sentence:= '';
SQLsentence:='';
if LpFieldName = '' then
raise EDBUpdateErr.Create('字段名不能为空');
if Pos(' ', LpFieldName) <> 0 then
raise EDBUpdateErr.Create('字段名中不能含有空格字符');
if LpDataType = ftString then
sentence := 'ADD '+LpFieldName+' Char('+ IntToStr( LpSize ) + ')';
if LpDataType = ftInteger then
sentence := 'ADD '+LpFieldName+' Integer';
if LpDataType = ftSmallInt then
sentence := 'ADD '+LpFieldName+' SmallInt';
if LpDataType = ftFloat then
sentence := 'ADD '+LpFieldName+' Float('+ IntToStr( LpSize ) +',0)';
if LpDataType = ftDate then
sentence := 'ADD '+LpFieldName+' Date';
if LpDataType = ftTime then
sentence := 'ADD '+LpFieldName+' Time';
if LpDataType = ftDateTime then
sentence := 'ADD '+LpFieldName+' TimeStamp';
if sentence = '' then
raise EDBUpdateErr.Create('无效的字段类型');
if SQLSentence = '' then
SQLSentence := sentence
else
SQLSentence := SQLSentence + ', ' + sentence;
Result:=SQLSentence;//返回SQL句体
end;
//在指定的表中删除字段
function KillField(LpFieldName:string):String;//删除表中的字段
var
SQLsentence : string;
begin
if LpFieldName = '' then
raise EDBUpdateErr.Create('字段名不能为空');
if Pos(' ', LpFieldName) <> 0 then
raise EDBUpdateErr.Create('字段名中不能含有空格字符');
if SQLSentence = '' then
SQLSentence := 'DROP COLUMN ' + LpFieldName
else
SQLSentence := SQLSentence + ', DROP ' + LpFieldName;
Result:=SQLSentence;
end;
//修改表结构的SQL语句执行体
function AlterTableExec(LpDataBaseName,LpSentence:string):Boolean;//修改表结构
var
AlterQueryTable:TQuery;
Successed:Boolean;//成功否
begin
Successed:=False;
AlterQueryTable:= TQuery.Create(nil);
try
try
with AlterQueryTable do
begin
DataBaseName:=LpDataBaseName;//数据库名
UniDirectional:=True;
Active:=False;
Sql.Clear;
Sql.Add(LpSentence);
ExecSQL;
Successed:=True;
end;
except
Successed:=False;
end;
finally
AlterQueryTable.Free;
if successed then
Result:=True
else
Result:=False;
end;
end;
//修改、添加、删除表结构时的SQL句体
function GetSQLSentence(LpTableName,LpSQLsentence:string): string;
begin
Result := 'ALTER TABLE "'+ LpTableName +'" ' + LpSQLSentence + ';';
end;
//▎============================================================▎//
//▎======================⑾进制函数及过程======================▎//
//▎============================================================▎//
//字符转化成十六进制
function StrToHex(AStr: string): string;
var
I : Integer;
// Tmp: string;
begin
Result := '';
For I := 1 to Length(AStr) do
begin
Result := Result + Format('%2x', [Byte(AStr[I])]);
end;
I := Pos(' ', Result);
While I <> 0 do
begin
Result[I] := '0';
I := Pos(' ', Result);
end;
end;
//十六进制转化成字符
function HexToStr(AStr: string): string;
var
I : Integer;
CharValue: Word;
begin
Result := '';
for I := 1 to Trunc(Length(Astr)/2) do
begin
Result := Result + ' ';
CharValue := TransChar(AStr[2*I-1])*16 + TransChar(AStr[2*I]);
Result[I] := Char(CharValue);
end;
end;
function TransChar(AChar: Char): Integer;
begin
if AChar in ['0'..'9'] then
Result := Ord(AChar) - Ord('0')
else
Result := 10 + Ord(AChar) - Ord('A');
end;
//▎============================================================▎//
//▎=====================⑿其它函数及过程=======================▎//
//▎============================================================▎//
// 输出限制在Min..Max之间
function TrimInt(Value, Min, Max: Integer): Integer; overload;
begin
if Value > Max then
Result := Max
else if Value < Min then
Result := Min
else
Result := Value;
end;
// 输出限制在0..255之间
function IntToByte(Value: Integer): Byte; overload;
asm
OR EAX, EAX
JNS @@Positive
XOR EAX, EAX
RET
@@Positive:
CMP EAX, 255
JBE @@OK
MOV EAX, 255
@@OK:
end;
// 由TRect分离出坐标、宽高
procedure DeRect(Rect: TRect; var x, y, Width, Height: Integer);
begin
x := Rect.Left;
y := Rect.Top;
Width := Rect.Right - Rect.Left;
Height := Rect.Bottom - Rect.Top;
end;
// 比较两个Rect
function RectEqu(Rect1, Rect2: TRect): Boolean;
begin
Result := (Rect1.Left = Rect2.Left) and (Rect1.Top = Rect2.Top) and
(Rect1.Right = Rect2.Right) and (Rect1.Bottom = Rect2.Bottom);
end;
// 产生TSize类型
function EnSize(cx, cy: Integer): TSize;
begin
Result.cx := cx;
Result.cy := cy;
end;
// 计算Rect的宽度
function RectWidth(Rect: TRect): Integer;
begin
Result := Rect.Right - Rect.Left;
end;
// 计算Rect的高度
function RectHeight(Rect: TRect): Integer;
begin
Result := Rect.Bottom - Rect.Top;
end;
// 判断范围
function InBound(Value: Integer; Min, Max: Integer): Boolean;
begin
Result := (Value >= Min) and (Value <= Max);
end;
// 交换两个数
procedure CnSwap(var A, B: Byte); overload;
var
Tmp: Byte;
begin
Tmp := A;
A := B;
B := Tmp;
end;
procedure CnSwap(var A, B: Integer); overload;
var
Tmp: Integer;
begin
Tmp := A;
A := B;
B := Tmp;
end;
procedure CnSwap(var A, B: Single); overload;
var
Tmp: Single;
begin
Tmp := A;
A := B;
B := Tmp;
end;
procedure CnSwap(var A, B: Double); overload;
var
Tmp: Double;
begin
Tmp := A;
A := B;
B := Tmp;
end;
// 延时
procedure Delay(const uDelay: DWORD);
var
n: DWORD;
begin
n := GetTickCount;
while ((GetTickCount - n) <= uDelay) do
Application.ProcessMessages;
end;
// 在Win9X下让喇叭发声
procedure BeepEx(const Freq: WORD = 1200; const Delay: WORD = 1);
const
FREQ_SCALE = 93180;
var
Temp: WORD;
begin
Temp := FREQ_SCALE div Freq;
asm
in al,61h;
or al,3;
out 61h,al;
mov al,$b6;
out 43h,al;
mov ax,temp;
out 42h,al;
mov al,ah;
out 42h,al;
end;
Sleep(Delay);
asm
in al,;
and al,$fc;
out ,al;
end;
end;
// 显示Win32 Api运行结果信息
procedure ShowLastError;
var
ErrNo: Integer;
Buf: array[0..255] of Char;
begin
ErrNo := GetLastError;
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, ErrNo, 0, Buf, 255, nil);
if Buf = '' then StrCopy(@Buf, PChar(SUnknowError));
MessageBox(Application.Handle, PChar(string(Buf) + #10#13 +
SErrorCode + IntToStr(ErrNo)),
SCnInformation, MB_OK + MB_ICONINFORMATION);
end;
//将字体Font.Style写入INI文件
function writeFontStyle(FS: TFontStyles; inifile: string; write: boolean):string;
var
Mystyle : string;
Myini : Tinifile;
begin
Mystyle := '[';
if fsBold in FS then MyStyle := MyStyle + 'fsBold';
if fsItalic in FS then
if MyStyle = '[' then
MyStyle := MyStyle + 'fsItalic'
else
MyStyle := MyStyle + ',fsItalic';
if fsUnderline in FS then
if MyStyle = '[' then
MyStyle := MyStyle + 'fsUnderline'
else
MyStyle := MyStyle + ',fsUnderline';
if fsStrikeOut in FS then
if MyStyle = '[' then
MyStyle := MyStyle + 'fsStrikeOut'
else
MyStyle := MyStyle + ',fsStrikeOut';
MyStyle := MyStyle + ']';
if write then
begin
Myini := TInifile.Create(inifile);
Myini.WriteString('FontStyle', 'style', MyStyle);
Myini.free;
end;
Result := MyStyle;
end;
//从INI文件中读取字体Font.Style文件
function readFontStyle(inifile: string): TFontStyles;
var
MyFontStyle : TFontStyles;
MyStyle : string;
Myini : Tinifile;
begin
MyFontStyle := [];
Myini := TInifile.Create(inifile);
Mystyle := Myini.ReadString('Fontstyle', 'style', '[]');
if pos('fsBold', Mystyle) > 0 then MyFontStyle := MyFontStyle + [fsBold];
if Pos('fsItalic', MyStyle) > 0 then MyFontStyle := MyFontStyle + [fsItalic];
if Pos('fsUnderline', MyStyle) > 0 then
MyFontStyle := MyFontStyle + [fsUnderline];
if Pos('fsStrikeOut', MyStyle) > 0 then
MyFontStyle := MyFontStyle + [fsStrikeOut];
MyIni.free;
Result := MyFontStyle;
end;
//*取得TMemo 控件当前光标的行和列信息到Tpoint中
//function ReadCursorPos(SourceMemo: TMemo): TPoint;
function ReadCursorPos(SourceMemo: TMemo): string;
var
// Point: TPoint;
X,Y:integer;
begin
// point.y := SendMessage(SourceMemo.Handle, EM_LINEFROMCHAR,SourceMemo.SelStart,0);
// point.x := SourceMemo.SelStart- SendMessage(SourceMemo.Handle,EM_LINEINDEX,point.y,0);
y := SendMessage(SourceMemo.Handle, EM_LINEFROMCHAR,SourceMemo.SelStart,0);
x := SourceMemo.SelStart- SendMessage(SourceMemo.Handle,EM_LINEINDEX,y,0);
Result := '行:'+inttostr(y+1)+' '+'列:'+inttostr(x+1);
end;
//*检查Tmemo控件能否Undo功能
function CanUndo(AMemo: TMemo): Boolean;
begin
Result :=AMemo.Perform(EM_CANUNDO, 0, 0)<>0;
end;
//* 实现Undo功能
procedure Undo(Amemo: Tmemo);
begin
Amemo.Perform(EM_UNDO, 0, 0);
end;
//* 实现ComBoBox自动下拉
procedure AutoListDisplay(ACombox:TComboBox);
begin
SendMessage(ACombox.handle, CB_SHOWDROPDOWN, Integer(True), 0);
end;
//* 小写金额转换为大写
function UpperMoney(small:real):string;
var
SmallMonth,BigMonth:string;
wei1,qianwei1:string[2];
qianwei,dianweizhi,qian:integer;
ObjSmall:real;
begin
{------- 修改参数令值更精确 -------}
ObjSmall:=Abs(small);
qianwei:=-2;
Smallmonth:=formatfloat('0.00',ObjSmall);
dianweizhi :=pos('.',Smallmonth);
for qian:=length(Smallmonth) downto 1 do
begin
if qian<>dianweizhi then
begin
case strtoint(copy(Smallmonth,qian,1)) of
1:wei1:='壹';
2:wei1:='贰';
3:wei1:='叁';
4:wei1:='肆';
5:wei1:='伍';
6:wei1:='陆';
7:wei1:='柒';
8:wei1:='捌';
9:wei1:='玖';
0:wei1:='零';
end;
case qianwei of
-3:qianwei1:='厘';
-2:qianwei1:='分';
-1:qianwei1:='角';
0 :qianwei1:='元';
1 :qianwei1:='拾';
2 :qianwei1:='佰';
3 :qianwei1:='千';
4 :qianwei1:='万';
5 :qianwei1:='拾';
6 :qianwei1:='佰';
7 :qianwei1:='千';
8 :qianwei1:='亿';
9 :qianwei1:='十';
10:qianwei1:='佰';
11:qianwei1:='千';
end;
inc(qianwei);
if Small<0 then
BigMonth :='负'+wei1+qianwei1+BigMonth
else
BigMonth :=wei1+qianwei1+BigMonth
end;
end;
Result:=BigMonth;
end;
//利用系统时间产生随机数
function Myrandom(Num: Integer): integer;
var
T: _SystemTime;
X: integer;
I: integer;
begin
Result := 0;
If Num = 0 then Exit;;
GetSystemTime(T);
X := Trunc(T.wMilliseconds/10) * T.wSecond * 1231;
X := X + random(1);
if X<>0 then
X := -X;
X := Random(X);
X := X mod num;
for I := 0 to X do
X := Random(Num);
Result := X;
end;
//打开输入法
procedure OpenIME(ImeName: string);
var
i: integer;
MyHKL: hkl;
begin
if ImeName <> '' then begin
if Screen.Imes.Count <> 0 then begin
i := Screen.Imes.IndexOf(ImeName);
if i >= 0 then MyHKL := hkl(Screen.Imes.Objects[i]);
ActivateKeyboardLayout(MyHKL, KLF_ACTIVATE);
end;
end;
end;
//关闭输入法
procedure CloseIME;
var
MyHKL: hkl;
begin
MyHKL := GetKeyboardLayout(0);
if ImmIsIme(MyHKL) then
ImmSimulateHotKey(Application.Handle, IME_CHOTKEY_IME_NONIME_TOGGLE);
end;
//打开中文输入法
procedure ToChinese(hWindows: THandle; bChinese: boolean);
begin
if ImmIsIME(GetKeyboardLayOut(0)) <> bChinese then
ImmSimulateHotKey(hWindows, IME_THotKey_IME_NonIME_Toggle);
end;
//数据备份
procedure BackUpData(LpBackDispMessTitle:String);
var
i,j:integer;
Source,Dest:array[0..200]of char;
s1:string;
Lp:_SHFILEOPSTRUCTA;
Success:Integer;
begin
if MessageBox(Application.Handle,' 您确认要备份数据吗？','询问窗口',4+32+256)=6 then
begin
with LP do
begin
Lp.wnd:=Application.Handle;
wFunc:=FO_COPY;
s1:='DATA\*.*';
i:=Length(s1);
StrCopy(Source,PChar(s1));
Source[i]:=#0;
Source[i+1]:=#0;
Source[i+2]:=#0;
pFrom:=Source;
s1:='BACKUP';
j:=Length(s1);
StrCopy(Dest,PChar(s1));
Dest[j]:='\';
Dest[j+1]:=#0;
Dest[j+2]:=#0;
Dest[j+3]:=#0;
pTo:=Dest;
fFlags:=FOF_ALLOWUNDO;
fAnyOperationsAborted:=False;
lpszProgressTitle:=PChar(LpBackDispMessTitle);
end;
Success:=SHFileOperation(LP);
case Success of
0:
MessageBox(Application.Handle,' 所有数据已备份完成 ！','提示窗口',0+48);
117:
MessageBox(Application.Handle,Pchar(' 您未创建“'+ExtractFilePath(Application.ExeName)+'BACKUP”目录所以不能完成数据备份 ！'),'提示窗口',0+16)
else
MessageBox(Application.Handle,' 在备份数据的过程中被用户中途中断 ！','提示窗口',0+16);
end;
end;
end;
////////////////////////////////////////////////////////////////////////////////
// //
// 从文件中读取Ado连接字串 //
// //
////////////////////////////////////////////////////////////////////////////////
function GetConnectionString(DataBaseName:string):string;
var FileStringList:Tstringlist;
TempString: ansistring;
TheReg:TRegistry;KeyName,fAppPath:string;
i:Integer;
begin
TheReg:=TRegistry.Create;
try
TheReg.RootKey:=HKEY_LOCAL_MACHINE;
KeyName:='Software\政府采购管理系统';
if TheReg.OpenKey(KeyName,False) then
fAppPath:=TheReg.ReadString('ApplicationPath');
finally
TheReg.Free;
end;
FileStringList:=Tstringlist.Create;
//先判断connection.txt是否存在,存在就调入
if FileExists(fAppPath+'\connection.txt') then
FileStringList.LoadFromFile(fAppPath+'\connection.txt')
else
begin
application.MessageBox('在系统所在目录中没有检测到连接文件(connection.txt)，无法启动系统。','提示',MB_IconError+mb_ok);
Result:='';
FileStringList.Free;
Exit;
end;
//组成一个符串，好进行处理。
TempString:='';
for i:=0 to FileStringList.Count-1 do
begin
TempString:=TempString+FileStringList.strings[i];
end;
TempString:=Replace(TempString,'DataBaseName',DataBaseName,False);
Result:=TempString;
end;
{function GetRemoteServerName：返回远程服务器的机器名称}
function GetRemoteServerName:string;
var iniServer:TIniFile;
TheReg:TRegistry;KeyName,fAppPath,RServerName:string;
begin
TheReg:=TRegistry.Create;
try
TheReg.RootKey:=HKEY_LOCAL_MACHINE;
KeyName:='Software\政府采购管理系统';
if TheReg.OpenKey(KeyName,False) then
fAppPath:=TheReg.ReadString('ApplicationPath');
finally
TheReg.Free;
end;
try
iniServer:=TIniFile.Create(fAppPath+'\RemoteServerName.ini');
with iniServer do
RServerName:=ReadString('Option','RServerName','');
iniServer.Free;
except
raise exception.Create('致命错误：未找到包含Com服务器配置的信息文件，初始化失败。');
end;
Result:=RServerName;
end;
initialization
WndLong := GetWindowLong(Application.Handle, GWL_EXSTYLE);
end.
{▎ 觉得还一般 请关注 http://www.cdsunco.com/down.htm 还有更多的好东西 ▎}
isDbase:=pos('.dbf',tempTableName)>0;
end
else
begin
isParadox:=TableType=ttParadox;
isDbase:=TableType=ttDbase;
end;
if isparadox or isDbase then
begin
bExclusive:=Exclusive;
bActive:=Active;
DisableControls;
// Close;
Exculsive:=true;
end
else
begin
StatusMsg:='无效的数据表类型。';
Exit;
end;
if isParadox then
begin
if wwMemAvail(Sizeof(CRTblDesc)) then
begin
StatusMsg:='内存不足，压缩表失败。';
end
else
begin
GetMem(pTblDesc,Sizeof(CRTblDesc));
fillchar(pTblDesc^,Sizeof(CRTblDesc),0);
with pTblDesc^ do
begin
strCopy(szTblName,Tablename);
strCopy(szTblType,szParadox);
Active:=True;
Check(DbiGetCursorProps(handle,Props));//检测是否右口令保护
bProtected:=props.bProtected;
Active:=False;
bPack:=True;
end;
Screen.Cursor:=crHourGlass;
SetDBFlag(dbfOpened,True);
rslt:=DBIdoRestructure(DBHandle,1,pTblDesc,nil,nil,nil,False);
if rslt<>DBIERR_NONE then
begin
DBiGetErrorString(rslt,SzErrMsg);
StatusMsg:=SzErrMsg;
end
else
Result:=True;
SetDBFlag(dbfOpened,False);
FreeMem(pTblDesc,Sizeof(CRTlDesc));
Screen.Cursor:=crDefault;
end;
end
else
if isDbase then
begin
Screen.Cursor:=crHourGlass;
OPen;
rslt:=dbiPacktable(DBHandle,Handle,nil,nil,True);
Screen.Cursor:=crDefault;
if rslt<>DBIERR_NONE then
begin
DBiGetERRorString(rslt,szErrMsg);
StatusMSg:=SzErrMsg;
end
else
Result:=True;
end;
Close;
Exculsive:=bExclusive;
Active:=bActive;
EnableControls;
end;}
{procedure CompactDb(DbName, NewDbName: string);
var
dao: OLEVariant;
begin
dao := CreateOleObject('DAO.DBEngine.35');
dao.CompactDatabase(DbName, NewDbName);
end;}
//修复Access表
procedure RepairDb(DbName: string);
var
Dao: OLEVariant;
begin
Dao := CreateOleObject('DAO.DBEngine.35');
Dao.RepairDatabase(DbName);
end;
//通过注册表创建ODBC配置[创建在系统DSN页下]
function CreateODBCCfgInRegistry(ODBCSourceName:WideString; ServerName, DataBaseDescription:String):boolean;
var
Reg: TRegistry;
LPT_systemDir:array [1..255] of char;
P:Pchar;
DriverString:String;
begin
Reg := TRegistry.Create;
Reg.RootKey := HKEY_LOCAL_MACHINE;
try
try
if not Reg.KeyExists('\Software\ODBC\ODBC.INI\'+trim(ODBCSourceName)) then
begin
//创建并打开主键。
if Reg.OpenKey('\Software\ODBC\ODBC.INI\'+trim(ODBCSourceName),True) then
begin
//写入键值
Reg.WriteString('DataBase', ODBCSourceName);
Reg.WriteString('Description',Trim(DataBaseDescription));
GetSystemDirectory(@LPT_systemDir,255) ;
P:=@LPT_systemDir;
DriverString:=StrCat(P,Pchar('\SQLSRV32.DLL')) ;
Reg.WriteString('Driver', DriverString);
Reg.WriteString('LastUser', 'Administrator');
Reg.WriteString('Server', trim(ServerName));
Reg.WriteString('Trusted_Connection', 'Yes');
reg.CloseKey;
end;
//加入ODBCDataSource
if Reg.OpenKey('\Software\ODBC\ODBC.INI\ODBC Data Sources\',True) then
begin
Reg.DeleteValue(ODBCSourceName);
Reg.WriteString(ODBCSourceName, 'SQL Server');
Reg.CloseKey;
end;
end;
Result:=True;
except
Result:=False;
end;
finally
Reg.Free;
end;
end;
function ADOConnectSysBase(Const Adocon:TadoConnection):boolean;
{* 用Ado连接SysBase数据库函数}
begin
with Adocon do
begin
Close;
LoginPrompt:=False; //若数据库不存在时，进行判断。。。。。。
ConnectionString:='Provider=MSDASQL.1;'+
'Password="";'+
'Persist Security Info=True;'+
'Data Source=Sy_Finalact';
try
KeepConnection:=True;
Screen.Cursor:=crHourGlass;
Connected:=True;
Open;
Screen.Cursor:=crDefault;
ADOConnectSysBase:=True;
except
ADOConnectSysBase:=False;
end;
end;
end;
//Ado连接数据库函数
function ADOConnectLocalDB(Const Adocon:TAdoConnection;Const Dbname,DBServerName:String;ValidateMode:Integer):boolean;
begin
with Adocon do
begin
Close;
LoginPrompt:=False; //若数据库不存在时，进行判断。。。。。。
if ValidateMode=0 then//使用Windows NT验证模式
ConnectionString:='Provider=SQLOLEDB.1;'+
'Password="";'+
'Integrated Security=SSPI;'+ //集成安全
'Persist Security Info=False;'+
'User ID=sa;Initial Catalog='+''''+dbname+''''+';'+
'Data Source='+''''+DBServerName+'''';
if ValidateMode=1 then//使用SQL SERVER验证模式
ConnectionString:='Provider=SQLOLEDB.1;'+
'Password="";'+
'Persist Security Info=True;'+
'User ID=sa;Initial Catalog='+''''+Dbname+''''+';'+
'Data Source='+''''+DBServerName+'''';
try
KeepConnection:=True;
Screen.Cursor:=crHourGlass;
Connected:=True;
Open;
Screen.Cursor:=crDefault;
ADOConnectLocalDB:=True;
except
ADOConnectLocalDB:=False;
end;
end;
end;
//Ado与ODBC共同连接数据库函数
function ADOODBCConnectLocalDB(Const Adocon:TAdoConnection;Const Dbname:String;ValidateMode:Integer):boolean;
begin
with Adocon do
begin
Close;
LoginPrompt:=False; //若数据库不存在时，进行判断。。。。。。
if ValidateMode=0 then//使用Windows NT验证模式
ConnectionString:='Provider=MSDASQL.1;'+
'Password="";'+
'Persist Security Info=False;'+
'User ID=sa;Data Source='+''''+DBName+''''+';'+
'Initial Catalog='+''''+DBname+'''';
if ValidateMode=1 then//使用SQL SERVER验证模式
ConnectionString:='Provider=MSDASQL.1;'+
'Password="";'+
'Persist Security Info=True;'+
'User ID=sa;Data Source='+''''+DBName+''''+';'+
'Initial Catalog='+''''+DBname+'''';
try
KeepConnection:=True;
Screen.Cursor:=crHourGlass;
Connected:=True;
Open;
Screen.Cursor:=crDefault;
ADOODBCConnectLocalDB:=True;
except
ADOODBCConnectLocalDB:=False;
end;
end;
end;
///在指定的数据库中建立表
function CreatTable(LpDataBaseName,LpTableName,LpSentence:string):Boolean;//建立新表
Var
CreatTableQuery:TQuery;
SQLsentence:string;
Successed:Boolean;//成功否
begin
Successed:=False;
SQLsentence:='CREATE TABLE "'+ LpTableName +'" ' + LpSentence;
CreatTableQuery:=TQuery.Create(nil);
try
try
with CreatTableQuery do
begin
UniDirectional:=True;
Active:=False;
Sql.Clear;
DataBaseName := LpDataBaseName; //数据库名
Sql.Add(SQLsentence);
ExecSQL;
Successed:=True;
end;
except
MessageBox(Application.Handle,Pchar(' 在建立数据库 '+Trim(LpDataBaseName)+' 中的 '+Trim(LpTableName)+' 表出错，建立未能成功 ！'),'建立失败',0+16);
Successed:=False;
end;
finally
CreatTableQuery.Free;//释放建立的Query
if Successed then
Result:=True//建立成功
else
Result:=False;//建立失败
end;
end;
//在指定的表中新填字段
function AddField(LpFieldName:string; LpDataType: TFieldType; LpSize: Word):string;//建立新表
var
Sentence,SQLsentence : string;
begin
Sentence:= '';
SQLsentence:='';
if LpFieldName = '' then
raise EDBUpdateErr.Create('字段名不能为空');
if Pos(' ', LpFieldName) <> 0 then
raise EDBUpdateErr.Create('字段名中不能含有空格字符');
if LpDataType = ftString then
sentence := 'ADD '+LpFieldName+' Char('+ IntToStr( LpSize ) + ')';
if LpDataType = ftInteger then
sentence := 'ADD '+LpFieldName+' Integer';
if LpDataType = ftSmallInt then
sentence := 'ADD '+LpFieldName+' SmallInt';
if LpDataType = ftFloat then
sentence := 'ADD '+LpFieldName+' Float('+ IntToStr( LpSize ) +',0)';
if LpDataType = ftDate then
sentence := 'ADD '+LpFieldName+' Date';
if LpDataType = ftTime then
sentence := 'ADD '+LpFieldName+' Time';
if LpDataType = ftDateTime then
sentence := 'ADD '+LpFieldName+' TimeStamp';
if sentence = '' then
raise EDBUpdateErr.Create('无效的字段类型');
if SQLSentence = '' then
SQLSentence := sentence
else
SQLSentence := SQLSentence + ', ' + sentence;
Result:=SQLSentence;//返回SQL句体
end;
//在指定的表中删除字段
function KillField(LpFieldName:string):String;//删除表中的字段
var
SQLsentence : string;
begin
if LpFieldName = '' then
raise EDBUpdateErr.Create('字段名不能为空');
if Pos(' ', LpFieldName) <> 0 then
raise EDBUpdateErr.Create('字段名中不能含有空格字符');
if SQLSentence = '' then
SQLSentence := 'DROP COLUMN ' + LpFieldName
else
SQLSentence := SQLSentence + ', DROP ' + LpFieldName;
Result:=SQLSentence;
end;
//修改表结构的SQL语句执行体
function AlterTableExec(LpDataBaseName,LpSentence:string):Boolean;//修改表结构
var
AlterQueryTable:TQuery;
Successed:Boolean;//成功否
begin
Successed:=False;
AlterQueryTable:= TQuery.Create(nil);
try
try
with AlterQueryTable do
begin
DataBaseName:=LpDataBaseName;//数据库名
UniDirectional:=True;
Active:=False;
Sql.Clear;
Sql.Add(LpSentence);
ExecSQL;
Successed:=True;
end;
except
Successed:=False;
end;
finally
AlterQueryTable.Free;
if successed then
Result:=True
else
Result:=False;
end;
end;
//修改、添加、删除表结构时的SQL句体
function GetSQLSentence(LpTableName,LpSQLsentence:string): string;
begin
Result := 'ALTER TABLE "'+ LpTableName +'" ' + LpSQLSentence + ';';
end;
//▎============================================================▎//
//▎======================⑾进制函数及过程======================▎//
//▎============================================================▎//
//字符转化成十六进制
function StrToHex(AStr: string): string;
var
I : Integer;
// Tmp: string;
begin
Result := '';
For I := 1 to Length(AStr) do
begin
Result := Result + Format('%2x', [Byte(AStr[I])]);
end;
I := Pos(' ', Result);
While I <> 0 do
begin
Result[I] := '0';
I := Pos(' ', Result);
end;
end;
//十六进制转化成字符
function HexToStr(AStr: string): string;
var
I : Integer;
CharValue: Word;
begin
Result := '';
for I := 1 to Trunc(Length(Astr)/2) do
begin
Result := Result + ' ';
CharValue := TransChar(AStr[2*I-1])*16 + TransChar(AStr[2*I]);
Result[I] := Char(CharValue);
end;
end;
function TransChar(AChar: Char): Integer;
begin
if AChar in ['0'..'9'] then
Result := Ord(AChar) - Ord('0')
else
Result := 10 + Ord(AChar) - Ord('A');
end;
//▎============================================================▎//
//▎=====================⑿其它函数及过程=======================▎//
//▎============================================================▎//
// 输出限制在Min..Max之间
function TrimInt(Value, Min, Max: Integer): Integer; overload;
begin
if Value > Max then
Result := Max
else if Value < Min then
Result := Min
else
Result := Value;
end;
// 输出限制在0..255之间
function IntToByte(Value: Integer): Byte; overload;
asm
OR EAX, EAX
JNS @@Positive
XOR EAX, EAX
RET
@@Positive:
CMP EAX, 255
JBE @@OK
MOV EAX, 255
@@OK:
end;
// 由TRect分离出坐标、宽高
procedure DeRect(Rect: TRect; var x, y, Width, Height: Integer);
begin
x := Rect.Left;
y := Rect.Top;
Width := Rect.Right - Rect.Left;
Height := Rect.Bottom - Rect.Top;
end;
// 比较两个Rect
function RectEqu(Rect1, Rect2: TRect): Boolean;
begin
Result := (Rect1.Left = Rect2.Left) and (Rect1.Top = Rect2.Top) and
(Rect1.Right = Rect2.Right) and (Rect1.Bottom = Rect2.Bottom);
end;
// 产生TSize类型
function EnSize(cx, cy: Integer): TSize;
begin
Result.cx := cx;
Result.cy := cy;
end;
// 计算Rect的宽度
function RectWidth(Rect: TRect): Integer;
begin
Result := Rect.Right - Rect.Left;
end;
// 计算Rect的高度
function RectHeight(Rect: TRect): Integer;
begin
Result := Rect.Bottom - Rect.Top;
end;
// 判断范围
function InBound(Value: Integer; Min, Max: Integer): Boolean;
begin
Result := (Value >= Min) and (Value <= Max);
end;
// 交换两个数
procedure CnSwap(var A, B: Byte); overload;
var
Tmp: Byte;
begin
Tmp := A;
A := B;
B := Tmp;
end;
procedure CnSwap(var A, B: Integer); overload;
var
Tmp: Integer;
begin
Tmp := A;
A := B;
B := Tmp;
end;
procedure CnSwap(var A, B: Single); overload;
var
Tmp: Single;
begin
Tmp := A;
A := B;
B := Tmp;
end;
procedure CnSwap(var A, B: Double); overload;
var
Tmp: Double;
begin
Tmp := A;
A := B;
B := Tmp;
end;
// 延时
procedure Delay(const uDelay: DWORD);
var
n: DWORD;
begin
n := GetTickCount;
while ((GetTickCount - n) <= uDelay) do
Application.ProcessMessages;
end;
// 在Win9X下让喇叭发声
procedure BeepEx(const Freq: WORD = 1200; const Delay: WORD = 1);
const
FREQ_SCALE = 93180;
var
Temp: WORD;
begin
Temp := FREQ_SCALE div Freq;
asm
in al,61h;
or al,3;
out 61h,al;
mov al,$b6;
out 43h,al;
mov ax,temp;
out 42h,al;
mov al,ah;
out 42h,al;
end;
Sleep(Delay);
asm
in al,;
and al,$fc;
out ,al;
end;
end;
// 显示Win32 Api运行结果信息
procedure ShowLastError;
var
ErrNo: Integer;
Buf: array[0..255] of Char;
begin
ErrNo := GetLastError;
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, ErrNo, 0, Buf, 255, nil);
if Buf = '' then StrCopy(@Buf, PChar(SUnknowError));
MessageBox(Application.Handle, PChar(string(Buf) + #10#13 +
SErrorCode + IntToStr(ErrNo)),
SCnInformation, MB_OK + MB_ICONINFORMATION);
end;
//将字体Font.Style写入INI文件
function writeFontStyle(FS: TFontStyles; inifile: string; write: boolean):string;
var
Mystyle : string;
Myini : Tinifile;
begin
Mystyle := '[';
if fsBold in FS then MyStyle := MyStyle + 'fsBold';
if fsItalic in FS then
if MyStyle = '[' then
MyStyle := MyStyle + 'fsItalic'
else
MyStyle := MyStyle + ',fsItalic';
if fsUnderline in FS then
if MyStyle = '[' then
MyStyle := MyStyle + 'fsUnderline'
else
MyStyle := MyStyle + ',fsUnderline';
if fsStrikeOut in FS then
if MyStyle = '[' then
MyStyle := MyStyle + 'fsStrikeOut'
else
MyStyle := MyStyle + ',fsStrikeOut';
MyStyle := MyStyle + ']';
if write then
begin
Myini := TInifile.Create(inifile);
Myini.WriteString('FontStyle', 'style', MyStyle);
Myini.free;
end;
Result := MyStyle;
end;
//从INI文件中读取字体Font.Style文件
function readFontStyle(inifile: string): TFontStyles;
var
MyFontStyle : TFontStyles;
MyStyle : string;
Myini : Tinifile;
begin
MyFontStyle := [];
Myini := TInifile.Create(inifile);
Mystyle := Myini.ReadString('Fontstyle', 'style', '[]');
if pos('fsBold', Mystyle) > 0 then MyFontStyle := MyFontStyle + [fsBold];
if Pos('fsItalic', MyStyle) > 0 then MyFontStyle := MyFontStyle + [fsItalic];
if Pos('fsUnderline', MyStyle) > 0 then
MyFontStyle := MyFontStyle + [fsUnderline];
if Pos('fsStrikeOut', MyStyle) > 0 then
MyFontStyle := MyFontStyle + [fsStrikeOut];
MyIni.free;
Result := MyFontStyle;
end;
//*取得TMemo 控件当前光标的行和列信息到Tpoint中
//function ReadCursorPos(SourceMemo: TMemo): TPoint;
function ReadCursorPos(SourceMemo: TMemo): string;
var
// Point: TPoint;
X,Y:integer;
begin
// point.y := SendMessage(SourceMemo.Handle, EM_LINEFROMCHAR,SourceMemo.SelStart,0);
// point.x := SourceMemo.SelStart- SendMessage(SourceMemo.Handle,EM_LINEINDEX,point.y,0);
y := SendMessage(SourceMemo.Handle, EM_LINEFROMCHAR,SourceMemo.SelStart,0);
x := SourceMemo.SelStart- SendMessage(SourceMemo.Handle,EM_LINEINDEX,y,0);
Result := '行:'+inttostr(y+1)+' '+'列:'+inttostr(x+1);
end;
//*检查Tmemo控件能否Undo功能
function CanUndo(AMemo: TMemo): Boolean;
begin
Result :=AMemo.Perform(EM_CANUNDO, 0, 0)<>0;
end;
//* 实现Undo功能
procedure Undo(Amemo: Tmemo);
begin
Amemo.Perform(EM_UNDO, 0, 0);
end;
//* 实现ComBoBox自动下拉
procedure AutoListDisplay(ACombox:TComboBox);
begin
SendMessage(ACombox.handle, CB_SHOWDROPDOWN, Integer(True), 0);
end;
//* 小写金额转换为大写
function UpperMoney(small:real):string;
var
SmallMonth,BigMonth:string;
wei1,qianwei1:string[2];
qianwei,dianweizhi,qian:integer;
ObjSmall:real;
begin
{------- 修改参数令值更精确 -------}
ObjSmall:=Abs(small);
qianwei:=-2;
Smallmonth:=formatfloat('0.00',ObjSmall);
dianweizhi :=pos('.',Smallmonth);
for qian:=length(Smallmonth) downto 1 do
begin
if qian<>dianweizhi then
begin
case strtoint(copy(Smallmonth,qian,1)) of
1:wei1:='壹';
2:wei1:='贰';
3:wei1:='叁';
4:wei1:='肆';
5:wei1:='伍';
6:wei1:='陆';
7:wei1:='柒';
8:wei1:='捌';
9:wei1:='玖';
0:wei1:='零';
end;
case qianwei of
-3:qianwei1:='厘';
-2:qianwei1:='分';
-1:qianwei1:='角';
0 :qianwei1:='元';
1 :qianwei1:='拾';
2 :qianwei1:='佰';
3 :qianwei1:='千';
4 :qianwei1:='万';
5 :qianwei1:='拾';
6 :qianwei1:='佰';
7 :qianwei1:='千';
8 :qianwei1:='亿';
9 :qianwei1:='十';
10:qianwei1:='佰';
11:qianwei1:='千';
end;
inc(qianwei);
if Small<0 then
BigMonth :='负'+wei1+qianwei1+BigMonth
else
BigMonth :=wei1+qianwei1+BigMonth
end;
end;
Result:=BigMonth;
end;
//利用系统时间产生随机数
function Myrandom(Num: Integer): integer;
var
T: _SystemTime;
X: integer;
I: integer;
begin
Result := 0;
If Num = 0 then Exit;;
GetSystemTime(T);
X := Trunc(T.wMilliseconds/10) * T.wSecond * 1231;
X := X + random(1);
if X<>0 then
X := -X;
X := Random(X);
X := X mod num;
for I := 0 to X do
X := Random(Num);
Result := X;
end;
//打开输入法
procedure OpenIME(ImeName: string);
var
i: integer;
MyHKL: hkl;
begin
if ImeName <> '' then begin
if Screen.Imes.Count <> 0 then begin
i := Screen.Imes.IndexOf(ImeName);
if i >= 0 then MyHKL := hkl(Screen.Imes.Objects[i]);
ActivateKeyboardLayout(MyHKL, KLF_ACTIVATE);
end;
end;
end;
//关闭输入法
procedure CloseIME;
var
MyHKL: hkl;
begin
MyHKL := GetKeyboardLayout(0);
if ImmIsIme(MyHKL) then
ImmSimulateHotKey(Application.Handle, IME_CHOTKEY_IME_NONIME_TOGGLE);
end;
//打开中文输入法
procedure ToChinese(hWindows: THandle; bChinese: boolean);
begin
if ImmIsIME(GetKeyboardLayOut(0)) <> bChinese then
ImmSimulateHotKey(hWindows, IME_THotKey_IME_NonIME_Toggle);
end;
//数据备份
procedure BackUpData(LpBackDispMessTitle:String);
var
i,j:integer;
Source,Dest:array[0..200]of char;
s1:string;
Lp:_SHFILEOPSTRUCTA;
Success:Integer;
begin
if MessageBox(Application.Handle,' 您确认要备份数据吗？','询问窗口',4+32+256)=6 then
begin
with LP do
begin
Lp.wnd:=Application.Handle;
wFunc:=FO_COPY;
s1:='DATA\*.*';
i:=Length(s1);
StrCopy(Source,PChar(s1));
Source[i]:=#0;
Source[i+1]:=#0;
Source[i+2]:=#0;
pFrom:=Source;
s1:='BACKUP';
j:=Length(s1);
StrCopy(Dest,PChar(s1));
Dest[j]:='\';
Dest[j+1]:=#0;
Dest[j+2]:=#0;
Dest[j+3]:=#0;
pTo:=Dest;
fFlags:=FOF_ALLOWUNDO;
fAnyOperationsAborted:=False;
lpszProgressTitle:=PChar(LpBackDispMessTitle);
end;
Success:=SHFileOperation(LP);
case Success of
0:
MessageBox(Application.Handle,' 所有数据已备份完成 ！','提示窗口',0+48);
117:
MessageBox(Application.Handle,Pchar(' 您未创建“'+ExtractFilePath(Application.ExeName)+'BACKUP”目录所以不能完成数据备份 ！'),'提示窗口',0+16)
else
MessageBox(Application.Handle,' 在备份数据的过程中被用户中途中断 ！','提示窗口',0+16);
end;
end;
end;
////////////////////////////////////////////////////////////////////////////////
// //
// 从文件中读取Ado连接字串 //
// //
////////////////////////////////////////////////////////////////////////////////
function GetConnectionString(DataBaseName:string):string;
var FileStringList:Tstringlist;
TempString: ansistring;
TheReg:TRegistry;KeyName,fAppPath:string;
i:Integer;
begin
TheReg:=TRegistry.Create;
try
TheReg.RootKey:=HKEY_LOCAL_MACHINE;
KeyName:='Software\政府采购管理系统';
if TheReg.OpenKey(KeyName,False) then
fAppPath:=TheReg.ReadString('ApplicationPath');
finally
TheReg.Free;
end;
FileStringList:=Tstringlist.Create;
//先判断connection.txt是否存在,存在就调入
if FileExists(fAppPath+'\connection.txt') then
FileStringList.LoadFromFile(fAppPath+'\connection.txt')
else
begin
application.MessageBox('在系统所在目录中没有检测到连接文件(connection.txt)，无法启动系统。','提示',MB_IconError+mb_ok);
Result:='';
FileStringList.Free;
Exit;
end;
//组成一个符串，好进行处理。
TempString:='';
for i:=0 to FileStringList.Count-1 do
begin
TempString:=TempString+FileStringList.strings[i];
end;
TempString:=Replace(TempString,'DataBaseName',DataBaseName,False);
Result:=TempString;
end;
{function GetRemoteServerName：返回远程服务器的机器名称}
function GetRemoteServerName:string;
var iniServer:TIniFile;
TheReg:TRegistry;KeyName,fAppPath,RServerName:string;
begin
TheReg:=TRegistry.Create;
try
TheReg.RootKey:=HKEY_LOCAL_MACHINE;
KeyName:='Software\政府采购管理系统';
if TheReg.OpenKey(KeyName,False) then
fAppPath:=TheReg.ReadString('ApplicationPath');
finally
TheReg.Free;
end;
try
iniServer:=TIniFile.Create(fAppPath+'\RemoteServerName.ini');
with iniServer do
RServerName:=ReadString('Option','RServerName','');
iniServer.Free;
except
raise exception.Create('致命错误：未找到包含Com服务器配置的信息文件，初始化失败。');
end;
Result:=RServerName;
end;
initialization
WndLong := GetWindowLong(Application.Handle, GWL_EXSTYLE);
end.
{▎ 觉得还一般 请关注 http://www.cdsunco.com/down.htm 还有更多的好东西 ▎}
