unit uDjcGlobal;
interface
uses ADODB, DB, ShellAPI, uLisPublicVar, Windows, Classes, SysUtils, uListComboBox, uLisSDK,
StrUtils, imm, Math, ExtCtrls, uInterface, uSharedVar, Controls, StdCtrls, jpeg, Graphics,
DateUtils, ShlObj, frxClass, frxDBSet,Printers;
type
TUpMode = (uNone, uInsert, uAppend, uEdit, uDelete);
TItemRecord = record
Code: Integer;
Name: string;
Spec: string;
ItemUnit: string; //单位
ItemPrice: Currency; //单价
ModifyMark: Integer; //可修改标志
end;
TBandType = (PageHeader, PageFooter);
procedure QuickSortt(var A: array of Integer);
function x_round(x: double): double;
function RoundTo1(j: Double; i: integer): string;
function GetArea(code: Integer): string;
procedure IniPhoto(var Bitmap: TBitmap); //清空PHOTO
function ReFile(OldName, NewName: string): Boolean; //改文件名
function MyTrimLeft(const S: string): string;
function MyTrimRight(const S: string): string;
procedure CloseEDTIME(edt: TEdit);
procedure OpenEDTIME(edt: TEdit);
procedure OpenCMBIME(cmb: TComboBox);
procedure GetDicIME(edt: TEdit);
procedure EdtKeyPress(Sender: TObject; var Key: Char);
procedure SetImage(Img: TPicture; Path: string);
function GetItemIndexByStr(str: string; cmb: TComboBox): Integer;
procedure IniImage(Image: TImage);
function GetPy(str: string): string;
function GetWb(str: string): string;
function FindControlByTabOrder(AContainer: TWinControl; ATabOrder: Integer): TWinControl;
procedure EnableEdit(AContainer: TWinControl; Atag: Integer; Enable: Boolean);
{设置下一个光标}
procedure ToNext(Sender: TObject; AContainer: TWinControl; CheckTabStop, OnLast: Boolean);
function QryTempExec(Con: TADOConnection; ASQLText: string; bShowSuccessMsg: Boolean = False):
Boolean; //ulzyFunction.pas中函数
procedure ShowADOErrors(con: TADOConnection); //ulzyFunction.pas中函数
procedure InitDataInListComboBoxBySQL(var AListComboBox: TListComboBox; sSQL:
string; ACon: TADOConnection); //ulzyFunction中的函数
function GetItemRecord(ACode, sType: string; AConn: TADOConnection): TItemRecord;
function ConnExe(Con: TADOConnection; stl: TStringList): Boolean;
function GetStrUnion(str: TStringList): string;
function GetDepOfCurrentOpertator(ADepRange: string): Integer; //ulzyFunction.pas中函数
procedure GetWarehouseListInListCombobox(ADOConn: TADOConnection; AListCombobox: TListCombobox;
bDefaultValue: Boolean = True);
procedure GetPcListInListCombobox(ADOConn: TADOConnection; AListCombobox: TListCombobox;
bDefaultValue: Boolean = True);
procedure GetYfListInListCombobox(ADOConn: TADOConnection; AListCombobox: TListCombobox;
bDefaultValue: Boolean = True);
procedure GetPacsInListCombobox(ADOConn: TADOConnection; AListCombobox: TListCombobox;
bDefaultValue: Boolean = True);
procedure GetPacsTypeLitCombobox(ADOConn: TADOConnection; AListCombobox: TListCombobox;
Condi: string = ' 1=1 '; bDefaultValue: Boolean = True);
procedure GetLisInListCombobox(ADOConn: TADOConnection; AListCombobox: TListCombobox;
bDefaultValue: Boolean = True);
function DropRemoteTable(qry: TADOQuery; TbName: string; DBType: Integer): Boolean;
function SQLTypeToOracleType(stype: string): string;
function MoneyCn(mmje: Double): string;
procedure closeime(handle: THandle); //关闭输入法
procedure SetCapsLockKey(vcode: Integer; down: Boolean);
function SetKey(a: char): char;
procedure CloseCapital;
procedure OpenCapital;
function GetIDInfoGetDInfo(const CardNo: string; var Sex, BirthDay: string; var Age: Integer;
var Area: string): Integer;
///
/// 数据库操作
///
function GetNo(Qry: TADOQuery; TableName, FieldName, WareFieldName, TypeFieldName: string;
WareValue: Integer; TypeValue: string): Integer;
function ExecQuery(qry: TADOQuery; lstr: WideString): Boolean;
function ExeQueryRet(var qry: TADOQuery; lstr: WideString): Integer;
procedure ShowQuery(qry: TADOQuery; lstr: WideString);
procedure ShowQuery1(ads: TADODataSet; lstr: WideString);
procedure IniComboByField(tblName, fldName, OrdFldName: string; cmbName: TComboBox; IsShowNum:
Boolean = True);
function GetCode(str: string): string;
function GetName(str: string): string;
procedure GetAddressName(var Name1, Name2, Name3: string; Code1, Code2, Code3: string);
function HasSubDept: Boolean;
function BoundMat: Boolean;
function MustInputGb: Boolean;
//打开目录
function BrowseCallbackProc(Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer; stdcall;
function BrowseFolder(const Folder: string): string;
///
/// Fastreport报表函数
///
procedure IniReport(var frReport:TfrxReport;var frDbBase:TfrxDBDataset;ReportName: string; qry: TADOQuery);
procedure CreatePage(var Page: TfrxReportPage; frxReport: TfrxReport; iWidth, iHeight: Double;
pDirect: TPrinterOrientation);
procedure CreateBand(var band: TfrxBand; Page: TfrxReportPage; iTop, iHeight: Double; BandType:
TBandType);
procedure CreateDataBand(var band: TfrxMasterData; Page: TfrxReportPage; DbSet: TfrxDBDataset;
iTop, iHeight: Integer);
procedure CreateMemoData(var memView: TfrxMemoView; Band: TfrxBand;
iLeft, iTop, iWidth, iHeight: Extended; fontname: string; fontsize: Integer;
Halign: TfrxHAlign; Valign: TfrxVAlign; frxData: TfrxDBDataset; DField: string;
FrameType: TfrxFrameTypes; Delimiters, ForStr: string; fkKind: TfrxFormatKind);
procedure CreateMemo(var memView: TfrxMemoView; Band: TfrxBand;
iLeft, iTop, iWidth, iHeight: Extended; fontname: string; fontsize: Integer;
Halign: TfrxHAlign; Valign: TfrxVAlign; FrameType: TfrxFrameTypes; sText: string);
implementation
///
/// 执行查询
///
/// 数据集
/// 查询语句
procedure ShowQuery(qry: TADOQuery; lstr: WideString);
begin
if qry.Active then
qry.Close;
qry.Sql.Clear;
qry.Sql.Text := lstr;
qry.Open;
end;
procedure ShowQuery1(ads: TADODataSet; lstr: WideString);
begin
if ads.Active then
ads.Close;
ads.CommandText := lstr;
ads.Open;
end;
///
/// 执行更新语句
///
/// 数据集
/// 更新语句
/// 执行是否成功
function ExecQuery(qry: TADOQuery; lstr: WideString): Boolean;
begin
Result := False;
try
if qry.Active then
qry.Close;
qry.Sql.Clear;
qry.Sql.Text := lstr;
qry.ExecSQL;
Result := True;
except
on e: exception do
TSJLisToolKit.SysMsgBox(e.Message, STOP + OK);
end;
end;
///
/// 执行查询
///
/// ADO连接对象
/// SQL语句
/// 是否显示弹出消息
/// 是否成功
function QryTempExec(Con: TADOConnection; ASQLText: string; bShowSuccessMsg: Boolean = False):
Boolean;
begin
Result := True;
try
Con.Execute(ASQLText);
if bShowSuccessMsg then
TSJLisToolKit.SysMsgBox('执行成功！');
except
Result := False;
ShowADOErrors(Con);
end;
end;
///
/// 显示ADO错误的系统消息
///
/// ADO连接对象
procedure ShowADOErrors(con: TADOConnection);
var
i: Integer;
strErrorList: TStrings;
begin
if not con.Errors.Count > 0 then
Exit;
strErrorList := TStringList.Create;
try
for i := 0 to con.Errors.Count - 1 do
begin
strErrorList.Add(con.Errors.Item[i].Source + ' : ' +
con.Errors.Item[i].Description + ' ; ' +
con.Errors.Item[i].SQLState);
end;
if Trim(strErrorList.Text) = '' then
Exit;
TSJLisToolKit.SysMsgBox(strErrorList.Text, OK + WARN)
finally
strErrorList.Free;
end;
end;
procedure InitDataInListComboBoxBySQL(var AListComboBox:
TListComboBox; sSQL: string; ACon: TADOConnection);
var
FQuery: TADOQuery;
FCode: Integer;
FName, FDesc: string;
begin
if Trim(sSQL) = '' then
Exit;
AListComboBox.Clear;
FQuery := TADOQuery.Create(nil);
with FQuery do
try
Connection := ACon;
SQL.Text := sSQL;
try
Open;
except on e: Exception do
TSJLisToolKit.SysMsgBox('初始化下拉框列表时出现以下错误:' + e.Message, WARN);
end;
if IsEmpty then
Exit;
with AListComboBox do
begin
DeleteAllItem;
First;
while not Eof do
begin
FCode := Fields[0].AsInteger;
FName := Trim(Fields[1].AsString);
{$IFDEF Test}codesite.SendMsg('FName ' + FName); {$ENDIF}
FDesc := Trim(Fields[0].AsString);
InsertItem(FName, FCode, FDesc);
Next;
end;
end;
finally
Free;
end;
end;
function ConnExe(Con: TADOConnection; stl: TStringList): Boolean;
var
i: Integer;
begin
Con.BeginTrans;
try
for i := 0 to stl.Count - 1 do
Con.Execute(stl[i]);
Con.CommitTrans;
Result := True;
except on e: Exception do
begin
Result := False;
Con.RollbackTrans;
TSJLisToolKit.SysMsgBox('保存数据时出现以下错误:' + e.Message, WARN);
end;
end;
end;
{function GetInfo: TFtpInfo;
var
Registry: TRegistry;
begin
Registry := TRegistry.Create;
with Registry do
begin
RootKey := HKEY_CURRENT_CONFIG;
if OpenKey('SJ_FileTransfer', False) = True then
begin
with Result do
begin
FtpPort := ReadString('Ftp_Port');
FileIP := ReadString('FileServer');
UserID := ReadString('UserID');
password := ReadString('Password');
PDFPath := ReadString('PDFPath');
end;
end;
Registry.Free;
end;
end; }
{procedure GetFileList(SDraw: Boolean; path, exts: string; ListItems: TListItems);
var
sr: TSearchRec;
i: Integer;
Item: TListItem;
slist, colNames: TStringList;
sTemp, sExt: string;
col: TListColumn;
begin
if SDraw then
begin
colNames := TStringList.Create;
colNames.CommaText := '名称,大小,修改时间,文件路径';
with TListView(ListItems.Owner) do
begin
Clear;
Columns.Clear;
for i := 0 to colNames.Count - 1 do
begin
col := Columns.Add;
col.Caption := colNames.Strings[i];
case i of
0: col.Width := 150;
1:
begin
col.Width := 77;
col.Alignment := taRightJustify;
end;
2:
begin
col.Width := 114;
col.Alignment := taLeftJustify;
end;
3:
begin
col.Width := 150;
col.Alignment := taLeftJustify;
end;
end;
end;
ViewStyle := vsReport;
end;
colNames.Free;
end;
sTemp := Trim(path);
slist := TStringList.Create;
if Copy(sTemp, Length(sTemp), 1) <> '\' then
sTemp := sTemp + '\';
if FindFirst(path + '*.*', faArchive, sr) = 0 then
begin
repeat
slist.CommaText := exts;
sExt := Trim(UpperCase(ExtractFileExt(sr.Name)));
if length(sExt) = 0 then continue;
if sExt[1] = '.' then sExt := copy(sExt, 2, length(sExt) - 1);
if slist.IndexOf(sExt) < 0 then Continue;
Item := ListItems.Add;
Item.ImageIndex := 1;
Item.Caption := sr.Name;
{$IFDEF Test}//codesite.SendMsg(sr.Name); {$ENDIF}
{ Item.SubItems.Add('');
Item.SubItems.Add(IntToStr(sr.Size));
Item.SubItems.Add(DateTimeToStr(sr.Time));
until FindNext(sr) <> 0;
Sysutils.FindClose(sr);
end;
slist.Free;
end;}
function GetDepOfCurrentOpertator(ADepRange: string):
Integer;
var
iPos: Integer;
begin
Result := 1;
if Trim(ADepRange) = '' then
Exit;
iPos := Pos(',', ADepRange);
if iPos > 0 then
Result := StrToInt(LeftStr(ADepRange, iPos - 1))
else
Result := StrToInt(ADepRange);
end;
procedure QuickSortt(var A: array of Integer);
procedure _QuickSort(var A: array of Integer; iLo, iHi: Integer);
var
Lo, Hi, Mid, T: Integer;
begin
Lo := iLo;
Hi := iHi;
Mid := A[(Lo + Hi) div 2];
repeat
while A[Lo] < Mid do
Inc(Lo);
while A[Hi] > Mid do
Dec(Hi);
if Lo <= Hi then
begin
T := A[Lo];
A[Lo] := A[Hi];
A[Hi] := T;
Inc(Lo);
Dec(Hi);
end;
until Lo > Hi;
if Hi > iLo then
_QuickSort(A, iLo, Hi);
if Lo < iHi then
_QuickSort(A, Lo, iHi);
end;
begin
_QuickSort(A, Low(A), High(A));
end;
function ExeQueryRet(var qry: TADOQuery; lstr: WideString): Integer;
begin
Result := -1;
try
if qry.Active then
qry.Close;
qry.Sql.Clear;
qry.Sql.Text := lstr;
Result := qry.ExecSQL;
except
on e: exception do
TSJLisToolKit.SysMsgBox(e.Message, STOP + OK);
end;
end;
function GetStrUnion(str: TStringList): string;
var
i: Integer;
stlTemp, stlTemp1: TStringList;
s, temp: string;
begin
s := '';
stlTemp := TStringList.Create;
stlTemp1 := TStringList.Create;
for i := 0 to str.Count - 1 do
begin
if Trim(str[i]) = '' then
Continue;
s := s + str[i] + ',';
end;
s := copy(s, 1, Length(s) - 1);
stlTemp.CommaText := s;
stlTemp.Sorted := True;
for i := 0 to stlTemp.Count - 1 do
begin
temp := stlTemp[i];
if stlTemp1.IndexOf(temp) = -1 then
stlTemp1.Add(temp);
end;
Result := stlTemp1.CommaText;
stlTemp.Free;
stlTemp1.Free;
end;
///
/// 获得药房下拉列表数据
///
/// 下拉列表控件名称
/// 设置默认值
procedure GetWarehouseListInListCombobox(ADOConn: TADOConnection; AListCombobox: TListCombobox;
bDefaultValue: Boolean);
var
TempQuery: TADOQuery;
begin
AListCombobox.DeleteAllItem;
TempQuery := TADOQuery.Create(nil);
TempQuery.Connection := ADOConn;
ShowQuery(TempQuery,
'Select WarehouseNo,WarehouseName from XT_WarehouseName where SysName = ''YKGL'' and Remark=0 Order by WarehouseNo');
with TempQuery do
try
First;
while not Eof do
begin
AListCombobox.InsertItem(Trim(FieldByName('WarehouseName').AsString),
FieldByName('WarehouseNo').AsInteger, '');
Next;
end;
if bDefaultValue then
if AListCombobox.Items.Count > 1 then
AListCombobox.ItemIndex := 1;
finally
Free;
end;
end;
procedure GetPacsInListCombobox(ADOConn: TADOConnection; AListCombobox: TListCombobox;
bDefaultValue: Boolean = True);
var
TempQuery: TADOQuery;
begin
AListCombobox.DeleteAllItem;
TempQuery := TADOQuery.Create(nil);
TempQuery.Connection := ADOConn;
ShowQuery(TempQuery,
'Select Code,NameCn,Name from Pacs_Modality where StopMark=0 Order by Code');
with TempQuery do
try
First;
while not Eof do
begin
AListCombobox.InsertItem(Trim(FieldByName('NameCn').AsString),
FieldByName('Code').AsInteger, Trim(FieldByName('Name').AsString));
Next;
end;
if bDefaultValue then
if AListCombobox.Items.Count > 1 then
AListCombobox.ItemIndex := 1;
finally
Free;
end;
end;
procedure GetPacsTypeLitCombobox(ADOConn: TADOConnection; AListCombobox: TListCombobox;
Condi: string = ' 1=1 '; bDefaultValue: Boolean = True);
var
TempQuery: TADOQuery;
begin
AListCombobox.DeleteAllItem;
TempQuery := TADOQuery.Create(nil);
TempQuery.Connection := ADOConn;
ShowQuery(TempQuery,
'Select Code,Name from Pacs_StudyType where StopMark=0 and ' + Condi + ' Order by Code');
with TempQuery do
try
First;
while not Eof do
begin
AListCombobox.InsertItem(Trim(FieldByName('Name').AsString),
FieldByName('Code').AsInteger, '');
Next;
end;
if bDefaultValue then
if AListCombobox.Items.Count > 1 then
AListCombobox.ItemIndex := 1;
finally
Free;
end;
end;
procedure GetLisInListCombobox(ADOConn: TADOConnection; AListCombobox: TListCombobox;
bDefaultValue: Boolean = True);
var
TempQuery: TADOQuery;
begin
AListCombobox.DeleteAllItem;
TempQuery := TADOQuery.Create(nil);
TempQuery.Connection := ADOConn;
ShowQuery(TempQuery,
'Select Code,WorkSheetType from HLIS_Worksheet_type where StopMark=0 Order by Code');
with TempQuery do
try
First;
while not Eof do
begin
AListCombobox.InsertItem(Trim(FieldByName('WorkSheetType').AsString),
FieldByName('Code').AsInteger, '');
Next;
end;
if bDefaultValue then
if AListCombobox.Items.Count > 1 then
AListCombobox.ItemIndex := 1;
finally
Free;
end;
end;
///
/// 获得用法下拉列表数据
///
/// 下拉列表控件名称
/// 设置默认值
procedure GetYfListInListCombobox(ADOConn: TADOConnection; AListCombobox: TListCombobox;
bDefaultValue: Boolean);
var
TempQuery: TADOQuery;
i: Integer;
begin
AListCombobox.DeleteAllItem;
TempQuery := TADOQuery.Create(nil);
TempQuery.Connection := ADOConn;
i := 0;
ShowQuery(TempQuery,
'Select Code,Name,SubMark from XT_GENERAL_NAMES where SysName = ''BQGL'' and Cmark=''使用方法'' Order by Code');
with TempQuery do
try
First;
while not Eof do
begin
Inc(i);
AListCombobox.InsertItem(IntToStr(i) + '.' + Trim(FieldByName('Name').AsString),
FieldByName('Code').AsInteger, Trim(FieldByName('SubMark').AsString));
Next;
end;
if bDefaultValue then
if AListCombobox.Items.Count > 1 then
AListCombobox.ItemIndex := 1;
finally
Free;
end;
end;
procedure GetPcListInListCombobox(ADOConn: TADOConnection; AListCombobox: TListCombobox;
bDefaultValue: Boolean);
var
TempQuery: TADOQuery;
i: Integer;
begin
AListCombobox.DeleteAllItem;
TempQuery := TADOQuery.Create(nil);
TempQuery.Connection := ADOConn;
i := 0;
ShowQuery(TempQuery,
'Select Code,Name,SubMark from XT_GENERAL_NAMES where SysName = ''BQGL'' and Cmark=''使用频次'' Order by Code');
with TempQuery do
try
First;
while not Eof do
begin
Inc(i);
AListCombobox.InsertItem(IntToStr(i) + '.' + Trim(FieldByName('Name').AsString),
FieldByName('Code').AsInteger, Trim(FieldByName('SubMark').AsString));
Next;
end;
if bDefaultValue then
if AListCombobox.Items.Count > 1 then
AListCombobox.ItemIndex := 1;
finally
Free;
end;
end;
function SQLTypeToOracleType(stype: string): string;
begin
if UpperCase(stype) = 'BIGINT' then
result := 'NUMBER(19)'
else if UpperCase(stype) = 'BINARY' then
result := 'RAW(50)'
else if UpperCase(stype) = 'BIT' then
result := 'NUMBER(2)'
else if UpperCase(stype) = 'CHAR' then
result := 'CHAR'
else if UpperCase(stype) = 'DATETIME' then
result := 'DATE'
else if UpperCase(stype) = 'DECIMAL' then
result := 'NUMBER(18)'
else if UpperCase(stype) = 'FLOAT' then
result := 'BINARY_DOUBLE(18)'
else if UpperCase(stype) = 'IMAGE' then
result := 'BLOB'
else if UpperCase(stype) = 'INT' then
result := 'NUMBER(10)'
else if UpperCase(stype) = 'MONEY' then
result := 'NUMBER(19,4)'
else if UpperCase(stype) = 'NCHAR' then
result := 'NCHAR'
else if UpperCase(stype) = 'NTEXT' then
result := 'NCLOB'
else if UpperCase(stype) = 'NUMERIC' then
result := 'NUMBER(18)'
else if UpperCase(stype) = 'NVARCHAR' then
result := 'NVARCHAR(50)'
else if UpperCase(stype) = 'REAL' then
result := 'BINARY_FLOAT'
else if UpperCase(stype) = 'SMALLDATETIME' then
result := 'DATE'
else if UpperCase(stype) = 'SMALLINT' then
result := 'NUMBER(5)'
else if UpperCase(stype) = 'SMALLMONEY' then
result := 'NUMBER(10,4)'
else if UpperCase(stype) = 'SQL_VARIANT' then
result := 'BLOB'
else if UpperCase(stype) = 'TEXT' then
result := 'CLOB'
else if UpperCase(stype) = 'TIMESTAMP' then
result := 'RAW(8)'
else if UpperCase(stype) = 'TINYINT' then
result := 'NUMBER(3)'
else if UpperCase(stype) = 'UNIQUEIDENTIFIER' then
result := 'BLOB'
else if UpperCase(stype) = 'VARBINARY' then
result := 'RAW(50)'
else if UpperCase(stype) = 'VARCHAR' then
result := 'VARCHAR2'
end;
function x_round(x: double): double;
var
x10: double;
xx: integer;
begin
x10 := abs(x) * 100 + 0.5;
xx := trunc(x10);
result := xx / 100;
if x < 0 then
result := -result;
end;
function DropRemoteTable(qry: TADOQuery; TbName: string; DBType: Integer): Boolean;
var
SQLSTR: string;
begin
if DBType = 0 then
begin
SQLSTR := ' if exists (select * from dbo.sysobjects where id = object_id(N' +
QuotedStr(TbName) + ' ) and OBJECTPROPERTY(id, N''IsUserTable'') = 1)' +
' drop table ' + TbName;
ExecQuery(qry, SQLSTR);
end
else if DBType = 1 then
begin
SQLSTR := 'select count(*) from user_all_tables where TABLE_NAME=''' + Uppercase(TbName) +
'''';
ShowQuery(qry, SQLSTR);
if qry.Fields[0].AsInteger > 0 then
begin
ExecQuery(qry, 'truncate table ' + Uppercase(TbName));
ExecQuery(qry, 'drop table ' + Uppercase(TbName));
end;
end;
end;
function MoneyCn(mmje: Double): string;
const
s1: string = '零壹贰叁肆伍陆柒捌玖';
s2: string = '分角元拾佰仟万拾佰仟亿拾佰仟万';
function StrTran(const S, s1, s2: string): string;
begin
Result := StringReplace(S, s1, s2, [rfReplaceAll]);
end;
var
S, dx: string;
i, Len: Integer;
begin
if mmje < 0 then
begin
dx := '负';
mmje := -mmje;
end;
S := Format('%.0f', [mmje * 100]);
Len := Length(S);
for i := 1 to Len do
dx := dx + Copy(s1, (Ord(S[i]) - Ord('0')) * 2 + 1, 2) + Copy(s2, (Len - i)
* 2 + 1, 2);
dx := StrTran(StrTran(StrTran(StrTran(StrTran(dx, '零仟', '零'), '零佰',
'零'),
'零拾', '零'), '零角', '零'), '零分', '整');
dx := StrTran(StrTran(StrTran(StrTran(StrTran(dx, '零零', '零'), '零零',
'零'),
'零亿', '亿'), '零万', '万'), '零元', '元');
if dx = '整' then
Result := '零元整'
else
Result := StrTran(StrTran(dx, '亿万', '亿零'), '零整', '整');
end;
procedure closeime(handle: THandle);
var
myhkl: hkl;
begin
myhkl := GetKeyBoardLayOut(0);
if ImmIsIME(myhkl) then //判断是否在中文状态,若是则关闭它
immsimulateHotkey(handle, IME_CHotKey_IME_NonIME_Toggle);
end;
procedure SetCapsLockKey(vcode: Integer; down: Boolean);
begin
if Odd(GetAsyncKeyState(vcode)) <> down then
begin
keybd_event(vcode, MapVirtualkey(vcode, 0),
KEYEVENTF_EXTENDEDKEY, 0);
keybd_event(vcode, MapVirtualkey(vcode, 0),
KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP, 0);
end;
if Odd(GetAsyncKeyState(vcode)) <> down then
begin
keybd_event(vcode, MapVirtualkey(vcode, 0),
KEYEVENTF_EXTENDEDKEY, 0);
keybd_event(vcode, MapVirtualkey(vcode, 0),
KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP, 0);
end;
end;
function MyTrimLeft(const S: string): string;
var
ci, sl: integer;
c: char;
begin
ci := 1; sl := length(S);
while (ci <= sl) do
begin
c := S[ci];
case c of
' ': inc(ci);
#161: if (ci < sl) and (S[ci + 1] = c) then
inc(ci, 2);
else
break;
end;
end;
Result := Copy(S, ci, sl);
end;
function MyTrimRight(const S: string): string;
var
ci, sl: integer;
c: char;
begin
sl := length(S);
ci := sl;
while (ci >= 0) do
begin
c := S[ci];
case c of
' ': Dec(ci);
#161: if (ci <= sl) and (S[ci - 1] = c) then
Dec(ci, 2);
else
break;
end;
end;
Result := Copy(S, 1, ci);
end;
function SetKey(a: char): char;
begin
case a of
'a': Result := 'A';
'b': Result := 'B';
'c': Result := 'C';
'd': Result := 'D';
'e': Result := 'E';
'f': Result := 'F';
'g': Result := 'G';
'h': Result := 'H';
'i': Result := 'I';
'j': Result := 'J';
'k': Result := 'K';
'l': Result := 'L';
'm': Result := 'M';
'n': Result := 'N';
'o': Result := 'O';
'p': Result := 'P';
'q': Result := 'Q';
'r': Result := 'R';
's': Result := 'S';
't': Result := 'T';
'u': Result := 'U';
'v': Result := 'V';
'w': Result := 'W';
'x': Result := 'X';
'y': Result := 'Y';
'z': Result := 'Z';
else
Result := a;
end;
end;
function RoundTo1(j: Double; i: integer): string;
begin
Result := FloatToStr(RoundTo(j, i));
end;
function GetNo(Qry: TADOQuery; TableName, FieldName, WareFieldName, TypeFieldName: string;
WareValue: Integer; TypeValue: string): Integer;
var
str: string;
max: Integer;
begin
Result := 0;
str := 'select max(' + FieldName + ') from ' + TableName + ' where ' + WareFieldName + '=' +
IntToStr(WareValue) +
' and ' + TypeFieldName + ' in ' + TypeValue;
ShowQuery(Qry, str);
if (Qry.IsEmpty) then
max := 0
else
begin
max := Qry.Fields[0].AsInteger;
end;
Result := max + 1;
end;
function GetBillNo(Qry: TADOQuery; WareValue, iType: Integer): Integer;
var
str: string;
max: Integer;
begin
Result := 0;
case iType of
0:
begin
Result := TSJDbToolKit.DataProcessLoader.GetISysADOQ.Get_no('GDZC_BOOK', 'BillNo',
'WarehouseNo',
0, WareValue, False);
end;
1:
begin
str := 'select max(billno) from GDZC_BOOK where WAREHOUSENO=' + IntToStr(WareValue) +
' and Type<=4 ';
ShowQuery(Qry, str);
if Qry.Fields[0].IsNull then
max := 1000000
else if Qry.Fields[0].AsInteger < 1000000 then
max := 1000000
else
max := Qry.Fields[0].AsInteger;
end;
2:
begin
str := 'select max(billno) from GDZC_BOOK where WAREHOUSENO=' + IntToStr(WareValue) +
' and Type>4 ';
ShowQuery(Qry, str);
if Qry.Fields[0].IsNull then
max := 2000000
else if Qry.Fields[0].AsInteger < 2000000 then
max := 2000000
else
max := Qry.Fields[0].AsInteger;
end;
end;
Result := max + 1;
end;
function HasSubDept: Boolean;
var
i: Integer;
getconfig: TGetParamValue;
begin
Result := False;
getconfig := TSJLisBusinessToolKit.XTGL_GET_CONFIG('CLGL', '是否使用二级科室',
'CLGL_DialToDepartment.dll', False);
if getconfig.Succeeded then
begin
i := getconfig.Value;
Result := (i = 1);
end;
end;
function BoundMat: Boolean;
var
i: Integer;
getconfig: TGetParamValue;
begin
Result := True;
getconfig := TSJLisBusinessToolKit.XTGL_GET_CONFIG('CLGL', '是否绑定病区材料',
'CLGL_Dictionary.dll', False);
if getconfig.Succeeded then
begin
i := getconfig.Value;
Result := (i <> 0);
end;
end;
function MustInputGb: Boolean;
var
i: Integer;
getconfig: TGetParamValue;
begin
Result := True;
getconfig := TSJLisBusinessToolKit.XTGL_GET_CONFIG('GDZC', '是否必须输入国标编码',
'GDZC_Dictionary.dll', False);
if getconfig.Succeeded then
begin
i := getconfig.Value;
Result := (i <> 0);
end;
end;
function FindControlByTabOrder(AContainer: TWinControl; ATabOrder: Integer): TWinControl;
var
index: Integer;
CurControl: TWinControl;
begin
for index := 0 to AContainer.ControlCount - 1 do
begin
CurControl := TWinControl(AContainer.Controls[index]);
if CurControl.TabOrder = ATabOrder then
begin
Result := CurControl;
Exit;
end;
end;
Result := nil;
end;
procedure EnableEdit(AContainer: TWinControl; Atag: Integer; Enable: Boolean);
var
index: Integer;
begin
for index := 0 to AContainer.ControlCount - 1 do
begin
if Atag = -1 then {忽略控件的tag}
AContainer.Controls[index].Enabled := Enable
else
begin {控件的tag为Atag}
if AContainer.Controls[index].tag = Atag then
AContainer.Controls[index].Enabled := Enable;
end; // end of if
end; //end of for
end;
procedure ToNext(Sender: TObject; AContainer: TWinControl; CheckTabStop, OnLast: Boolean);
var
index, sndTabOrder: Integer;
CurControl: TWinControl;
Count: Integer;
begin
if Sender is TWinControl then
begin
sndTabOrder := (Sender as TWinControl).TabOrder;
end
else
Exit;
Count := 0;
for index := 0 to AContainer.ControlCount - 1 do
begin
if AContainer.Controls[index] is TWinControl then
Inc(Count)
else
Continue;
end;
for index := sndTabOrder + 1 to Count - 1 do
begin
CurControl := FindControlByTabOrder(AContainer, index);
if CurControl = nil then
Continue;
if (Trim(TCustomEdit(CurControl).Text) = '') or
(Trim(TComboBox(CurControl).Text) = '') then
begin
if (CurControl.CanFocus) and (not CheckTabStop or CurControl.TabStop) then
begin
CurControl.SetFocus;
Break;
end;
end;
if (OnLast) and (index = Count - 1) then //到最后一个
begin
if (CurControl.CanFocus) and (not CheckTabStop or CurControl.TabStop) then
CurControl.SetFocus;
end;
end;
end;
procedure SetImage(Img: TPicture; Path: string);
var
Extension: string;
Jpeg: TJPEGImage;
begin
Extension := UpperCase(Copy(Path, Length(Path) - 2, 3));
if Extension = 'BMP' then
Img.Bitmap.LoadFromFile(Path)
else if Extension = 'JPG' then
begin
Jpeg := TJPEGImage.Create;
Jpeg.LoadFromFile(Path);
Img.Bitmap.Assign(Jpeg);
Jpeg.Free;
end;
end;
///
/// 获得区域名
///
///
///
function GetArea(code: Integer): string;
var
TempQry: TADOQuery;
begin
TempQry := TADOQuery.Create(nil);
TempQry.Connection := TSJDbToolKit.GetRemoteAdoConnection;
ShowQuery(TempQry, 'select code,name from MZGH_AREA where code=' + IntToStr(code));
if not TempQry.IsEmpty then
Result := Trim(TempQry.Fieldbyname('name').AsString);
TempQry.Free;
end;
procedure IniPhoto(var Bitmap: TBitmap);
begin
Bitmap := nil;
end;
///
/// fldName有两列，编码和列
///
///
///
///
///
///
procedure IniComboByField(tblName, fldName, OrdFldName: string; cmbName: TComboBox; IsShowNum:
Boolean);
var
qryTemp: TADOQuery;
begin
qryTemp := TADOQuery.Create(nil);
cmbName.Items.Clear;
cmbName.Items.Add('');
qryTemp.Connection := TSJDbToolKit.GetRemoteAdoConnection;
ShowQuery(qryTemp, 'select distinct ' + fldName + ' from ' + tblName + ' order by ' +
OrdFldName);
if not qryTemp.IsEmpty then
begin
qryTemp.First;
while not qryTemp.Eof do
begin
if not IsShowNum then
cmbName.Items.Add(Trim(qryTemp.Fields[1].AsString))
else
cmbName.Items.Add(Trim(qryTemp.Fields[0].AsString + '.' + qryTemp.Fields[1].AsString));
qryTemp.Next;
end;
end;
qryTemp.Free;
end;
function GetName(str: string): string;
var
i: Integer;
begin
Result := '';
i := Pos('.', str);
if i > 0 then
Result := Copy(str, i + 1, Length(str) - i);
end;
function GetCode(str: string): string;
var
i: Integer;
begin
Result := '';
i := Pos('.', str);
if i > 0 then
Result := Copy(str, 1, i - 1);
end;
procedure GetAddressName(var Name1, Name2, Name3: string; Code1, Code2, Code3: string);
var
qryTemp: TADOQuery;
begin
qryTemp := TADOQuery.Create(nil);
qryTemp.Connection := TSJDbToolKit.GetRemoteAdoConnection;
ShowQuery(qryTemp, 'select distinct grade1name from mzgh_address_1 where grade1code=' + Code1);
if not qryTemp.IsEmpty then
Name1 := Trim(qryTemp.Fields[0].AsString);
ShowQuery(qryTemp, 'select distinct grade2name from mzgh_address_1 where grade1code=' + Code1 +
' and grade2code=' + Code2);
if not qryTemp.IsEmpty then
Name2 := Trim(qryTemp.Fields[0].AsString);
ShowQuery(qryTemp, 'select distinct grade3name from mzgh_address_1 where grade1code=' + Code1 +
' and grade2code=' + Code2 + ' and grade3code=' + Code3);
if not qryTemp.IsEmpty then
Name3 := Trim(qryTemp.Fields[0].AsString);
qryTemp.Free;
end;
function GetItemIndexByStr(str: string; cmb: TComboBox): Integer;
var
i: Integer;
begin
for i := 0 to cmb.Items.Count do
begin
if Pos(str, cmb.Items[i]) > 0 then
begin
Result := i;
Break;
end;
end;
end;
function GetIDInfoGetDInfo(const CardNo: string; var Sex,
BirthDay: string; var Age: Integer; var Area: string): Integer;
var
iCardNo: Int64;
iYear, iSex: Integer;
sBirth, fBirth: string;
dBirth: TDateTime;
begin
Result := 0; //表示身份证输入正确
if (Length(CardNo) <> 15) and (Length(CardNo) <> 18) then
begin
Result := 1; //位长不对
Exit;
end;
if Length(CardNo) = 15 then
begin
if not TryStrToInt64(CardNo, iCardNo) then
begin
Result := 2; //必须为数字
Exit;
end;
sBirth := '19' + Copy(CardNo, 7, 6);
iSex := StrToInt(Copy(CardNo, 15, 1));
if Odd(iSex) then
Sex := '男'
else
Sex := '女';
end
else
begin
if not TryStrToInt64(Copy(CardNo, 1, 17), iCardNo) then
begin
Result := 2; //前17位必须为数字
Exit;
end;
sBirth := Copy(CardNo, 7, 8);
iSex := StrToInt(Copy(CardNo, 17, 1));
case iSex of
0: Sex := '未知';
1: Sex := '男';
2: Sex := '女';
9: Sex := '未说明';
end;
end;
fBirth := Format('%s-%s-%s', [Copy(sBirth, 1, 4),
Copy(sBirth, 5, 2), Copy(sBirth, 7, 2)]);
if not TryStrToDate(fBirth, dBirth) then
begin
Result := 3; //生日格式不对
Exit;
end;
iYear := YearsBetween(Date, dBirth);
if (iYear < 0) or (iYear >= 120) then
begin
Result := 4; //年龄错误
Exit;
end;
BirthDay := sBirth;
Age := iYear;
Area := GetArea(StrToInt(Copy(CardNo, 1, 2)));
end;
procedure CloseEDTIME(edt: TEdit);
var
KeyStates: TKeyboardState;
begin
GetKeyboardState(KeyStates);
if (KeyStates[VK_CAPITAL] = 1) then
begin
SetCapsLockKey(VK_CAPITAL, TRUE); //关大写
end;
Closeime(edt.Handle);
end;
procedure OpenEDTIME(edt: TEdit);
var
KeyStates: TKeyboardState;
begin
GetKeyboardState(KeyStates);
if (KeyStates[VK_CAPITAL] = 1) then
begin
SetCapsLockKey(VK_CAPITAL, TRUE); //关大写
end;
edt.ImeMode := imChinese;
edt.ImeName := ShareGlobalVar.GlobalVar.GetImeName;
edt.ImeMode := imOpen;
end;
procedure GetDicIME(edt: TEdit);
var
KeyStates: TKeyboardState;
begin
GetKeyboardState(KeyStates);
if (KeyStates[VK_CAPITAL] = 0) then
begin
SetCapsLockKey(VK_CAPITAL, TRUE); //开大写
end;
Closeime(edt.Handle); //关输入法
end;
procedure OpenCMBIME(cmb: TComboBox);
var
KeyStates: TKeyboardState;
begin
GetKeyboardState(KeyStates);
if (KeyStates[VK_CAPITAL] = 1) then
begin
SetCapsLockKey(VK_CAPITAL, TRUE); //关大写
end;
cmb.ImeMode := imChinese;
cmb.ImeName := ShareGlobalVar.GlobalVar.GetImeName;
cmb.ImeMode := imOpen;
end;
procedure CloseCapital;
var
KeyStates: TKeyboardState;
begin
GetKeyboardState(KeyStates);
if (KeyStates[VK_CAPITAL] = 1) then
begin
SetCapsLockKey(VK_CAPITAL, TRUE); //关大写
end;
end;
procedure OpenCapital;
var
KeyStates: TKeyboardState;
begin
GetKeyboardState(KeyStates);
if (KeyStates[VK_CAPITAL] = 0) then
begin
SetCapsLockKey(VK_CAPITAL, TRUE); //开大写
end;
end;
procedure IniImage(Image: TImage);
begin
Image.Picture := nil;
end;
procedure EdtKeyPress(Sender: TObject; var Key: Char);
begin
if not (Key in ['0'..'9', #8, #13]) then
Key := #0;
end;
function GetPy(str: string): string;
begin
Result := UpperCase(TSJDbToolKit.DataProcessLoader.GetISysADOQ.Return_PYM(str));
end;
function GetWb(str: string): string;
begin
Result := UpperCase(TSJDbToolKit.DataProcessLoader.GetISysADOQ.Return_WBM(str));
end;
function ReFile(OldName, NewName: string): Boolean;
var
Fo: TSHFileOpStruct;
begin
FillChar(Fo, SizeOf(Fo), 0);
with Fo do
begin
Wnd := 0;
wFunc := FO_RENAME;
pFrom := PChar(OldName + #0);
pTo := PChar(NewName + #0);
fFlags := FOF_NOCONFIRMATION + FOF_SILENT;
end;
Result := (SHFileOperation(Fo) = 0);
end;
function BrowseCallbackProc(Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer; stdcall;
begin
case uMsg of
BFFM_INITIALIZED: SendMessage(Wnd, BFFM_SETSELECTION, 1, lpData);
end;
Result := 0;
end;
function BrowseFolder(const Folder: string): string;
var
TitleName: string;
lpItemID: PItemIDList;
BrowseInfo: TBrowseInfo;
DisplayName: array[0..MAX_PATH] of char;
TempPath: array[0..MAX_PATH] of char;
begin
Result := Folder;
FillChar(BrowseInfo, sizeof(TBrowseInfo), #0);
BrowseInfo.hwndOwner := GetActiveWindow;
BrowseInfo.pszDisplayName := @DisplayName;
TitleName := '请选择一个目录';
BrowseInfo.lpszTitle := PChar(TitleName);
BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS;
BrowseInfo.lpfn := BrowseCallbackProc;
BrowseInfo.lParam := Integer(PChar(Folder));
lpItemID := SHBrowseForFolder(BrowseInfo);
if Assigned(lpItemId) then
begin
SHGetPathFromIDList(lpItemID, TempPath);
GlobalFreePtr(lpItemID);
Result := string(TempPath);
end
else
Result := '';
end;
procedure IniReport(var frReport:TfrxReport;var frDbBase:TfrxDBDataset;ReportName: string; qry: TADOQuery);
begin
frReport.clear;
frReport.LoadFromFile(ReportName);
frReport.DataSets.Clear;
frDbBase.DataSet := qry;
frReport.DataSets.Add(frDbBase);
end;
procedure CreatePage(var Page: TfrxReportPage;
frxReport: TfrxReport; iWidth, iHeight: Double;
pDirect: TPrinterOrientation);
begin
Page := TfrxReportPage.Create(frxReport);
Page.CreateUniqueName;
Page.PaperWidth := iWidth;
Page.Height := iHeight;
Page.Orientation := pDirect;
end;
procedure CreateBand(var band: TfrxBand; Page: TfrxReportPage; iTop,
iHeight: Double; BandType: TBandType);
begin
case BandType of
PageHeader: band := TfrxPageHeader.Create(Page);
PageFooter: band := TfrxPageFooter.Create(Page);
end;
band.CreateUniqueName;
band.Top := iTop;
band.Height := iHeight;
end;
procedure CreateDataBand(var band: TfrxMasterData;
Page: TfrxReportPage; DbSet: TfrxDBDataset; iTop, iHeight: Integer);
begin
band := TfrxMasterData.Create(Page);
band.CreateUniqueName;
band.DataSet := DbSet;
band.Top := iTop;
band.Height := iHeight;
end;
procedure CreateMemo(var memView: TfrxMemoView; Band: TfrxBand;
iLeft, iTop, iWidth, iHeight: Extended; fontname: string;
fontsize: Integer; Halign: TfrxHAlign; Valign: TfrxVAlign;
FrameType: TfrxFrameTypes; sText: string);
begin
memView := TfrxMemoView.Create(Band);
memView.CreateUniqueName;
memView.ParentFont := False;
memView.Font.Name := fontname;
memView.Font.Size := fontsize;
memView.SetBounds(iLeft, iTop, iWidth, iHeight);
memView.HAlign := Halign;
memView.VAlign := Valign;
memView.Frame.Typ := FrameType;
memView.Memo.Text := sText;
end;
procedure CreateMemoData(var memView: TfrxMemoView; Band: TfrxBand;
iLeft, iTop, iWidth, iHeight: Extended; fontname: string;
fontsize: Integer; Halign: TfrxHAlign; Valign: TfrxVAlign;
frxData: TfrxDBDataset; DField: string; FrameType: TfrxFrameTypes;
Delimiters, ForStr: string; fkKind: TfrxFormatKind);
begin
memView := TfrxMemoView.Create(Band);
memView.CreateUniqueName;
memView.ParentFont := False;
memView.Font.Name := fontname;
memView.Font.Size := fontsize;
memView.SetBounds(iLeft, iTop, iWidth, iHeight);
memView.HAlign := Halign;
memView.VAlign := Valign;
memView.DataSet := frxData;
memView.DataField := DField;
memView.Frame.Typ := FrameType;
memView.ExpressionDelimiters := Delimiters;
memView.DisplayFormat.FormatStr := ForStr;
memView.DisplayFormat.Kind := fkKind;
end;
end.
