unit Ufunction;
interface
uses Windows,
Messages,
Winsock,
Registry,
SysUtils,
Variants,
Classes,
Graphics,
Controls,
Forms,
Dialogs,
StdCtrls,
DB,
ADODB,
Grids,
DBGrids,
DBTables,
ExtCtrls,
nb,
IdFTP,
comobj,
XLconst,
inifiles,
Clipbrd;
//***************System函數*****************************************************
function GetProgramVersion: string;
function GetFileVersionS: string;
//update : True 表示由該函數更新版本信息 False 表示隻做Check動作
//update by dargon Liu on 08/08/08 04:40
function Check_Version(var DB_Name: TDatabase; Program_Name, BU_Type: string; OtherFile: string = ''; update: Boolean = False): boolean;
//檢查版本, Update為True將自動更新最新版本信息
function CheckADOInstalled: Boolean; //檢查ADO組件是否安裝
function GetMyPCName: string; //獲取計算機名稱
function UpdateExeFile(sBu_Type, sExeName, sOther: string): Boolean; //從固定服務器DownLoad程式,更新
function Get_File_From_Ftp(sFileName: string; desFile: string): Boolean;
//******************************************************************************
{************Add by Dargon in 2008/06/07***************************************}
//**************控件設置********************************************************
procedure SetComboBox(Qry: TQuery; sSQL, sField: string; cbb: TComboBox); //設置ComboBox的值
procedure SetListBox(Qry: TQuery; sSQL, sField: string; lb: TListBox; bl: Boolean = False); //設置ListBox的值
//******************************************************************************
//*************SQL執行/處理*****************************************************
procedure ExcSQL(var Qry: TQuery; sSQL: string; bl: Boolean = False; param: string = ''; sValue: string = ''); overload; //執行單條SQL語句
procedure ExcSQL(var Qry: TQuery; sTable, sField, sValue: string); overload; //執行傳入參數所指定的SQL語句,並更新Qry數據集
function ExcASQL(Qry: TQuery; sSQL, sField: string): TStringList; //執行單條SQL語句,並返回結果集
procedure ExcMulSQL(Qry: TQuery; sList: TStringList; bl: Boolean = False; param: string = ''; sValue: string = ''); overload;
//執行以StringList存儲的多條SQL語句
procedure ExcMulSQL(Qry: TQuery; substr, sStr: string; bl: Boolean = False; param: string = ''; sValue: string = ''); overload;
//執行以substr為分隔符的多條SQL語句
function GetFieldValue(Qry: TQuery; sSQL, sField: string): string; //執行SQL並返回值
//******************************************************************************
//*************字符處理*********************************************************
function slipStr(substr, str: string): TStringList; //切割以substr為分隔符的字符串,並以StringList返回
//******************************************************************************
//*************特殊判斷*********************************************************
function ChkEmpExist(Qry: TQuery; emp: string): Boolean; //Check工號是否存在
function ChkEmpBC(Qry: TQuery; empBC: string; emp: string = ''): Boolean; //Check工號和密碼是否匹配
function ChkEmpPurview(Qry: TQuery; empBC: string; pfun: string; emp: string = ''): Boolean; //Check是否有特定權限
//******************************************************************************
//*************SFC相關函數******************************************************
procedure InsertSysLog(Qry: TQuery; Prg_name, Action_type, Action_Desc: string; Emp: string = 'System'); //插入系統日志
function Get_BDEDSN(DS_TYPE: string; DS_Name: TDatabase): Boolean;
function Get_ADODSN(DS_TYPE: string; ADOORA_DSN:TADOConnection): Boolean;
//******************************************************************************
{***********END by Dargon in 2008/06/07****************************************}
function GetIPAddr: string; ////獲取本機IP地址
procedure setSystemDateTime(var DB_Name: TDatabase); ////將本機時間修改為系統時間
procedure SaveLog(var Listbox_NAME: Tlistbox; fileroute, logfile: string);
procedure SaveMemoLog(var Memo_Name: TMemo; fileroute, logfile: string);
procedure InsertSystemLog(var DB_Name: TDatabase; EempNo, PrgName, ActionType, ActionDesc: string);
///******************************獲取本機MAC ID*********************************
function NbLanaEnum: TLana_Enum; //*
function NbReset(l: Byte): Word; //*
function NbGetMacAddr(LanaNum: Integer): string; //*
function GetMAC: string; //*
///******************************獲取本機MAC ID*********************************
procedure SaveToExcel(DBGrid: TDBGrid; Query: TQuery; var Msg: string);
procedure SaveToExcelFont(DBGrid: TDBGrid; var Msg: string);
procedure KillProcess(Curr_App: TApplication); //Kill Process
function Get_String(LineData, Split_Str: string; item_index: integer): string;
function checkprgopen(qry: TQuery; prg_name, ip: string): Boolean;
var
//-------------
HLib: THandle;
funUpdateFile: function(sBu_Type, sFILENAME, sOther: string): Boolean; stdcall;
proGetBDE: procedure(BDEORA_DSN: TDatabase; DS_TYPE: string); safecall;
proGetADO: procedure(ADOORA_DSN: TADOConnection; DS_TYPE: string); safecall;
implementation
function Get_String(LineData, Split_Str: string; item_index: integer): string;
var
j, K: Integer;
Ch, sData: string;
iPos: Integer;
SN: array[1..10] of string;
SN_End: array[1..10] of integer;
begin
K := 1;
if POS('^', LineData) > 0 then
Split_Str := '^';
if pos(split_str, LineData) = 0 then
begin
result := '';
exit;
end;
LineData := trim(LineData);
if (length(LineData) = 0) then
begin
Result := '';
exit;
end;
for j := 1 to length(LineData) do
begin
Ch := Copy(LineData, j, 1);
if Ch = trim(Split_Str) then
begin
SN_End[k] := j;
k := k + 1;
end;
end;
// 若只有料號barcode則sn_end為length(linedata)+1
SN_End[K] := j;
for j := 1 to item_index do
begin
if SN_End[j] = 0 then
SN_end[j] := length(LineData) + 1;
end;
for j := 1 to item_index do
begin
if j = 1 then
SN[j] := trim(Copy(LineData, 1, SN_end[j] - 1))
else
SN[j] := trim(Copy(LineData, SN_end[j - 1] + 1, SN_end[j] - SN_end[j - 1] - 1));
end;
sData := SN[item_index];
Result := sData;
end;
function GetProgramVersion: string;
var
sExe, Build_Date: string;
iBytes: DWORD;
Len: UINT;
vTemp1, vTemp2: pchar;
begin
sExe := Application.ExeName;
iBytes := GetFileVersionInfoSize(PChar(sExe), iBytes);
if (iBytes > 0) then
begin
vTemp1 := AllocMem(iBytes);
Build_Date := ' ( Build Date : ' + FormatDateTime('yyyy/mm/dd', FileDateToDateTime(FileAge(Application.ExeName))) + ' )';
try
GetFileVersionInfo(PChar(sExe), 0, iBytes, vTemp1);
if VerQueryValue(vTemp1, PChar('StringFileInfo\040403B6\FileVersion'),
Pointer(vTemp2), Len) then
Result := Build_Date + ' Version : ' + vTemp2
else
Result := Build_Date + ' Version : 9.9.9.9';
finally
FreeMem(vTemp1, iBytes);
end;
end
else
Result := Build_Date + ' Version : 9.9.9.9';
end;
////記錄SystemLog
procedure InsertSystemLog(var DB_Name: TDatabase; EempNo, PrgName, ActionType, ActionDesc: string);
var
quryLog: TQuery;
begin
quryLog := TQuery.Create(nil);
quryLog.DatabaseName := DB_Name.DatabaseName;
with quryLog do
begin
Close;
SQL.Clear;
SQL.Add('INSERT INTO SFISM4.R_SYSTEM_LOG_T (EMP_NO, PRG_NAME, ACTION_TYPE, ACTION_DESC ) ' +
'VALUES (:EMP, :PRGNAME, :ACTIONTYPE, :ACTIONDESC )');
ParamByName('EMP').AsString := EempNo;
ParamByName('PRGNAME').AsString := PrgName;
ParamByName('ACTIONTYPE').AsString := ActionType;
ParamByName('ACTIONDESC').AsString := ActionDesc;
ExecSQL;
end;
end;
//////記錄Log文件
procedure SaveLog(var Listbox_NAME: Tlistbox; fileroute, logfile: string);
var
fname: string;
f: textFile;
begin
if Listbox_NAME.Items.Text <> '' then
begin
fname := FormatDateTime('YYYYMMDDHHMM', NOW) + '.txt';
if not DirectoryExists(fileroute + '\' + logfile) then
if not ForceDirectories(fileroute + '\' + logfile) then
raise Exception.Create('Cannot create ' + '\' + fileroute + '\' + logfile);
Listbox_NAME.Items.SaveToFile(fileroute + '\' + logfile + '\' + fname);
end;
end;
procedure SaveMemoLog(var Memo_Name: TMemo; fileroute, logfile: string);
var
fname: string;
f: textFile;
begin
if Memo_Name.Lines.Text <> '' then
begin
fname := FormatDateTime('YYYYMMDDHHMM', NOW) + '.txt';
if not DirectoryExists(fileroute + '\' + logfile) then
if not ForceDirectories(fileroute + '\' + logfile) then
raise Exception.Create('Cannot create ' + '\' + fileroute + '\' + logfile);
Memo_Name.Lines.SaveToFile(fileroute + '\' + logfile + '\' + fname);
end;
end;
procedure setSystemDateTime(var DB_Name: TDatabase); ////將本機時間修改為系統時間
var
SystemDateTime: TSystemTime;
quryData: TQuery;
begin
quryData := TQuery.Create(nil);
quryData.DatabaseName := DB_Name.DatabaseName;
with quryData do
begin
Close;
SQL.Clear;
SQL.Add('select sysdate from dual');
Prepare;
Open;
DateTimeToSystemTime(FieldByName('sysdate').AsDateTime, SystemDateTime);
Close;
end;
SetLocalTime(SystemDateTime);
end;
//*******版本檢查(更新)*****************
function Check_Version(var DB_Name: TDatabase; Program_Name, BU_Type: string; OtherFile: string = ''; update: Boolean = False): boolean;
var
ver_no, str, AP_Path: string;
begin
Result := False;
if not Get_BDEDSN('Y', DB_Name) then
Exit;
ver_no := GetFileVersionS;
ver_no := Copy(ver_no, (pos(':', ver_no) + 1), (Length(ver_no) - pos(':',
ver_no) + 1));
with TQuery.Create(Application) do
try
begin
databasename := DB_Name.DatabaseName;
Close;
SQL.Clear;
SQL.ADD('Select * from sfism4.ams_ap');
SQL.ADD('Where AP_NAME=:prgname ');
ParamByName('prgname').AsString := Program_Name;
Open;
if RecordCount > 0 then
begin
str := FieldByName('AP_VERSION').AsString;
AP_Path := FieldByName('AP_DESC').AsString;
if (Trim(str) < Trim(ver_no)) and update then
begin
Close;
SQL.Clear;
SQL.ADD('Update sfism4.ams_ap set AP_VERSION=:VERSION,UPDAE_TIME =Sysdate');
SQL.ADD('Where AP_NAME=:PROGRAM_NAME');
ParamByName('PROGRAM_NAME').AsString := Program_Name;
ParamByName('VERSION').AsString := ver_no;
ExecSQL;
Result := True;
end
else
if Trim(str) < Trim(ver_no) then
begin
showmessage('您當前使用的程式版本(' + Trim(Ver_NO) + ')高於服務器上的程式版本(' + Trim(str) + ') !' +
#13 + '您可能使用的是測試版本,如不清楚是否能夠使用,請聯系MIS!');
Result := True;
end
else
if Trim(str) > Trim(ver_no) then
begin
showmessage('程式版本太低, 開始更新程式........ !' + #13 + '當前使用的程式版本(' + Trim(Ver_NO) + ')' +
'服務器上的程式版本(' + Trim(str) + ') !');
if not UpdateExeFile(Bu_Type, Program_Name, OtherFile) then
ShowMessage('程式更新失敗,請與MIS聯系!')
else
ShowMessage('程式更新成功, 請重新開啟程式!');
Result := False;
end
else
Result := True;
end
else
if update then
begin
Close;
SQL.Clear;
SQL.ADD('INSERT INTO sfism4.ams_ap (AP_NAME,AP_VERSION,AP_PATH,AP_TYPE,FILE_NAME)');
SQL.ADD('VALUES(:PROGRAM_NAME,:VERSION,''WEPKEY'',''FILE'',''WEPKEY'')');
ParamByName('PROGRAM_NAME').AsString := Program_Name;
ParamByName('VERSION').AsString := ver_no;
ExecSQL;
Result := True;
end
else
begin
Application.MessageBox('程式版本沒有定議!' +
#13 + '請聯係MIS定議程式版本', 'Error', MB_OK);
Result := False;
end;
end;
finally
free;
end;
end;
function CheckADOInstalled: Boolean;
var
r: TRegistry;
s: string;
begin
r := TRegistry.create;
try
with r do
begin
RootKey := HKEY_CLASSES_ROOT;
OpenKey('\ADODB.Connection\CurVer', false);
s := ReadString('');
if s <> '' then
Result := True
else
Result := False;
CloseKey;
end;
finally
r.free;
end;
end;
function GetMyPCName: string;
var
ComputerName: pchar;
Size: Cardinal;
Re: Boolean;
begin
Size := MAX_COMPUTERNAME_LENGTH + 1;
Getmem(ComputerName, Size);
{retrieve computer name}
Re := GetComputerName(ComputerName, Size);
if re then
Result := StrPas(Computername)
else
Result := 'No PCNAME';
Freemem(ComputerName);
end;
function UpdateExeFile(sBU_type, sExeName, sOther: string): Boolean;
begin
Result := False;
try
try
HLib := LoadLibrary('SFIS_CON.dll');
if HLib <> 0 then
begin
funUpdateFile := GetProcAddress(HLib, 'UpdateFile');
if @funUpdateFile <> nil then
Result := funUpdateFile(sBU_type, sExeName, sOther)
else
raise exception.Create('sfis_con.dll內函數調用失敗!');
end
else
raise exception.Create('找不到文件sfis_con.dll或文件損壞');
except on e: Exception do
begin
Result := False;
ShowMessage('程式更新失敗!請與MIS聯系!' + #13 + e.Message);
end;
end;
finally
FreeLibrary(Hlib);
end;
end;
function Get_File_From_Ftp(sFileName: string; desFile: string): Boolean;
var
ftpRmyh: TIdFTP;
Ftpconfigfile: TiniFile;
ftpserverip: string;
begin
Result := True;
Ftpconfigfile := TiniFile.Create('SFIS.INI');
ftpserverip := Ftpconfigfile.ReadString('SERVERCONFIG', 'ftpserver', '10.120.251.76');
Ftpconfigfile.Free;
ftpRmyh := TIdFTP.Create(nil);
ftpRmyh.Host := ftpserverip;
ftpRmyh.Port := 21;
ftpRmyh.Username := 'sfc';
ftpRmyh.Password := 'sfc';
try
ftpRmyh.Connect;
except
ShowMessage('ftp服務器連接失敗,請盡快聯系MIS!');
Result := False;
end;
try
ftpRmyh.Get(sFileName, desFile, True, False);
except on e: Exception do
begin
ShowMessage('從服務器上下載文件失敗,請盡快聯系MIS!' + #13 + e.Message);
Result := False;
end;
end;
try
ftpRmyh.Disconnect;
except
end;
FreeAndNil(ftpRmyh);
end;
function GetFileVersionS: string;
var
V1, V2, V3, V4: Word;
VerInfoSize: DWORD;
VerInfo: Pointer;
VerValueSize: DWORD;
VerValue: PVSFixedFileInfo;
Dummy: DWORD;
FileName: string;
begin
FileName := Application.ExeName;
try
VerInfoSize := GetFileVersionInfoSize(PChar(FileName), Dummy);
GetMem(VerInfo, VerInfoSize);
GetFileVersionInfo(PChar(FileName), 0, VerInfoSize, VerInfo);
VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize);
with VerValue^ do
begin
V1 := dwFileVersionMS shr 16;
V2 := dwFileVersionMS and $FFFF;
V3 := dwFileVersionLS shr 16;
V4 := dwFileVersionLS and $FFFF;
end;
FreeMem(VerInfo, VerInfoSize);
Result := Format('%d.%d.%d.%d', [v1, v2, v3, v4]); // 2.0.0.0
except
end;
end;
procedure SetComboBox(Qry: TQuery; sSQL, sField: string; cbb: TComboBox);
var
strList: TStringList;
i: Integer;
begin
strList := TStringList.Create;
strList := ExcASQL(Qry, sSQL, sField);
for i := 0 to strList.Count - 1 do
begin
cbb.Items.Add(strList.Strings[i]);
end;
FreeAndNil(strList);
end;
procedure SetListBox(Qry: TQuery; sSQL, sField: string; lb: TListBox; bl: Boolean = False);
var
strList: TStringList;
i: Integer;
begin
lb.Items.Clear;
strList := TStringList.Create;
strList := ExcASQL(Qry, sSQL, sField);
for i := 0 to strList.Count - 1 do
begin
if bl and (lb.Items.IndexOf(strList.Strings[i]) >= 0) then //如果BL為True;相同的Item只保留一個
Continue;
lb.Items.Add(strList.Strings[i]);
end;
FreeAndNil(strList);
end;
procedure ExcSQL(var Qry: TQuery; sSQL: string; bl: Boolean = False; param: string = ''; sValue: string = '');
begin
with Qry do
begin
close;
sql.Clear;
SQL.Add(sSQL);
//Prepare;
if param <> '' then
ParamByName(param).AsString := sValue;
if not bl then
ExecSQL
else
Open;
end;
end;
procedure ExcSQL(var Qry: TQuery; sTable, sField, sValue: string);
begin
with Qry do
begin
Close;
sql.Clear;
sql.Add('select * from ' + sTable + ' where ' + sField + ' = ' + QuotedStr(sValue));
Open;
end;
end;
function ExcASQL(Qry: TQuery; sSQL, sField: string): TStringList;
var
sList: TStringList;
begin
sList := TStringList.Create;
with Qry do
begin
close;
sql.Clear;
SQL.Add(sSQL);
Open;
First;
while not eof do
begin
sList.Add(FieldByName(sField).AsString);
Next;
end;
Result := sList;
end;
end;
procedure ExcMulSQL(Qry: TQuery; sList: TStringList; bl: Boolean = False; param: string = ''; sValue: string = '');
var
sSQL: string;
i: integer;
begin
with Qry do
begin
try
//DB.StartTransaction;
for i := 0 to sList.Count - 1 do
begin
sSQL := sList.Strings[i];
ExcSQL(Qry, sSQL, bl, param, sValue);
end;
except
on E: Exception do
begin
//DB.Rollback;
ShowMessage(E.Message);
end;
end;
end;
end;
procedure ExcMulSQL(Qry: TQuery; substr, sStr: string; bl: Boolean = False; param: string = ''; sValue: string = '');
begin
ExcMulSQL(Qry, slipStr(substr, sStr), bl, param, sValue);
end;
function GetFieldValue(Qry: TQuery; sSQL, sField: string): string; //執行SQL並返回值
begin
ExcSQL(Qry, sSQL, True);
Result := Qry.fieldByName(sField).AsString;
end;
function slipStr(substr, str: string): TStringList;
var
iPos: Integer;
sStr: string;
strList: TStringList;
begin
strList := TStringList.Create;
sStr := str;
iPos := Pos(substr, sStr);
while iPos > 0 do
begin
strList.Add(Copy(sStr, 1, iPos - 1));
Delete(sStr, 1, iPos);
iPos := Pos(substr, sStr);
end;
Result := strList;
end;
function ChkEmpExist(Qry: TQuery; emp: string): Boolean; //Check工號是否存在
begin
ExcSQL(qry, 'sfis1.C_emp_desc_t', 'emp_no', emp);
Result := not Qry.Eof;
end;
function ChkEmpBC(Qry: TQuery; empBC: string; emp: string = ''): Boolean; //Check工號和密碼是否匹配
var
sSQL: string;
begin
if emp = '' then
sSQL := 'select * from sfis1.c_emp_desc_t where Quit_Date > Sysdate and emp_BC = ' + Quotedstr(empBC)
else
sSQL := 'select * from sfis1.c_emp_desc_t where Quit_Date > Sysdate and emp_BC = ' + Quotedstr(empBC) +
' and emp_no = ' + Quotedstr(emp);
ExcSQL(Qry, sSQL);
Result := not Qry.Eof;
end;
function ChkEmpPurview(Qry: TQuery; empBC: string; pfun: string; emp: string = ''): Boolean; //Check是否有特定權限
var
sSQL: string;
begin
if emp = '' then
sSQL := 'select A.Emp_NO from sfis1.c_emp_desc_t A, sfis1.c_privilege B ' +
' where A.EMP_NO = B.EMP and A.Quit_Date > Sysdate ' +
' and A.EMP_BC = ' + Quotedstr(empBC) + ' and B.Fun = ' + QuotedStr(pfun)
else
sSQL := 'select A.Emp_NO from sfis1.c_emp_desc_t A, sfis1.c_privilege B ' +
' where A.EMP_NO = B.EMP and A.Quit_Date <= Sysdate ' +
' and A.emp_NO = ' + Quotedstr(emp) + ' and A.EMP_BC = ' + Quotedstr(empBC) +
' and B.Fun = ' + QuotedStr(pfun);
ExcSQL(Qry, sSQL);
Result := not Qry.Eof;
end;
procedure InsertSysLog(Qry: TQuery; Prg_name, Action_type, Action_Desc: string; Emp: string = 'System');
var
sSQL: string;
begin
if emp = 'System' then
emp := GetMyPCName;
sSQL := 'Insert into sfism4.r_system_log_t values(:Emp, :Prg_Name, :Action_Type, :Action_Desc, sysdate)';
with Qry do
begin
close;
sql.Clear;
sql.Add(sSQL);
Prepare;
ParamByName('emp').AsString := Copy(Emp, 1, 25);
ParamByName('Prg_Name').AsString := Prg_Name;
ParamByName('Action_Type').AsString := Action_Type;
ParamByName('Action_Desc').AsString := Action_Desc;
ExecSQL;
end;
end;
function Get_ADODSN(DS_TYPE: string; ADOORA_DSN:TADOConnection): Boolean;
begin
try
try
while HLib = 0 do
begin
HLib := LoadLibrary('SFIS_CON.dll');
if HLib <> 0 then
begin
proGetADO := GetProcAddress(HLib, 'GetADO_DSN');
if @proGetADO <> nil then
proGetADO(ADOORA_DSN, DS_TYPE)
else
raise exception.Create('sfis_con.dll內GetBDE_DSN函數調用失敗!');
end
else
//raise exception.Create('找不到文件sfis_con.dll或文件損壞');
begin
if not Get_File_From_Ftp('/sfis_ams/login/sfis_con.dll', GetCurrentDir + '\sfis_con.dll') then
raise exception.Create('找不到文件sfis_con.dll或文件損壞');
end;
end;
Result := True;
except on e: Exception do
begin
Result := False;
ShowMessage('數據庫連接失敗,系統不能正常運行!' + #13 + e.Message);
end;
end;
finally
//if HLib<>0 then
FreeLibrary(Hlib);
end;
end;
function Get_BDEDSN(DS_TYPE: string; DS_Name: TDatabase): Boolean;
begin
try
try
while HLib = 0 do
begin
HLib := LoadLibrary('SFIS_CON.dll');
if HLib <> 0 then
begin
proGetBDE := GetProcAddress(HLib, 'GetBDE_DSN');
if @proGetBDE <> nil then
proGetBDE(DS_Name, DS_TYPE)
else
raise exception.Create('sfis_con.dll內GetBDE_DSN函數調用失敗!');
end
else
//raise exception.Create('找不到文件sfis_con.dll或文件損壞');
begin
if not Get_File_From_Ftp('/sfis_ams/login/sfis_con.dll', GetCurrentDir + '\sfis_con.dll') then
raise exception.Create('找不到文件sfis_con.dll或文件損壞');
end;
end;
Result := True;
except on e: Exception do
begin
Result := False;
ShowMessage('數據庫連接失敗,系統不能正常運行!' + #13 + e.Message);
end;
end;
finally
//if HLib<>0 then
FreeLibrary(Hlib);
end;
end;
function GetIPAddr: string;
type
TaPInAddr = array[0..10] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
phe: PHostEnt;
pptr: PaPInAddr;
Buffer: array[0..63] of char;
I: Integer;
GInitData: TWSADATA;
begin
WSAStartup($101, GInitData);
Result := '';
GetHostName(Buffer, SizeOf(Buffer));
phe := GetHostByName(buffer);
if phe = nil then
Exit;
pptr := PaPInAddr(Phe^.h_addr_list);
I := 0;
while pptr^[I] <> nil do
begin
result := StrPas(inet_ntoa(pptr^[I]^));
Inc(I);
end;
WSACleanup;
end;
///******************************獲取本機MAC ID*********************************
function GetMAC: string;
var
L_Enum: TLana_Enum;
RetCode: Word;
i: Integer;
begin
L_Enum := NbLanaEnum; { enumerate lanas for WIN NT }
if L_Enum.Length = 0 then
begin
exit;
end;
for i := 0 to (L_Enum.Length - 1) do
begin { for every lana found }
RetCode := NbReset(L_Enum.Lana[i]); { Reset lana for WIN NT }
if RetCode <> NRC_GOODRET then
begin
exit;
end;
if NbGetMacAddr(i) <> '??:??:??:??:??:??' then
Result := Format('%s', [NbGetMacAddr(i)]);
end;
end;
function NbLanaEnum: TLana_Enum;
var
NCB: TNCB;
L_Enum: TLana_Enum;
RetCode: Word;
begin
{$IFDEF WIN32}
FillChar(NCB, SizeOf(NCB), 0);
FillChar(L_Enum, SizeOf(TLana_Enum), 0);
NCB.Command := NCB_ENUM;
NCB.Buf := @L_Enum;
NCB.Length := Sizeof(L_Enum);
RetCode := NetBiosCmd(NCB);
if RetCode <> NRC_GOODRET then
begin
L_Enum.Length := 0;
L_Enum.Lana[0] := Byte(RetCode);
end;
{$ELSE} { not supported for WIN16, fake LANA 0 }
L_Enum.Length := 1;
L_Enum.Lana[0] := 0;
{$ENDIF}
Result := L_Enum;
end;
function NbReset(l: Byte): Word;
var
NCB: TNCB;
begin
{$IFNDEF WIN32} { will reset all your connections for WIN16 }
Result := NRC_GOODRET; { so just fake a reset for Win16 }
{$ELSE}
FillChar(NCB, SizeOf(NCB), 0);
NCB.Command := NCB_RESET;
NCB.Lana_Num := l;
Result := NetBiosCmd(NCB);
{$ENDIF}
end;
function NbGetMacAddr(LanaNum: Integer): string;
var
NCB: TNCB;
AdpStat: TAdpStat;
RetCode: Word;
begin
FillChar(NCB, SizeOf(NCB), 0);
FillChar(AdpStat, SizeOf(AdpStat), 0);
NCB.Command := NCB_ADPSTAT;
NCB.Buf := @AdpStat;
NCB.Length := Sizeof(AdpStat);
FillChar(NCB.CallName, Sizeof(TNBName), $20);
NCB.CallName[0] := Byte('*');
NCB.Lana_Num := LanaNum;
RetCode := NetBiosCmd(NCB);
if RetCode = NRC_GOODRET then
begin
Result := Format('%2.2x:%2.2x:%2.2x:%2.2x:%2.2x:%2.2x',
[AdpStat.ID[0],
AdpStat.ID[1],
AdpStat.ID[2],
AdpStat.ID[3],
AdpStat.ID[4],
AdpStat.ID[5]
]);
end
else
begin
Result := '??:??:??:??:??:??';
end;
end;
///******************************獲取本機MAC ID*********************************
procedure SaveToExcel(DBGrid: TDBGrid; Query: TQuery; var Msg: string);
var
savename, cFieldname, Filename: string;
sString: string;
i, j: Integer;
Clip: TClipboard; // 要宣告此物件
Sheet: Variant;
xLAPP: variant;
SaveDialog: TSaveDialog;
begin
Filename := copy(application.ExeName, length(getcurrentdir) + 2, length(application.exename) - length(getcurrentdir) - 5);
try
XLApp := CreateOleObject('Excel.Application');
XLApp.Visible := True;
XLApp.Workbooks.Add(xlWBatWorkSheet);
XLApp.Workbooks[1].WorkSheets[1].Name := Filename;
except
Msg := 'Could not Start Microsoft Excel.';
Exit;
end;
Query.First;
DBGrid.Visible := FALSE;
XLApp.Worksheets[1].select;
XLApp.Cells.EntireColumn.Font.Size := 10;
for i := 0 to Query.FieldCount - 1 do
begin
sString := sString + DBGrid.Fields[i].FieldName + #9;
end;
sString := sString + #13 + #10; // #13 #10 將游標移至下一列並且到最前面的位置
while not Query.Eof do
begin
for j := 0 to Query.FieldCount - 1 do
begin
cFieldname := DBGrid.Fields[j].FieldName;
sString := sString + Query.FieldByName(cFieldname).asstring + #9;
end;
Query.Next;
sString := sString + #13 + #10; // #13 #10 將游標移至下一列並且到最前面的位置
end;
Clip := Clipboard; // 利用此一物件來存放所有欲丟至 Excel 所有資料
Clip.Clear;
Clip.Open;
Clip.AsText := sString;
Clip.Close;
Sheet := XLApp.Workbooks[1].WorkSheets[Filename];
XLApp.Cells.EntireColumn.NumberFormatLocal := '@';
XLApp.Worksheets[Filename].Paste; // 使用 Paste 方式, 把所有的資料一次丟至 Excel 不用考慮到儲存格位置的問題!!
XLApp.Cells.EntireColumn.AutoFit; // 此指令為自動調整欄寬
DBGRID.Visible := TRUE;
XLApp.Application.Quit;
XLApp := Null;
Msg := 'Save To Excel OK!! ';
end;
procedure SaveToExcelFont(DBGrid: TDBGrid; var Msg: string);
var
iRow, iCol, iTemp: Integer;
zz, sTmp1, sTmp2, Filename: string;
sRange, sTop, sBottom, sSheet: string;
MsExcelWorkBook: Variant;
MsExcel: Variant;
begin
Filename := copy(application.ExeName, length(getcurrentdir) + 2, length(application.exename) - length(getcurrentdir) - 5);
try
MsExcel := CreateOleObject('Excel.Application');
MsExcel.Visible := TRUE;
MsExcelworkBook := MsExcel.Workbooks.Add;
MsExcel.Worksheets[1].name := Filename;
except
Msg := 'Could not Start Microsoft Excel.';
Exit;
end;
try
MsExcel.Worksheets[1].select;
MsExcel.Cells.EntireColumn.Font.Size := 9;
iRow := 0;
DBGrid.DataSource.DataSet.First;
while not DBGrid.DataSource.DataSet.Eof do
begin
for iCol := 0 to DBGrid.DataSource.DataSet.FieldCount - 1 do
begin
if icol < 26 then
begin
if iRow = 0 then
MsExcel.Worksheets[1].Range[Chr(65 + iCol) + IntToStr(iRow +
1)].Value := DBGrid.DataSource.DataSet.Fields[iCol].FieldName
else
MsExcel.Worksheets[1].Range[Chr(65 + iCol) + IntToStr(iRow +
1)].Value := DBGrid.DataSource.DataSet.Fields[iCol].AsString;
MsExcel.Worksheets[1].Range[Chr(65 + iCol) + IntToStr(iRow +
1)].Borders.LineStyle := 1;
if iRow = 0 then
MsExcel.Worksheets[1].Range[Chr(65 + iCol) + IntToStr(iRow +
1)].Interior.ColorIndex := 43;
end
else
begin
sTmp1 := Chr(65 + ((iCol) div 26) - 1);
sTmp2 := Chr(65 + ((iCol) mod 26));
if iRow = 0 then
MsExcel.Worksheets[1].Range[sTmp1 + sTmp2 + IntToStr(iRow +
1)].Value := DBGrid.DataSource.DataSet.Fields[iCol].FieldName
else
MsExcel.Worksheets[1].Range[sTmp1 + sTmp2 + IntToStr(iRow +
1)].Value := DBGrid.DataSource.DataSet.Fields[iCol].AsString;
MsExcel.Worksheets[1].Range[sTmp1 + sTmp2 + IntToStr(iRow +
1)].Borders.LineStyle := 1;
if iRow = 0 then
MsExcel.Worksheets[1].Range[sTmp1 + sTmp2 + IntToStr(iRow +
1)].Interior.ColorIndex := 43;
end;
end;
if iRow > 0 then
DBGrid.DataSource.DataSet.next;
inc(iRow);
end;
MsExcel.Cells.EntireColumn.AutoFit;
MsExcel.Application.Quit;
Msg := 'Save To Excel OK !! ';
except
//SaveTag := False;
MsExcel.Application.Quit;
MsExcel := 'Null';
Msg := 'Save To Microsoft Excel Error...';
Exit;
end;
end;
procedure KillProcess(Curr_App: TApplication); //Kill Process
var
P: Dword;
begin
GetWindowThreadProcessId(Curr_App.Handle, @P);
if P <> 0 then
TerminateProcess(OpenProcess(PROCESS_TERMINATE, False, P), $FFFFFFFF);
end;
function checkprgopen(qry: TQuery; prg_name, ip: string): Boolean;
begin
result := true;
with qry do
begin
close;
sql.Clear;
sql.Add('select * from sfis1.c_parameter_ini where prg_name=:prgname and vr_value=:ip ');
ParamByName('prgname').AsString := prg_name;
ParamByName('ip').AsString := ip;
open;
if recordcount = 0 then
result := false;
end;
end;
end.
