func.pas
来自「适合行业为眼镜业」· PAS 代码 · 共 980 行 · 第 1/2 页
PAS
980 行
unit func;
interface
uses
Windows,DB,SysUtils,dbtables,Dialogs,registry,menus,Forms,jpeg,SConnect,ObjBrkr,
graphics,classes,DBGrids,StdCtrls, GD_Chain_Server_TLB,variants,ComCtrls,ExtCtrls,DBClient,Grids;
Function WriteRegFile(menth:integer;keyname:String;Regkey:variant):variant;
Function ReadRegFile(menth:integer;keyname:String):variant;
Function ExistsRegKey(keyname:string):boolean;
Function DeleteRegKey(keyname:string):boolean;
Function GetFontStyle(FontNo:integer):TFontStyles;
Function Encrypt(EncryptStr,EncryptKey:string):string;
Function Decrypt(DecryptStr,EncryptKey:string):string;
Function Small2Big(SourceMoney:Currency):string;
procedure setnull(f_from:TForm);
procedure createinter; //创建接口 wg
procedure detroy; //释放接口; wg
function Cmd_Check_Filsh(no:string):boolean; //检查审核是否审核完毕 wg
function setCode(sql:string;maks:string):string; //auto id; wg
function selectpy( values:string):string; //拼音转换; wg
procedure ckbEdit(ckb:TCheckBox;edt:TEdit);///
procedure ckbEdits(ckb:TCheckBox;edt1,edt2:TEdit); //
procedure ckbCmb(ckb:TCheckBox;cmb:TComboBox);//
procedure ckbDtps(ckb:TCheckBox;dtp1,dtp2:TDateTimePicker);//控制
///2004-4-9 add 用于从服务器取得本部门人员等
procedure GetDataToComBoX(cmbman:TcomboBox;tempsql:string;XsFieldName:string);
procedure loadborlanced(cdsname:TClientDataSet); //负载纠错；
function simpe(sockets:TSocketConnection;simpename:TSimpleObjectBroker):boolean;
procedure savefromdata(cdsname:TClientDataSet;dataname:string);//存储数据
function GetKeyFieldValue(sortField:string;clientdb:TClientDataSet): OleVariant;
//procedure DeleteRow(Row:Integer);
procedure getlock(m:string;index,count:integer);
function SetPass(List_No:string):boolean; //单据只能出现一次；
function SetPassed(List_No:string):boolean;
procedure SortGrid(filedbynames:string;CdsTable:Tclientdataset;GridBase:tdbgrid;column: TColumn); //排序
procedure GetValuesData(Mcmb:tcombobox); //获得数据；
procedure SetValuesData (Mcmb:tcombobox); //取数据;
procedure SetDbgrid( grid:tdbgrid;index:integer); //设置DBGRID的固定列
function DelRow(var StrGrid:TStringGrid;Arow:integer):boolean;
function clearGrid(var Grid:TStringGrid):boolean;
procedure RefreshOrd(var Grid:TStringGrid);
function GetDataPrint(recipient,GETclient:tClientdataset):boolean;
procedure GetCopyGrid(souce,client:tstringgrid);
var
dbgCur:TDBGrid; //网格
no,typed:widestring; //wg edit ; 单句编号和类别名称
Font_Style:array[0..4] of TFontStyles;
//***级别审核************
tempselect:string;
man_Select:String;//审核人员
man_no:string;//审核人编号;
Man_Public_Code:string; //审核代码('SH_01,SH_02,SH_03,SH_04,SH_05)
LevelType{单据名称},LevelCount{审核级数},ExamineMan{审核人员}:String;
LevelSeries:string;//所属级别
//***级别审核************
//商品类别选择
CheckDo:String;//基本信息窗体中选择操作对象；
Do_Result:String;//基本信息窗体中选择操作对象选择结果；
Public_Do:String;
Public_Do_Result:String;
String_Col:Integer; //Stringrid 的第几行
Check_Mond,check_Mond_Result:String;
Check_Storage,Check_Storage_Result,Check_Storage_Result_NO:String;
Employe_Check,Employe_Check_Result,Employe_type:String;
//*********商品基本信息窗体的公共操作部分********************
Subject_Str:string;//操作对象
Subject_No:string; //选择结果
Subject_Name:string; //选择结果
Subject_Back:string; //选择结果
Subject_Facility:string; //选择结果
//*****************************
G_Modal,G_Cards,G_Brand:String;
//************************审核****************************
Collate_Str,Collate_Result:String;
SH_Level:Integer;//审核级数
ExamineMan1,ExamineMan2,ExamineMan3,ExamineMan4,ExamineMan5:String;//审核人
ee1,ee2,ee3,ee4,ee5:string;//审核人别名
LevelName1,LevelName2,LevelName3,LevelName4,LevelName5:String;//审核名称
Flag1,Flag2,Flag3,Flag4,Flag5:Integer;
List_NO:string;//单据编号
Goods_No_Str,Goods_Name_Str:String;//商品编号 \商品名称
Goods_Check_str:String;//商品选择
/////////////////////////////////////////////
Handle_Man:String;//操作员名称
Handle_No:String;//操作员编号
Handle_Part:String;//操作员部门
shopid:widestring;//部门对应仓库编号
tablename:string;
//////////////////////////////////////
wldwno,officeid:string;//往来单位编号,配送申请部门编号,操作部门编号;
////////////////////////////////////////
LHXZ_Str,LHXZ_Str_Result,LHXZ_Str_List_NO:String;//来货选择
ZLXZ_Str,ZLXZ_Str_Result,ZLXZ_Str_List_NO:String;//质量选择
Contract_Check_Str,Contract_Check_Result_Str:String;//合同选择
ChildShop_Str,ChildShop_Result_NO,ChildShop_Result_Name:String;//店面选择
Stock_Contract_Str,Stock_Contract_NO:String; //采购合同
Storage_No_Str,Storage_Name_Str,Stock_States_Detail_str:String;//库存状况
Sign_Search_str,Sign_Search_Result_str:String;//单品查询
Storage_Up_Limit,Storage_Down_Limit:String;//库存上下限数量
Storage_Warn_Limit_Set:string;//库存上、下限设置
CK_MC,SP_MC:String;//仓库名称、商品名称；
Str_KD,Str_KS,Str_JS:String;//变化幅度，开始度数，结束度数
BH_Count:integer;//变化个数
Str_NO:String;//商品代码编辑规则
Str_Part_No,Str_part_Name,Str_Part_Code:String;//部门代码，部门名称；
//***************库存预警向导管理
Storage_Guide_Name,Storage_Guide_NO,Storage_Guide_Type,Storage_Guide_Str:String;
//***************
//起初建立帐
begin_build_str:string;
adisp:IEasy_Dcom_ServerDisp;//接口名；动态创建接口 ;
ipubtemp:IPublicServerDisp;
p_name:tstringlist; //部门编号集
partname,Fpartname:tstringlist;//部门名称集和子类部门名称集
stockinput:string; //入库单编号
/////////////////////
/////系统设置//////
len:integer; //单据编号长度;
loginlock: array [0..250] of integer;
Skinid:integer;//皮肤序号；
///////////////////////////////
Mstorage:tstringlist;
LocalB:boolean;//是否为总仓库；
qx,qxstr:string;//权限字符串;
ReCheck:integer;//记录质量验收当前的状态！！
ShowLimit,Color:integer; //系统设置;
BEdit:boolean;//制单修改状态
//////////////////////
implementation
uses main, Data, untdatadm;
procedure loadborlanced(cdsname:TClientDataSet); //负载纠错
begin
try
cdsname.ApplyUpdates(-1);
except
simpe(dmmain.socketpublic,frm_data.Simple);
end;
end;
function Cmd_Check_Filsh(no:string):boolean;
var
sqlquery:widestring;
begin
sqlquery:=' select Check_Result from receipt where Check_Result=5 and Receipt_No='+''''+trim(no)+'''';
dmmain.CDSquery2.Close;
dmmain.CDSquery2.Data:=adisp.resultrecord(sqlquery);
dmmain.CDSquery2.Open;
if dmmain.CDSquery2.IsEmpty then
begin
result:=false;
end else
begin
result:=true;
end;
end;
procedure savefromdata(cdsname:TClientDataSet;dataname:string);
begin
cdsname.SaveToFile(ExtractFilePath(application.ExeName)+trim(dataname),dfxml);
end;
function simpe(sockets:TSocketConnection;simpename:TSimpleObjectBroker):boolean;
begin
sockets.Close;
//simpename.SetConnectStatus(sockets.Address,false);
sockets.Address:=simpename.GetComputerForProgID(sockets.host);
try
sockets.Open;
result:=true;
except
result:=false
end;
end;
Function GetCurImage(CurStr:string):integer;
var
len:integer;
tempstr:string;
begin
tempstr:=trim(CurStr);
len:=length(tempstr);
if (len mod 2)=0 then
begin
tempstr:=copy(tempstr,length(tempstr)-1,2);
end
else
begin
tempstr:=copy(tempstr,length(tempstr),1);
Result:=strtoint(tempstr);
end;
end;
Function strtohex(instr:string):string;
var
i:integer;
asc:integer;
hexstr:string;
begin
Result:='';
for i:=1 to length(instr) do
begin
asc:=ord(instr[i]);
hexstr:=inttohex(asc,2);
Result:=Result+hexstr;
end;
end;
Function hexstrtodecstr(instr:string):string;
var
hexstr1,hexstr2:string;
decint,i:integer;
begin
try
Result:='';
i:=1;
while not (i>length(instr)) do
begin
hexstr1:=copy(instr,i,1);
if hexstr1='A' then hexstr1:='10';
if hexstr1='B' then hexstr1:='11';
if hexstr1='C' then hexstr1:='12';
if hexstr1='D' then hexstr1:='13';
if hexstr1='E' then hexstr1:='14';
if hexstr1='F' then hexstr1:='15';
hexstr2:=copy(instr,i+1,1);
if hexstr2='A' then hexstr2:='10';
if hexstr2='B' then hexstr2:='11';
if hexstr2='C' then hexstr2:='12';
if hexstr2='D' then hexstr2:='13';
if hexstr2='E' then hexstr2:='14';
if hexstr2='F' then hexstr2:='15';
decint:=strtoint(hexstr1)*16+strtoint(hexstr2);
Result:=Result+chr(decint);
i:=i+2;
end;
except
Result:='False';
end;
end;
Function Encrypt(EncryptStr,EncryptKey:string):string;
var
i,j,icount:integer;
s1,s2,tempstr:string;
asc1,asc2,asc3:integer;
begin
Result:='';
s1:=EncryptStr;
s2:=EncryptKey;
icount:=length(s1) div 3;
j:=1;
for i:=1 to icount do
begin
tempstr:=copy(s1,(i-1)*3+1,3);
asc1:=strtoint(tempstr);
asc2:=ord(s2[j]);
j:=j+1;
if j>length(s2) then
j:=1;
asc3:=asc1 xor asc2;
Result:=Result+chr(asc3);
end;
end;
Function Decrypt(DecryptStr,EncryptKey:string):string;
var
i,j:integer;
str:char;
s1,s2:string;
asc1,asc2,asc3:integer;
begin
Result:='';
s1:=DecryptStr;
s2:=EncryptKey;
j:=1;
for i:=1 to length(s1) do
begin
str:=s1[i];
asc1:=ord(str);
asc2:=ord(s2[j]);
j:=j+1;
if j>length(s2) then
j:=1;
asc3:=asc1 xor asc2;
Result:=Result+formatfloat('000',asc3);
end;
Result:=trim(Result);
end;
function GetFontStyle(FontNo:Integer):TFontStyles;
begin
Result:=[];
case FontNo of
3: Result:=[fsBold,fsItalic];
2: Result:=[fsItalic];
1: Result:=[fsBold];
else Result:=[];
end;
end;
Function writeselfdog(var selfstr:string;port:integer):integer;
type
TDataProc=Function(num: Integer; data: Pchar):integer;cdecl;//stdcall;
var
re :integer;
hLib :Thandle;
DataProc :TDataProc;
begin
hLib:=LoadLibrary('Dec.dll');
if hLib<32 then
begin
result:=-2;
exit;
end;
DataProc:=TDataProc(GetProcAddress(hLib,'SetData'));
re:=DataProc(port,@selfstr[1]);
FreeLibrary(hLib);
result:=re;
end;
Function WriteRegFile(menth:integer;keyname:String;Regkey:variant):variant;
var
tempkey :string;
tempregkey :Tregistry;
begin
tempregkey:=TRegistry.create;
try
tempkey:='\SOFTWARE\minipacs';
tempregkey.RootKey := HKEY_LOCAL_MACHINE;
tempregkey.OpenKey(tempkey,TRUE);
case menth of
1:
begin
tempregkey.WriteInteger(keyname,Regkey);
result :=tempregkey.ReadInteger(keyname);
end;
2:
begin
tempregkey.WriteString(keyname,Regkey);
result:=tempregkey.ReadString(keyname);
end;
3:
begin
tempregkey.WriteBool(keyname,Regkey);
result:= tempregkey.ReadBool(keyname);
end;
end;
finally
tempregkey.closekey;
tempregkey.destroy;
end;
end;
Function ReadRegFile(menth:integer;keyname:String):variant;
var
tempkey :string;
tempregkey :Tregistry;
begin
tempregkey:=TRegistry.create;
try
tempkey:='\SOFTWARE\minipacs';
tempregkey.RootKey := HKEY_LOCAL_MACHINE;
tempregkey.OpenKey(tempkey,TRUE);
case menth of
1:Result:=tempregkey.ReadInteger(keyname);
2:Result:=tempregkey.ReadString(keyname);
3:Result:=tempregkey.ReadBool(keyname);
end;
finally
tempregkey.closekey;
tempregkey.destroy;
end;
end;
Function ExistsRegKey(keyname:string):boolean;
var
tempkey :string;
tempregkey :Tregistry;
begin
tempregkey:=TRegistry.create;
try
tempkey:='\SOFTWARE\minipacs';
tempregkey.RootKey := HKEY_LOCAL_MACHINE;
tempregkey.OpenKey(tempkey,TRUE);
if tempregkey.valueexists(keyname) then
result:= true
else
result:= false;
finally
tempregkey.closekey;
tempregkey.destroy;
end;
end;
Function DeleteRegKey(keyname:string):boolean;
var
tempkey:string;
tempregkey:Tregistry;
begin
tempregkey:=TRegistry.create;
try
tempkey:='\SOFTWARE\minipacs';
tempregkey.RootKey := HKEY_LOCAL_MACHINE;
tempregkey.OpenKey(tempkey,TRUE);
if tempregkey.valueexists(keyname) then
begin
tempregkey.DeleteKey(keyname);
result:= true
end
else
result:= false;
finally
tempregkey.closekey;
tempregkey.destroy;
end;
end;
Procedure Change_Bmp_To_Jpeg(var bmpfile,jpgFile:String; compressquality:integer);
var
jpegimg :Tjpegimage;
bmpimg:TBitMap;
begin
jpegimg:=nil;
bmpimg:=nil;
try
try
jpegimg :=Tjpegimage.create;
bmpimg :=TBitMap.create;
bmpimg.loadfromfile(bmpfile);
Jpegimg.compressionQuality:=compressquality;
Jpegimg.Assign(bmpimg);
Jpegimg.Compress ;
Jpegimg.SaveToFile(jpgFile);
deletefile(bmpfile);
except
MessageBeep(0);
Application.MessageBox('当前图象转换错误!','警告!',0);
exit;
end;
finally
if jpegimg<>nil then
jpegimg.free;
if bmpimg<>nil then
bmpimg.free;
end;
end;
Function Get_Part_Path(filename :string):string;
var
len,i :integer;
begin
len :=length(filename);
for i:=len downto 1 do
begin
if filename[i]='\' then
break;
end;
result :=copy(filename,1,i-1)
end;
//转换大写金额
function Small2Big(SourceMoney:Currency):string;
var
//strSourceMoney保存未转换的小写字符串，strSourceMoney保存已转换的大写字符串
strSourceMoney,strObjectMoney:string;
//ThisWei为当前位的大写，ThisPos为当前位的人民币单位
ThisWei,ThisPos:string[2];
//iWei为当前位置,posPoint为小数点的位置
iWei,posPoint:integer;
begin
strSourceMoney :=formatfloat('0.00',SourceMoney);//将浮点数转换成指定格式字符串
posPoint:= pos('.', strSourceMoney); // 小数点的位置
//循环小写货币的每一位，从小写的右边位置到左边
for iWei :=length(strSourceMoney) downto 1 do
begin
case strSourceMoney[iWei] of //转换当前数字
'.':Continue; //如果是小数点，则不进行转换操作
'1':ThisWei:='壹'; '2': ThisWei:='贰';
'3': ThisWei:='叁'; '4': ThisWei:='肆';
'5': ThisWei:='伍'; '6': ThisWei:='陆';
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?