{**********************************************
*** Name: BaseFunction;
*** Author: SilverLong 2005-8-15;
***
*** Function: 公共函数;
**********************************************}
unit BaseFunction;
interface
USES windows,SysUtils,Classes,Controls,dbtables, Dialogs,DB,FORMS,ComCtrls,
Math ,ShlObj, ActiveX, ComObj, Registry,XMLDoc, XMLIntf, strutils,
Messages, Variants, Graphics,ExtCtrls, StdCtrls,ImgList, Grids, DBGrids;
//System;
//***************************************************//
type
{ TStream seek origins }
TFolderNo = (Desktop, StartMenu, Programs);
type
TCPUID = array[1..4] of Longint;
TVendor = array [0..11] of char;
TObjList=class (TList)
public
destructor Destroy; override;
procedure Clear; override;
procedure SaveToStream(stream: TStream); virtual;
procedure LoadFromStream(stream: TStream); virtual;
end;
var
_DecNum: Integer;
_RoundValue: Double;
_EquMinValue: Double;
_ZeroMinValue: Double;
function StrIsEmpty (s: String): Boolean;
//procedure StringWrite (F : File; s: String);
//procedure StringRead (F : File; s: String);
function SLtrim (s: String): String;
function STrim (s: String): String;
function SAllTrim (s: String): String;
function SRemoveSpace (s: String): String;//除掉空格
procedure SSplitString (s: String; s1: String; s2: String);
procedure SSplitString1 (s: String; s1: String; s2: String);
function SIntToStrFix (n: Integer; cnt: Integer): String;
function ARound (v: Double): Double; //求整
function ARoundN (v: Double; n: Integer): Double; //保留几位小数
function AEqu (v1: Double; v2: Double): Boolean; //两个是否相等
function ASmall (v1: Double; v2: Double): Boolean; //file://v1 < v2
function ABig (v1: Double; v2: Double): Boolean; // file://v1 > v2
function AIsZero (v1: Double): Boolean; //file://判断是否为零
function AMax (a: Double; b: Double): Double; // file://返回大值
function AMin (a: Double; b: Double): Double; // file://返回小值
procedure ASwap (p1: Double; p2: Double); // file://交换
function IMax (a: Integer; b: Integer): Integer; //file://返回大值
function IMin (a: Integer; b: Integer): Integer;// file://返回小值
procedure ISwap (p1: Integer; p2: Integer); //file://交换
function RealToStr (v: Double): String; //file://Double转换成String
function RealToStr1 (v: Double): String;
function StrToReal (s: String): Double; //file://String转换成Double
function RealStr (v: Double): String; //file://Double转换成String
function RealStrN (v: Double; dec: Integer): String; //file://保留几位小数 Double转换成String
function RealDateN(v: Double): String; //file://日期转化成字符
function IsDate(const str: string): Boolean;
function GetDate(const str: string): TDateTime; //file://字符转化成日期
function RealStr1 (v: Double; len: Integer; dec: Integer): String;
function RealStr2 (v: Double; len: Integer; dec: Integer): String;
function RealStr3 (v: Double; len: Integer; dec: Integer): String;
function RealStr4 (v: Double; len: Integer; dec: Integer): String;
function StrInt (s: String): Integer; //file://string 转换成 integer
//file://xml
procedure WriteXMLValue(XML : IXMLNode; Const mc : string; Var Val: string);
procedure ReadXMLValue(XML : IXMLNode; Const mc : string; Var Val: string);
//file://以下是保存为数据流
procedure WriteToStream (stream: TStream; const Number: Integer); overload;
procedure WriteToStream (stream: TStream; const Number: Int64); overload;
procedure WriteToStream (stream: TStream; const v: Cardinal); overload;
procedure WriteToStream (stream: TStream; const v: Word); overload;
procedure WriteToStream (stream: TStream; const Filestr: String); overload;
procedure WriteToStream (stream: TStream; const v: Double); overload;
procedure WriteToStream (stream: TStream; const Bool: Boolean); overload;
procedure ReadFromStream (stream: TStream; var v: Cardinal); overload;
procedure WriteToStream (stream: TStream; const Number: Extended); overload;
procedure ReadFromStream (stream: TStream; var v: Extended); overload;
procedure ReadFromStream (stream: TStream; var Number: Integer); overload;
procedure ReadFromStream (stream: TStream; var Number: Int64); overload;
procedure ReadFromStream (stream: TStream; var v: Word); overload;
procedure ReadFromStream (stream: TStream; var Filestr: String); overload;
procedure ReadFromStream (stream: TStream; var v: Double); overload;
procedure ReadFromStream (stream: TStream; var Bool: Boolean); overload;
procedure WriteToStream (stream: TStream; const sList: TStringList); overload;
procedure ReadFromStream (stream: TStream; var sList: TStringList); overload;
procedure WriteToStream (stream: TStream; const iary: array of Integer); overload;
procedure ReadFromStream (stream: TStream; var iary: array of Integer); overload;
function StrLike (sou: String; key: String): Boolean; //file://sou中是否包括key
function SRight (s: String; n: Integer): String; // file://取右边多少个字符
procedure LoadFileList (Path: String; slist: TStrings; noPath: Boolean);
function TimeTicket: Longint;
function MonthOfDate (date: TDateTime): Integer;
function DayOfDate (date: TDateTime): Integer;
function YearOfDate (date: TDateTime): Integer;
function GetSplitWord (s: String; splitc: Char): String;
function HexToInt (s: String): Integer; //file://16进制转换成10进制
function TransStrByTable (sou: String; ori: TStringList; des: TStringList): String;
procedure LoadTransTable (fn: String; sou: TStringList; tag: TStringList);
function MakeFilePath (s: String): String;
function RemoveNote (s: String): String;
function MakePath (path: String): String;
function Blone (tj: String; v: String): Boolean;
function CodeStr (s: String): String;
function DeCodeStr (s: String): String;
function GetValueFromStr (vname: String; s: String; txt: String): Boolean;
function GetParaList (txt: String; ss: TStringList): Boolean;
function SReplace (txt: String; sou: String; tag: String): String;
Function GetOSInfo: String; // file://NT 还是 Windows 98?取得当前操作平台
function GetCurrentUserName : string;// file://获取当前Windows用户的登录名
Procedure SetLink(FolderNo: TFolderNo; ACmdFile, Parameter, LinkName: string);//创建快捷方式
function GetMouseHwndAndClassName(Sender: TObject): string;
function GetMousePosHwndAndClassName(Sender: TPoint): string; //file://获取当前鼠标位置的类名和句柄
function GetIdeDiskSerialNumber : String; //file://取Ide硬盘序列号函数
//file://得到CpuID号
function GetCPUID : TCPUID; assembler; register;
function GetCPUVendor : TVendor; assembler; register;
function GetCPUIDStr: String;
{日期型字段显示过程,在OnGetText事件中调用}
procedure DateFieldGetText(Sender: TField; var Text: String);
{日期型字段输入判断函数,在OnSetText事件中调用}
function DateFieldSetText(Sender: TField; const Text: String):Boolean;
//file://不能输入字符
function CheckNullValue(var Key: Char): Boolean;
{判断输入的字符是否是数字}
function CheckInputNum(const IsInteger: Boolean; AStr: string; var Key: Char): Boolean;
//file://得到下一编号
function GetNextStrId(const PreId: string): string; // preId := 'LX000000';
//***************************************************//
//数据表复制(将源S_DATASET数据复制到目标D_DATASET)
PROCEDURE DB_CLONE(S_DATASET,D_DATASET:TDATASET);
//数据保存事物处理-单表 参数(保存QUERY,处理 DATABASE)
PROCEDURE BC_SWCL(CQY_CLQY:TQUERY;CDB_CLDB:TDATABASE);//处理事务
//数据集中单列数据求和 参数 (CDA_CLDA:合计数据集;CS_ZDM:合计列的字段名;VAR CI_SL:返回记录数)返回单列合计
FUNCTION HJ_SL_DL(CDA_CLDA:TDataSet;CS_ZDM:STRING;VAR CI_SL:INTEGER):REAL;
//数据集中单列数据求和 参数 (CDA_CLDA:合计数据集;CS_ZDM:合计列的字段名)返回单列合计
FUNCTION HJ_DL(CDA_CLDA:TDataSet;CS_ZDM:STRING):REAL;
//数据LOOKUP字段模拟 参数 CQY_CXQY 主QY,CQY_GGQY:外键代码QY ; CS_CXZDM 查询字段名,CS_CXSJ 查询数据,CS_XSZDM 显示代码QY字段名,CS_GGZDM,CS_WCDXSXX:STRING; VAR RS_XSSJ:STRING;CS_XGBZ:BOOLEAN):BOOLEAN;
FUNCTION LOOKUP(CQY_CXQY,CQY_GGQY:TQUERY;
CS_CXZDM,CS_CXSJ,CS_XSZDM,CS_GGZDM,CS_WCDXSXX:STRING;
VAR RS_XSSJ:STRING;CS_XGBZ:BOOLEAN):BOOLEAN;
//数据写入
FUNCTION ZXXR(CDT_GGDT:TDATASET;CS_SZZDM,CS_SZSJ:Variant):BOOLEAN;
//删除数据集中所有数据 参数(CDA_CLDA 需删除的数据集)
PROCEDURE SC_QY(CDA_CLDA:TDataSet);
//在数据集中定位 参数 DATASET 定位数据集;CS_ZDM 定位字段 CS_CS:定位值 如果定位到返回TRUE 否则返回FALSE
//注意要求全匹配定位
FUNCTION LOCATE1(DATASET:TDATASET;CS_ZDM,CS_CS: STRING):BOOLEAN;
//在数据集中定位 参数 DATASET 定位数据集;CS_ZDM1 定位字段1 ;CS_ZDM1 定位字段2;CS_CS1:定位值1 CS_CS2:定位值2;如果定位到返回TRUE 否则返回FALSE
//注意要求全匹配定位
FUNCTION LOCATE2(DATASET:TDATASET;CS_ZDM1,CS_ZDM2,CS_CS1,CS_CS2: STRING):BOOLEAN;
//删除数据集中所有数据 参数(CDA_CLDA 需删除的数据集)
procedure SCDB(DATASET: TDATASET);
//两查询数据集事物保存 F_QUERY 数据集1, S_QUERY:数据集1 TQUERY;CDB_CLDB:TDATABASE);
procedure BC_LX(F_QUERY, S_QUERY: TQUERY;CDB_CLDB:TDATABASE);
//三查询数据集事物保存 F_QUERY 数据集1, S_QUERY:数据集1 TQUERY;CDB_CLDB:TDATABASE);
procedure BC_SX(F_QUERY, S_QUERY ,T_QUERY: TQUERY;CDB_CLDB:TDATABASE);
//四查询数据集事物保存 F_QUERY 数据集1, S_QUERY:数据集1 TQUERY;CDB_CLDB:TDATABASE);
procedure BC_SHX(F_QUERY, S_QUERY ,T_QUERY,TH_QUERY: TQUERY;CDB_CLDB:TDATABASE);
//定位
Function LOCATE3( const cTable: TDATASET;const zdm,sValue: String): Boolean;
//***************************************************//
//在字符串左、右根据输入的参数进行长度补位
FUNCTION AppendSpaceOfStr(SOURCES:STRING;nLen:INTEGER;nType:String;ReplaceStr:String):STRING;
//在整数左、右根据输入的参数进行长度补位
FUNCTION AppendSpaceOfInt(SOURCES:INTEGER;nLen:INTEGER;nType:String;ReplaceStr:String):STRING;
//取SOURCES字符串的右WS位
FUNCTION WS_RIGHT(SOURCES :STRING;WS:SHORTINT):STRING;
//将CS_SCC删除串 的' '清空
PROCEDURE QK_SCKK(VAR CS_SCC:STRING);
//取SOURCES字符串的左WS位
FUNCTION WS_LEFT(SOURCES :STRING;WS:SHORTINT):STRING;//取SOURCES的左WS位
//在目标串SOU中查找FGF分格符并将分格符前的串赋予DES返回
//PROCEDURE JQZFC(FGF:STRING;VAR SOU,DES:STRING);
//返回定长字符串 参数 CD 返回串长度 ZFC 格式的字符串 ;HJ 为TRUE填充空格在后 HJ 为FALSE填充空格在前
FUNCTION FHDCZFC(CD:SHORTINT;ZFC:STRING;HJ:BOOLEAN):STRING;
//***************************************************//
//***************************大小写转换**********************//
//************************************************
//此单位共定义两个函数来实现数字金额的中文大写转化
//此函数可支持12位整数
//程序思路如下************************************
//将小数点前的整数取出,算出整数长度,不足千亿时前面补足0!
//角分分别求出并保存!
//将12位的整数分割成3部分,高位代表亿,中间的代表万,剩下的代表千圆及一下
//分割成的三部分都有相同的长度,每位各代表千位、百位、拾位、个位
//定义genge函数,将计算这四位的数
//将3部分分别计算出来,合成,这里就是整数位的大写形式
//计算出分角形式
//合成,做尾后处理,输出返回
//程序作者 龙堂海 lth009@163.com
//*************************************************
//**************************************************/
//*****关键词:调用CHM 帮助文件 */
//*****在DELPHI中如何调用CHM格式的帮助文件。 */
//*****最重要的是实现调用时要打开对应的帮助主题, */
//*****也就是要跳到指定的索引。 */
//*****然后,在调用时如下所示: */
//*****HtmlHelpA(Handle 'c:/windows/myHelp.chm' 0 '欢迎.htm');
//*****定义一个函数:
{ 例子
try
strtofloat(labelededit1.Text);
labelededit2.Text:=xiaotoda(labelededit1.Text);
except
messagebox(handle,'输入的数字有错误!','错误',mb_ok+mb_iconwarning);
labelededit1.SelectAll;
labelededit1.SetFocus;
end;
}
const
da:array[0..9]of pchar=('零','壹','贰','叁','肆','伍','陆','柒','捌','玖');
C1 = 52845; //常量
C2 = 22719; //常量
TableName = 'LOTTERY_';
function xiaotoda(money:string):string; //主函数
function fenge(p:string):string; //计算4位数字的千位、百位、拾位、个位,这具有普遍性!
function HtmlHelpA (hwndcaller:Longint;lpHelpfile:string;wCommand:Longint;dwData:string):HWND;STDCALL;EXTERNAL 'hhctrl.ocx';
function Encrypt(const S: String; Key: Word): String;//字符串加密
function Decrypt(const S: String; Key: Word): String;//字符串解密
procedure EncryptFile(INFName, OutFName : String; Key : Word);//文件加密
procedure DecryptFile(INFName, OutFName : String; Key : Word);//文件解密
//处理读取文件内容
Function GetFileText(Filename,ReamName,FilePath:String):TStringList;
//处理网络资源的永久连接
Function Connettion(FileListName,ServerIP,UserName,UserPWD:String):integer;
//判断是否为数字
function IsNum(str:string):boolean;
//取字串的右边若干字元
function RightStr(const sAString: string; iCount: integer): string;
// 取字串的左边若干字元
function LeftStr(const sAString: string; const iCount: integer):string;
//***************************大小写转换**********************//
//****************************Unicode转换************************//
type
TPDUFormatRec = Record
CenterLen:Array[0..1] of Char; //短信息中心地址长度
CenterType:Array[0..1] of Char; //短信息中心号码类型,91是TON/NPI
CenterNumber:Array[0..13] of Char; //所在地GSM短信息中心的号码
FileHeader:Array[0..1] of Char; //指正常地发送短信息
SMType:Array[0..1] of Char; //信息类型
CalledLen:Array[0..1] of Char; //被叫号码长度
CalledType:Array[0..1] of Char; //被叫号码类型
CalledNumber:Array[0..11] of Char; //被叫号码
// PID:Array[0..1] of Char; //
// DCS:Array[0..1] of Char; //
// TimeStamp:Array[0..13] of Char; //
SMCodeType:Array[0..5] of Char; //短信息编码类型GSM Default Alphabet,如为中文则是000010
SMLen:Array[0..1] of Char; //短信息长度
end;
TPDUSendRec = Record
SMSCLength:Array[0..1] of Char;
FirstOctet:Array[0..1] of Char;
MessageReference:Array[0..1] of Char;
PhoneLength:Array[0..1] of Char;
AddressType:Array[0..1] of Char;
Phone:Array[0..11] of Char;
TPPID:Array[0..1] of Char;
TPDCS:Array[0..1] of Char;
TPValidityPeriod:Array[0..1] of Char;
TPUserDataLength:Array[0..1] of Char;
//TPUserData
end;
TPDUFirstReadRec = Record
SMSCLength:Array[0..1] of Char;
AddressType:Array[0..1] of Char;
ServiceCenterNumber:Array[0..13] of Char; //Length???
FirstOctet:Array[0..1] of Char;
SendPhoneLength:Array[0..1] of Char;
SendPhoneType:Array[0..1] of Char;
// TONNPI:Array[0..1] of Char;
//Phone
end;
TPDUSecondReadRec = Record
TPPID:Array[0..1] of Char;
TPDCS:Array[0..1] of Char;
TimeStamp:Array[0..13] of Char;
TPUserDataLength:Array[0..1] of Char;
//TPUserData
end;
function ChangeOrder(OriStr:String;TotalLen:Integer):String;
function ResumeOrder(OriStr:String):String;
function EncodeEnglish(s:String):String;
function DecodeEnglish(s:String):String;
function Encode8Bits(s:String):String;
function Decode8Bits(s:String):String;
function EncodeUniCode(s:WideString):String;
function DecodeUniCode(s:String):WideString;
Function Mix2PDU(CenterNumber,CalledNumber,ShortMsg:String):String;
function MixSendPDU(Phone,ShortMsg:String;Var SendLen:String;SMType:Integer):String;
function DisposeReadPDU(PDUData:String;Var Phone,MsgContent:String):Integer;
//****************************Unicode转换************************//
//***************************************************************//
//===============================================================
//动态定位数据行
//过程名: DyDbgDataLine
//作者: haitian
//日期: 2003-02-22
//功能: 根据用户指定的条件自动移动到DBGrid控件中符合此条件的某行数据上
//输入参数:
// sValue:当前需要移动到的行的值;
// tab:当前DBGrid中对应的表的数据;
// dsr:当前需要操作的数据源;
//返回值: 无
//修改记录:
//================================================================
Procedure DyDbgDataLine(sValue:string;tab:Ttable;dsr:TDatasource);
//改变颜色标记当前数据行
//首先把DBGrid的DefaultDrawing属性设为false;然后在OnDrawDataCell事件函数中调用下面的函数:
//===============================================================
//过程名: DrawLine
//作者: haitian
//日期: 2003-02-22
//功能: 把Dbgrid中的指定的行改变颜色作为标记;
//输入参数:
// zdm:字段名;
// Rect:需要出入的行的某个单元;
// Field:当前显示的域;
// state:当前行的显示状态;
// zdz:当前需要移动到的行的值;
// tab:当前DBGrid中对应的表的数据;
// dbg:当前需要操作的DBGrid;
//返回值: 无
//修改记录:
//================================================================
Procedure DrawLine(tab:Ttable;const Rect:Trect;Field:Tfield;state:TgridDrawState;dbg:TDBGrid);
//四舍五入的函数,具体用法 myround(1.999,2) = 2.00
//第一位1.999为要四舍五入的数,2为要取的小数位
//yuan:原浮点数,PP保留 小数点后第几位
function myround(const yuan: Extended; const pp: Integer): Extended;
//***************************************************************//
//功 能:得到汉字笔画
function GetBiHua(chnstr:string):integer;
implementation
//file://得到下一编号
function GetNextStrId(const PreId: string): string; // preId := 'LX000000';
var
I,n,n1: Integer;
s,s1: string;
c: char;
begin
n := Length(PreId);
n1 := 0;
for I := n downto 1 do begin
c := PreId[I];
if (Ord(c) >= 65) and (Ord(c) <= 90) then begin
n1 := I;
Break;
end;
end;
s := Copy(PreId, 1, n1);
s1 := Copy(PreId, n1 + 1, 100);
s1 := IntToStr(StrToInt(s1) + 1);
result := s1;
for I := 1 to n - n1 - Length(s1) do
Result := '0' + Result;
result := s + Result;
end;
//file://不能输入字符
function CheckNullValue(var Key: Char): Boolean;
const
ControlKeySet = [Char(#13)];
begin
Key := #0;
Result := True;
end;
{判断输入的字符是否是数字}
function CheckInputNum(const IsInteger: Boolean; AStr: string; var Key: Char): Boolean;
const
NumberSet = ['0' .. '9', '.', '-'];
ControlKeySet = [Char(#8), Char(#13)];
begin
if Key in ControlKeySet then begin
Result := True;
Exit;
end;
if not (Key in NumberSet) then Key := #0;
if (Key = '.') and ((Length(AStr) = 0) or (Pos('.', AStr) > 0)) then
Key := #0;
//file://不能前两个同时为0
if (Length(AStr) = 1) and (AStr[1] = '0') and (Key = '0') then Key := #0;
//file://不能有多个负号
if (Pos('-', AStr) >= 0) and (Key = '-') then Key := #0;
if IsInteger then begin
if key = '.' then Key := #0;
// if (Length(AStr) = 1) and (AStr[1] = '0') or (Key = '.') then Key := #0;
end;
Result := Key <> #0;
end;
{日期型字段显示过程,在OnGetText事件中调用}
procedure DateFieldGetText(Sender: TField; var Text: String);
var
dDate: TDate;
wYear,wMonth,wDay: Word;
aryTestYMD: Array [1..2] of Char ;{测试输入掩码用临时数组}
iYMD: Integer;
begin
iYMD := 0;
dDate:= Sender.AsDateTime;
DecodeDate(dDate,wYear,wMonth,wDay);
{测试输入掩码所包含的格式.}
aryTestYMD:= '年';
if StrScan(PChar(Sender.EditMask), aryTestYMD[1]) <> nil then iYMD:= 1;
aryTestYMD:= '月';
if StrScan(PChar(Sender.EditMask), aryTestYMD[1]) <> nil then iYMD:= 2;
aryTestYMD:= '日';
if StrScan(PChar(Sender.EditMask), aryTestYMD[1]) <> nil then iYMD:= 3;
case iYMD of
1:{输入掩码为:”yyyy年”的格式.}
Text:= IntToStr(wYear) + '年';
2: {输入掩码为:”yyyy年mm月”的格式.}
Text:= IntToStr(wYear) + '年' + IntToStr(wMonth) + '月';
3: {输入掩码为:”yyyy年mm月dd日”的格式.}
Text:= IntToStr(wYear) + '年' + IntToStr(wMonth) + '月' + IntToStr(wDay) + '日';
else {默认为:”yyyy年mm月dd日”的格式.}
Text:= IntToStr(wYear) + '年' + IntToStr(wMonth) + '月' + IntToStr(wDay) + '日';
end;
end;
{日期型字段输入判断函数,在OnSetText事件中调用}
function DateFieldSetText(Sender: TField; const Text: String):Boolean;
var
dDate: TDate;
sYear,sMonth,sDay: String;
aryTestYMD: Array [1..2] of Char;
iYMD: Integer;
begin
iYMD := 0;
{获得用户输入的日期}
sYear := Copy(Text, 1, 4);
sMonth:= Copy(Text, 7, 2);
SDay := Copy(Text, 11, 2);
{测试输入掩码所包含的格式.}
aryTestYMD := '年';
if StrScan( PChar(Sender.EditMask), aryTestYMD[1] ) <> nil then iYMD := 1;
aryTestYMD := '月';
if StrScan( PChar(Sender.EditMask), aryTestYMD[1] ) <> nil then iYMD := 2;
aryTestYMD := '日';
if StrScan( PChar(Sender.EditMask), aryTestYMD[1] ) <> nil then iYMD := 3;
{利用Try…Except进行输入的日期转换}
try begin
case iYMD of
1: {输入掩码为:”yyyy年”的格式.}
begin
dDate := StrToDate( sYear + '-01-01' );{中文Windows默认的日期格式为:yyyy-mm-dd.下同}
Sender.AsDateTime := dDate;
end;
2: {输入掩码为:”yyyy年mm月”的格式.}
begin
dDate := StrToDate( sYear + '-' + sMonth + '-01' );
Sender.AsDateTime:=dDate;
end;
3: {输入掩码为:”yyyy年mm月dd日”的格式.}
begin
dDate := StrToDate( sYear + '-' + sMonth + '-' + sDay );
Sender.AsDateTime := dDate;
end;
else {默认为:”yyyy年mm月dd日”的格式.}
begin
dDate := StrToDate( sYear + '-' + sMonth + '-' + sDay );
Sender.AsDateTime := dDate;
end;
end;
DateFieldSetText := True;
end;
except
{日期转换出错}
begin
showmessage( PChar ( Text + '不是有效的日期!'));
DateFieldSetText := False;
end;
end;
end;
function GetMouseHwndAndClassName(Sender: TObject): string;
var
rPos: TPoint;
begin
Result := '';
//if boolean(GetCursorPos(rPos)) then Result := GetMousePosHwndAndClassName(rPos);
end;
function GetMousePosHwndAndClassName(Sender: TPoint): string;
var
hWnd: THandle;
aName: array [0..255] of char;
tmpstr: string;
begin
tmpstr := '';
hWnd := WindowFromPoint(Sender);
tmpstr := 'Handle : ' + IntToStr(hWnd);
if boolean(GetClassName(hWnd, aName, 256)) then
tmpstr := 'ClassName : ' + string(aName)
else
tmpstr := 'ClassName : not found';
Result := tmpstr;
end;
function GetCurrentUserName : string;
const
cnMaxUserNameLen = 254;
var
sUserName : string;
dwUserNameLen : Dword;
begin
dwUserNameLen := cnMaxUserNameLen-1;
SetLength( sUserName, cnMaxUserNameLen );
GetUserName(Pchar( sUserName ), dwUserNameLen );
SetLength( sUserName, dwUserNameLen );
Result := sUserName;
end;
Procedure SetLink(FolderNo: TFolderNo; ACmdFile, Parameter, LinkName: string);
var
MyObject : Iunknown;
MySLink : IShellLink;
MyPFile : IPersistFile;
FileName : string;
Directory : string;
WFileName : WideString;
MyReg : TRegIniFile;
tmpFolderNo : string;
begin
if FolderNo = Desktop then tmpFolderNo:= 'Desktop';
if FolderNo = StartMenu then tmpFolderNo:= 'StartMenu';
if FolderNo = Programs then tmpFolderNo:= 'Programs';
MyObject := CreateComObject(CLSID_ShellLink);
MySLink := MyObject as IShellLink;
MyPFile := MyObject as IPersistFile;
FileName := ACmdFile;
with MySLink do
begin
SetArguments(Pchar(Parameter));
SetPath(Pchar(FileName));
SetWorkingDirectory(Pchar(ExtractFilePath(FileName)));
end;
MyReg := TRegIniFile.Create('Software/MicroSoft/Windows/CurrentVersion/Explorer');
Directory := MyReg.ReadString('Shell Folders', tmpFolderNo,'');
//file://CreateDir(Directory);
WFileName := Directory + '/' + LinkName + '.lnk';
MyPFile.Save(PWChar(WFileName),False);
MyReg.Free;
end;
Function GetOSInfo: String;
var
VI: TOSVersionInfo;
begin
Result:= '';
VI.dwOSVersionInfoSize := SizeOf(VI);
GetVersionEx(VI);//取得正在运行的Windeows和Win32操作系统的版本
// VI.dwPlatformId
Result:= Result + Format('%d%d%d',[VI.dwMajorVersion,VI.dwMinorVersion,VI.dwBuildNumber]);
//Result:= Result + GetIdeDiskSerialNumber + GetCPUIDStr;
case Win32Platform of
VER_PLATFORM_WIN32_WINDOWS: Result := Result + 'Windows 95/98';
VER_PLATFORM_WIN32_NT: Result := Result + 'Windows NT';
else
Result := Result + 'Windows32';
end;
end;
function GetCPUID : TCPUID; assembler; register;
asm
PUSH EBX {Save affected register}
PUSH EDI
MOV EDI,EAX {@Resukt}
MOV EAX,1
DW $A20F {CPUID Command}
STOSD {CPUID[1]}
MOV EAX,EBX
STOSD {CPUID[2]}
MOV EAX,ECX
STOSD {CPUID[3]}
MOV EAX,EDX
STOSD {CPUID[4]}
POP EDI {Restore registers}
POP EBX
end;
function GetCPUVendor : TVendor; assembler; register;
asm
PUSH EBX {Save affected register}
PUSH EDI
MOV EDI,EAX {@Result (TVendor)}
MOV EAX,0
DW $A20F {CPUID Command}
MOV EAX,EBX
XCHG EBX,ECX {save ECX result}
MOV ECX,4
@1:
STOSB
SHR EAX,8
LOOP @1
MOV EAX,EDX
MOV ECX,4
@2:
STOSB
SHR EAX,8
LOOP @2
MOV EAX,EBX
MOV ECX,4
@3:
STOSB
SHR EAX,8
LOOP @3
POP EDI {Restore registers}
POP EBX
end;
function GetCPUIDStr: String;
var
CPUID : TCPUID;
I : Integer;
S : TVendor;
begin
Result := '';
for I := Low(CPUID) to High(CPUID) do CPUID[I] := -1;
CPUID := GetCPUID;
Result := Result + IntToHex(CPUID[1],8);
Result := Result + IntToHex(CPUID[2],8);
Result := Result + IntToHex(CPUID[3],8);
Result := Result + IntToHex(CPUID[4],8);
S := GetCPUVendor;
Result := Result + S;
end;
function GetIdeDiskSerialNumber : String; //file://取Ide硬盘序列号函数
type
TSrbIoControl = packed record
HeaderLength : ULONG;
Signature : Array[0..7] of Char;
Timeout : ULONG;
ControlCode : ULONG;
ReturnCode : ULONG;
Length : ULONG;
end;
SRB_IO_CONTROL = TSrbIoControl;
PSrbIoControl = ^TSrbIoControl;
TIDERegs = packed record
bFeaturesReg : Byte; // Used for specifying SMART "commands".
bSectorCountReg : Byte; // IDE sector count register
bSectorNumberReg : Byte; // IDE sector number register
bCylLowReg : Byte; // IDE low order cylinder value
bCylHighReg : Byte; // IDE high order cylinder value
bDriveHeadReg : Byte; // IDE drive/head register
bCommandReg : Byte; // Actual IDE command.
bReserved : Byte; // reserved. Must be zero.
end;
IDEREGS = TIDERegs;
PIDERegs = ^TIDERegs;
TSendCmdInParams = packed record
cBufferSize : DWORD;
irDriveRegs : TIDERegs;
bDriveNumber : Byte;
bReserved : Array[0..2] of Byte;
dwReserved : Array[0..3] of DWORD;
bBuffer : Array[0..0] of Byte;
end;
SENDCMDINPARAMS = TSendCmdInParams;
PSendCmdInParams = ^TSendCmdInParams;
TIdSector = packed record
wGenConfig : Word;
wNumCyls : Word;
wReserved : Word;
wNumHeads : Word;
wBytesPerTrack : Word;
wBytesPerSector : Word;
wSectorsPerTrack : Word;
wVendorUnique : Array[0..2] of Word;
sSerialNumber : Array[0..19] of Char;
wBufferType : Word;
wBufferSize : Word;
wECCSize : Word;
sFirmwareRev : Array[0..7] of Char;
sModelNumber : Array[0..39] of Char;
wMoreVendorUnique : Word;
wDoubleWordIO : Word;
wCapabilities : Word;
wReserved1 : Word;
wPIOTiming : Word;
wDMATiming : Word;
wBS : Word;
wNumCurrentCyls : Word;
wNumCurrentHeads : Word;
wNumCurrentSectorsPerTrack : Word;
ulCurrentSectorCapacity : ULONG;
wMultSectorStuff : Word;
ulTotalAddressableSectors : ULONG;
wSingleWordDMA : Word;
wMultiWordDMA : Word;
bReserved : Array[0..127] of Byte;
end;
PIdSector = ^TIdSector;
const
IDE_ID_FUNCTION = $EC;
IDENTIFY_BUFFER_SIZE = 512;
DFP_RECEIVE_DRIVE_DATA = $0007c088;
IOCTL_SCSI_MINIPORT = $0004d008;
IOCTL_SCSI_MINIPORT_IDENTIFY = $001b0501;
DataSize = sizeof(TSendCmdInParams)-1+IDENTIFY_BUFFER_SIZE;
BufferSize = SizeOf(SRB_IO_CONTROL)+DataSize;
W9xBufferSize = IDENTIFY_BUFFER_SIZE+16;
var
hDevice : THandle;
cbBytesReturned : DWORD;
pInData : PSendCmdInParams;
pOutData : Pointer; // PSendCmdOutParams
Buffer : Array[0..BufferSize-1] of Byte;
srbControl : TSrbIoControl absolute Buffer;
procedure ChangeByteOrder( var Data; Size : Integer );
var
ptr : PChar;
i : Integer;
c : Char;
begin
ptr := @Data;
for i := 0 to (Size shr 1)-1 do begin
c := ptr^;
ptr^ := (ptr+1)^;
(ptr+1)^ := c;
Inc(ptr,2);
end;
end;
begin
Result := '';
FillChar(Buffer,BufferSize,#0);
if Win32Platform=VER_PLATFORM_WIN32_NT then begin // Windows NT, Windows 2000
// Get SCSI port handle
hDevice := CreateFile( '//./Scsi0:',GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE,
nil, OPEN_EXISTING, 0, 0 );
if hDevice=INVALID_HANDLE_VALUE then Exit;
try
srbControl.HeaderLength := SizeOf(SRB_IO_CONTROL);
System.Move('SCSIDISK',srbControl.Signature,8);
srbControl.Timeout := 2;
srbControl.Length := DataSize;
srbControl.ControlCode := IOCTL_SCSI_MINIPORT_IDENTIFY;
pInData := PSendCmdInParams(PChar(@Buffer) + SizeOf(SRB_IO_CONTROL));
pOutData := pInData;
with pInData^ do begin
cBufferSize := IDENTIFY_BUFFER_SIZE;
bDriveNumber := 0;
with irDriveRegs do begin
bFeaturesReg := 0;
bSectorCountReg := 1;
bSectorNumberReg := 1;
bCylLowReg := 0;
bCylHighReg := 0;
bDriveHeadReg := $A0;
bCommandReg := IDE_ID_FUNCTION;
end;
end;
if not DeviceIoControl( hDevice, IOCTL_SCSI_MINIPORT,
@Buffer, BufferSize, @Buffer, BufferSize,
cbBytesReturned, nil ) then Exit;
finally
CloseHandle(hDevice);
end;
end else begin // Windows 95 OSR2, Windows 98
hDevice := CreateFile( '//./SMARTVSD', 0, 0, nil, CREATE_NEW, 0, 0 );
if hDevice=INVALID_HANDLE_VALUE then Exit;
try
pInData := PSendCmdInParams(@Buffer);
pOutData := @pInData^.bBuffer;
with pInData^ do begin
cBufferSize := IDENTIFY_BUFFER_SIZE;
bDriveNumber := 0;
with irDriveRegs do begin
bFeaturesReg := 0;
bSectorCountReg := 1;
bSectorNumberReg := 1;
bCylLowReg := 0;
bCylHighReg := 0;
bDriveHeadReg := $A0;
bCommandReg := IDE_ID_FUNCTION;
end;
end;
if not DeviceIoControl( hDevice, DFP_RECEIVE_DRIVE_DATA,
pInData, SizeOf(TSendCmdInParams)-1, pOutData,
W9xBufferSize, cbBytesReturned, nil ) then Exit;
finally
CloseHandle(hDevice);
end;
end;
with PIdSector(PChar(pOutData)+16)^ do begin
ChangeByteOrder(sSerialNumber,SizeOf(sSerialNumber));
SetString(Result,sSerialNumber,SizeOf(sSerialNumber));
end;
end;
procedure TObjList.Clear;
begin
inherited;
end;
destructor TObjList.Destroy;
begin
inherited;
end;
function StrIsEmpty (s: String): Boolean;
begin
Result := False;
if s = '' then
Result := True;
end;
{procedure StringWrite (f: file; s: String);
begin
end;
procedure StringRead (f: file; s: String);
begin
end;
}
function SLtrim (s: String): String;
begin
end;
function STrim (s: String): String;
begin
end;
function SAllTrim (s: String): String;
begin
end;
function SRemoveSpace (s: String): String;
var
I : Integer;
Count : Integer;
begin
Result:= '';
Count := length(s);
for I := 1 to Count do begin
if s[I] <> ' ' then begin
Result := Result + s[I];
end;
end;
end;
procedure SSplitString (s: String; s1: String; s2: String);
begin
end;
procedure SSplitString1 (s: String; s1: String; s2: String);
begin
end;
function SIntToStrFix (n: Integer; cnt: Integer): String;
begin
end;
function ARound (v: Double): Double;
begin
Result := Round(V);
end;
function ARoundN (v: Double; n: Integer): Double;
var
I : Integer;
begin
result := v;
for I := 0 to N - 1 do begin
Result := Result * 10;
end;
Result := Round(Result);
for I := 0 to N - 1 do begin
Result := Result / 10;
end;
end;
function AEqu (v1: Double; v2: Double): Boolean;
begin
result := False;
if v1 = v2 then
result := True
end;
function ASmall (v1: Double; v2: Double): Boolean;
begin
result := False;
if v1 < v2 then
result := True;
end;
function ABig (v1: Double; v2: Double): Boolean;
begin
result := False;
if v1 > v2 then
result := True;
end;
function AIsZero (v1: Double): Boolean;
begin
Result := False;
if V1 = 0 then Result := True;
end;
function AMax(a: Double; b: Double): Double;
begin
if a >= b then
result := a
else
result := b;
end;
function AMin(a: Double; b: Double): Double;
begin
if a >= b then
result := b
else
result := a;
end;
procedure ASwap (p1: Double; p2: Double);
begin
end;
function IMax(a: Integer; b: Integer): Integer;
begin
if a >= b then
result := a
else
result := b;
end;
function IMin(a: Integer; b: Integer): Integer;
begin
if a >= b then
result := b
else
result := a;
end;
procedure ISwap (p1: Integer; p2: Integer);
begin
end;
function RealToStr (v: Double): String;
begin
result := FloatToStr(v);
end;
function RealToStr1 (v: Double): String;
begin
end;
function StrToReal(s: String): Double;
var
I : Integer;
B : Boolean;
begin
B := True;
result := 0;
for I := 1 to length(s) do begin
if (ord(s[I]) > 57) or (ord(s[I]) < 48) then begin
if ord(s[I]) <> 46 then begin
B := False;
Break;
end;
end;
end;
if B and (Length(s) <> 0) then
result := StrToFloat(s)
end;
function RealStr (v: Double): String;
begin
result := FloatToStr(v);
end;
function FloatToFloat(Const D: Double; Const N: integer): Double;
var
I : integer;
Max : LongInt;
begin
Max := 1;
for I := 1 to N do begin
Max := Max * 10;
end;
result := D * Max;
result := Round(result);
result := result / Max;
end;
function RealStrN (v: Double; dec: Integer): String;
var
TD : Double;
begin
TD := FloatToFloat(V, dec);
result := FloatToStr(TD);
end;
function RealDateN(v: Double): String;
var
Year, Month, Day : word;
begin
DecodeDate(v, Year, Month, Day);
result := IntToStr(year) + '年' + IntToStr(Month) + '月' + IntToStr(Day) + '日';
end;
function IsDate(const str: string): Boolean;
begin
try
StrToDate(str);
except
Result := False;
Exit;
end;
Result := True;
end;
function GetDate(const str: string): TDateTime;
var
NewStr: string;
begin
NewStr := str;
NewStr := StringReplace(NewStr,'年','-',[]);
NewStr := StringReplace(NewStr,'月','-',[]);
NewStr := StringReplace(NewStr,'日','',[]);
if IsDate(NewStr) then Result := StrToDate(NewStr)
else Result := SysUtils.Date;
end;
function RealStr1 (v: Double; len: Integer; dec: Integer): String;
begin
end;
function RealStr2 (v: Double; len: Integer; dec: Integer): String;
begin
end;
function RealStr3 (v: Double; len: Integer; dec: Integer): String;
begin
end;
function RealStr4 (v: Double; len: Integer; dec: Integer): String;
begin
end;
function StrInt (s: String): Integer;
var
I : Integer;
B : Boolean;
begin
B := True;
result := 0;
if s = '' then begin
result := 0;
Exit;
end;
for I := 1 to length(s) do begin
if (ord(s[I]) > 57) or (ord(s[I]) < 48) then begin
B := False;
Break;
end;
end;
if B and (Length(s) <> 0) then
result := StrToInt(s)
end;
procedure WriteXMLValue(XML : IXMLNode; Const mc : string; Var Val: string);
var
Child_Node : IXMLNode;
begin
Child_Node := XML.AddChild(mc);
Child_Node.Text := Val;
end;
procedure ReadXMLValue(XML : IXMLNode; Const mc : string; Var Val: string);
var
Child_Node : IXMLNode;
begin
Child_Node := XML.ChildNodes.First;
if (Child_Node.NodeName = mc) then
Val := Child_Node.Text;
end;
procedure ReadFromStream(Stream: TStream; var Bool: Boolean);
begin
Stream.Read(Bool,SizeOf(Bool));
end;
procedure ReadFromStream(Stream: TStream; var Number: integer);
begin
Stream.Read(Number,SizeOf(Number));
end;
procedure ReadFromStream (stream: TStream; var Number: Int64); overload;
begin
Stream.Read(Number,SizeOf(Number));
end;
procedure ReadFromStream(Stream: TStream; var Filestr: string);
var
Count : integer;
I : integer;
S : Char;
begin
Filestr := '';
Count := 0;
ReadFromStream(Stream, Count);
for I := 1 to Count do begin
Stream.Read(S, 1);
Filestr:= Filestr + s;
end;
end;
procedure WriteToStream(Stream: TStream; const Number: integer);
begin
Stream.Write(Number,SizeOf(Number));
end;
procedure WriteToStream (stream: TStream; const Number: Int64); overload;
begin
Stream.Write(Number,SizeOf(Number));
end;
//file://将filestr 写入流中
procedure WriteToStream(Stream: TStream; const Filestr: string);
var
Count : integer;
I : integer;
S : Char;
begin
Count:= length(Filestr);
WriteToStream(Stream,Count);
for I:= 1 to Count do begin
S := FileStr[I];
Stream.Write(S, 1);
end;
end;
procedure WriteToStream (stream: TStream; const Number: Extended); overload;
begin
Stream.Write(Number,SizeOf(Number));
end;
procedure ReadFromStream (stream: TStream; var v: Extended); overload;
begin
Stream.Read(v,SizeOf(v));
end;
procedure WriteToStream(Stream: TStream; const Bool: Boolean);
begin
Stream.Write(Bool,Sizeof(Bool));
end;
procedure WriteToStream (stream: TStream; const v: Cardinal); overload;
begin
end;
procedure WriteToStream (stream: TStream; const v: Word); overload;
begin
end;
procedure WriteToStream (stream: TStream; const v: Double); overload;
begin
Stream.Write(V , sizeof(V));
end;
procedure ReadFromStream (stream: TStream; var v: Cardinal); overload;
begin
end;
procedure ReadFromStream (stream: TStream; var v: Word); overload;
begin
end;
procedure ReadFromStream (stream: TStream; var v: Double); overload;
begin
Stream.Read(V , sizeof(v));
end;
procedure WriteToStream (stream: TStream; const sList: TStringList); overload;
begin
end;
procedure ReadFromStream (stream: TStream; var sList: TStringList); overload;
begin
end;
procedure WriteToStream (stream: TStream; const iary: array of Integer); overload;
begin
end;
procedure ReadFromStream (stream: TStream; var iary: array of Integer); overload;
begin
end;
function StrLike (sou: String; key: String): Boolean;
begin
result := False;
if pos(sou, key) > 0 then
result := True;
end;
function SRight (s: String; n: Integer): String;
var
I : Integer;
begin
Result := '';
for I := 1 to n do begin
Result := Result + s[I];
end;
end;
procedure LoadFileList (Path: String; slist: TStrings; noPath: Boolean);
begin
end;
function TimeTicket: Longint;
begin
Result := 0;
end;
function MonthOfDate (date: TDateTime): Integer;
begin
Result := 0;
end;
function DayOfDate (date: TDateTime): Integer;
begin
Result := 0;
end;
function YearOfDate (date: TDateTime): Integer;
begin
Result := 0;
end;
function GetSplitWord (s: String; splitc: Char): String;
begin
end;
function HexToInt (s: String): Integer;
begin
Result := 0;
end;
function TransStrByTable (sou: String; ori: TStringList; des: TStringList): String;
begin
end;
procedure LoadTransTable (fn: String; sou: TStringList; tag: TStringList);
begin
end;
function MakeFilePath (s: String): String;
begin
end;
function RemoveNote (s: String): String;
begin
end;
function MakePath (path: String): String;
begin
end;
function Blone (tj: String; v: String): Boolean;
begin
Result := False;
end;
function CodeStr (s: String): String;
begin
end;
function DeCodeStr (s: String): String;
begin
end;
function GetValueFromStr (vname: String; s: String; txt: String): Boolean;
begin
Result := False;
end;
function GetParaList (txt: String; ss: TStringList): Boolean;
begin
Result := False;
end;
function SReplace (txt: String; sou: String; tag: String): String;
begin
end;
procedure TObjList.LoadFromStream(stream: TStream);
var
I : integer;
tmpCount : integer;
tmp: TObject;
begin
ReadFromStream(Stream, tmpCount);
for I:= 0 to tmpCount - 1 do begin
Stream.Read(tmp, SizeOf(tmp));
Add(tmp);
end;
end;
procedure TObjList.SaveToStream(stream: TStream);
var
I : integer;
tmp: TObject;
begin
WriteToStream(Stream, Count);
for I:= 0 to Count - 1 do begin
tmp := Items[I];
Stream.Write(tmp, Sizeof(tmp));
end;
end;
//***************************************************//
//表克隆
PROCEDURE DB_CLONE(S_DATASET,D_DATASET:TDATASET);
VAR I:SHORTINT;
BEGIN
D_DATASET.Append;
WITH S_DATASET DO
BEGIN
FOR I:=0 TO FieldCount-1 DO
BEGIN
D_DATASET.Fields[I].VALUE:=Fields[I].VALUE;
END;
END;
D_DATASET.POST;
END;
//处理事务
PROCEDURE BC_SWCL(CQY_CLQY:TQUERY;CDB_CLDB:TDATABASE);
BEGIN
IF CQY_CLQY.State IN [DSEDIT,DSINSERT] THEN CQY_CLQY.Post;
IF CQY_CLQY.UpdatesPending THEN
BEGIN
CDB_CLDB.StartTransaction;
TRY
CQY_CLQY.ApplyUpdates;
CDB_CLDB.Commit;
EXCEPT
CDB_CLDB.Rollback;
RAISE;
END;
CQY_CLQY.CommitUpdates;
END;
END;
//数据集中单列数据求和(返回记录数或返回单列合计)
FUNCTION HJ_SL_DL(CDA_CLDA:TDataSet;CS_ZDM:STRING;VAR CI_SL:INTEGER):REAL;
VAR LF_HJJG:REAL;
L_DQJL: TBookmark;
BEGIN
LF_HJJG:=0;
L_DQJL:=CDA_CLDA.GETBOOKMARK;
IF CDA_CLDA.State IN [DSBROWSE]
THEN BEGIN
TRY
WITH CDA_CLDA DO
BEGIN
FIRST;
DisableControls;
WHILE NOT EOF DO
BEGIN
LF_HJJG:=LF_HJJG+FIELDBYNAME(CS_ZDM).ASFLOAT;
CI_SL:=CI_SL+1;
NEXT;
END;
EnableControls;
END;
FINALLY
CDA_CLDA.GotoBookmark(L_DQJL);
CDA_CLDA.FreeBookmark(L_DQJL);
END;
END;
RESULT:=LF_HJJG;
END;
//数据集中单列数据求和(返回单列合计)
FUNCTION HJ_DL(CDA_CLDA:TDataSet;CS_ZDM:STRING):REAL;
VAR LF_HJJG:REAL;
L_DQJL: TBookmark;
BEGIN
LF_HJJG:=0;
L_DQJL:=CDA_CLDA.GETBOOKMARK;
IF CDA_CLDA.State IN [DSBROWSE]
THEN BEGIN
TRY
WITH CDA_CLDA DO
BEGIN
FIRST;
DisableControls;
WHILE NOT EOF DO
BEGIN
LF_HJJG:=LF_HJJG+FIELDBYNAME(CS_ZDM).ASFLOAT;
NEXT;
END;
EnableControls;
END;
FINALLY
CDA_CLDA.GotoBookmark(L_DQJL);
CDA_CLDA.FreeBookmark(L_DQJL);
END;
END;
RESULT:=LF_HJJG;
END;
//数据LOOKUP字段模拟
FUNCTION LOOKUP(CQY_CXQY,CQY_GGQY:TQUERY;
CS_CXZDM,CS_CXSJ,CS_XSZDM,CS_GGZDM,CS_WCDXSXX:STRING;
VAR RS_XSSJ:STRING;CS_XGBZ:BOOLEAN):BOOLEAN;
VAR LBL_ZD:BOOLEAN;
BEGIN
LBL_ZD:=FALSE;
IF CS_CXSJ=''
THEN BEGIN
RS_XSSJ:=CS_WCDXSXX;
{ RESULT:=LBL_ZD;}
RESULT:=TRUE;
IF CQY_GGQY.STATE IN [DSEDIT,DSINSERT]
THEN BEGIN
CQY_GGQY.EDIT;
CQY_GGQY.FieldByName(CS_GGZDM).CLEAR;
END;
EXIT;
END;
IF CQY_GGQY.ACTIVE THEN
WITH CQY_CXQY DO
BEGIN
CASE CQY_CXQY.FieldBYNAME(CS_CXZDM).DataType OF
ftString: LBL_ZD:=LOCATE(CS_CXZDM,CS_CXSJ,[]);
ftInteger,ftSmallint: LBL_ZD:=LOCATE(CS_CXZDM,STRTOINT(CS_CXSJ),[]);
END;
IF LBL_ZD
THEN BEGIN
IF CS_XGBZ AND (CQY_GGQY.FieldByName(CS_GGZDM).ASSTRING<>CS_CXSJ)
THEN BEGIN
CQY_GGQY.EDIT;
CQY_GGQY.FieldByName(CS_GGZDM).ASSTRING:=CS_CXSJ;
END;
RS_XSSJ:=CQY_CXQY.FIELDBYNAME(CS_XSZDM).ASSTRING;
END
ELSE BEGIN
IF CS_XGBZ
THEN BEGIN
CQY_GGQY.EDIT;
CQY_GGQY.FieldByName(CS_GGZDM).CLEAR;
END;
RS_XSSJ:=CS_WCDXSXX;
END;
END;
RESULT:=LBL_ZD;
END;
//数据写入
FUNCTION ZXXR(CDT_GGDT:TDATASET;CS_SZZDM,CS_SZSJ:Variant):BOOLEAN;
BEGIN
WITH CDT_GGDT DO
BEGIN
IF (ACTIVE) AND (CDT_GGDT AS TBDEDATASET).CachedUpdates
THEN BEGIN
EDIT;
FIELDBYNAME(CS_SZZDM).VALUE:=CS_SZSJ;
POST;
RESULT:=TRUE;
END
ELSE RESULT:=FALSE;
END;
END;
//删除数据集中所有数据
PROCEDURE SC_QY(CDA_CLDA:TDataSet);
BEGIN
WITH CDA_CLDA DO
BEGIN
FIRST;
WHILE NOT EOF DO
BEGIN
DELETE;
END;
END;
END;
//在数据集中定位
FUNCTION LOCATE1(DATASET:TDATASET;CS_ZDM,CS_CS: STRING):BOOLEAN;
BEGIN
IF DATASET.ACTIVE
THEN RESULT:=DATASET.Locate(CS_ZDM,CS_CS,[loCaseInsensitive, loPartialKey])
ELSE RESULT:=FALSE;
END;
//在数据集中定位
FUNCTION LOCATE2(DATASET:TDATASET;CS_ZDM1,CS_ZDM2,CS_CS1,CS_CS2: STRING):BOOLEAN;
var dq : TBookMark;
cd : boolean;
begin
cd:=false;
With DATASET do
begin
DisableControls;
dq:=GetBookmark;
First;
While not EOF do
if (fieldbyname(CS_zdm1).AsString = CS_CS1) AND (fieldbyname(CS_zdm2).AsString = CS_CS2)
then begin
cd:=true;
Break;
end
else Next;
end ;
if not cd then DATASET.GotoBookmark(dq);
DATASET.FreeBookmark(dq);
DATASET.EnableControls;
result:=cd;
end;
//删除数据集中所有数据
procedure SCDB(DATASET: TDATASET);
begin
WITH DATASET DO
BEGIN
IF DATASET.ACTIVE
THEN BEGIN
WHILE NOT EOF DO
BEGIN
DATASET.Delete;
END;
END;
END;
end;
//两查询数据集事物保存
procedure BC_LX(F_QUERY, S_QUERY: TQUERY;CDB_CLDB:TDATABASE);
begin
CDB_CLDB.StartTransaction;
TRY
F_QUERY.ApplyUpdates;
S_QUERY.ApplyUpdates;
CDB_CLDB.Commit;
EXCEPT
CDB_CLDB.Rollback;
RAISE;
END;
F_QUERY.CommitUpdates;
S_QUERY.CommitUpdates;
end;
//三查询数据集事物保存
procedure BC_SX(F_QUERY, S_QUERY, T_QUERY: TQUERY;CDB_CLDB:TDATABASE);
begin
CDB_CLDB.StartTransaction;
TRY
F_QUERY.ApplyUpdates;
S_QUERY.ApplyUpdates;
T_QUERY.ApplyUpdates;
CDB_CLDB.Commit;
EXCEPT
CDB_CLDB.Rollback;
RAISE;
END;
F_QUERY.CommitUpdates;
S_QUERY.CommitUpdates;
T_QUERY.CommitUpdates;
end;
//四查询数据集事物保存
procedure BC_SHX(F_QUERY, S_QUERY ,T_QUERY,TH_QUERY: TQUERY;CDB_CLDB:TDATABASE);
begin
CDB_CLDB.StartTransaction;
TRY
F_QUERY.ApplyUpdates;
S_QUERY.ApplyUpdates;
T_QUERY.ApplyUpdates;
TH_QUERY.ApplyUpdates;
CDB_CLDB.Commit;
EXCEPT
CDB_CLDB.Rollback;
RAISE;
END;
F_QUERY.CommitUpdates;
S_QUERY.CommitUpdates;
T_QUERY.CommitUpdates;
TH_QUERY.ApplyUpdates;
end;
//定位
Function LOCATE3( const cTable: TDATASET;const zdm,sValue: String): Boolean;
var dq : TBookMark;
cd : boolean;
begin
cd:=false;
With cTable do
begin
DisableControls;
dq:=GetBookmark;
While not EOF do
if fieldbyname(zdm).AsString = sValue
then begin
cd:=true;
Break;
end
else NEXT;
if not cd
then begin
GotoBookmark(dq);
While not BOF do
if fieldbyname(zdm).AsString = sValue
then begin
cd:=true;
Break;
end
else Prior;
end;
end ;
ctable.FreeBookmark(dq);
cTable.EnableControls;
result:=cd;
end;
//-------------------------------------------------
//在字符串左、右根据输入的参数进行长度补位
FUNCTION AppendSpaceOfStr(SOURCES:STRING;nLen:INTEGER;nType:String;ReplaceStr:String):STRING;
var StrBuf:String;
i:Integer;
BEGIN
StrBuf:='';
StrBuf:=Trim(SOURCES);
if Uppercase(nType) = 'R' then
Begin
for i:=1 to nLen -Length(StrBuf) do
Begin
StrBuf:=StrBuf + ReplaceStr;
End;
End;
if Uppercase(nType) = 'L' then
Begin
for i:=1 to nLen -Length(StrBuf) do
Begin
StrBuf:=ReplaceStr+StrBuf;
End;
End;
Result :=StrBuf;
END;
//在整数左、右根据输入的参数进行长度补位
FUNCTION AppendSpaceOfInt(SOURCES:INTEGER;nLen:INTEGER;nType:String;ReplaceStr:String):STRING;
var StrBuf:String;
i:Integer;
BEGIN
StrBuf:='';
StrBuf:=IntToStr(SOURCES);
if Uppercase(nType) = 'R' then
Begin
for i:=1 to nLen -Length(StrBuf) do
Begin
StrBuf:=StrBuf + ReplaceStr;
End;
End;
if Uppercase(nType) = 'L' then
Begin
for i:=1 to nLen -Length(StrBuf) do
Begin
StrBuf:=ReplaceStr+StrBuf;
End;
End;
Result :=StrBuf;
END;
//-------------------------------------------------
//取SOURCES字符串的右WS位
FUNCTION WS_RIGHT(SOURCES :STRING;WS:SHORTINT):STRING;//取SOURCES的右WS位
VAR LI_CD:SHORTINT;
BEGIN
LI_CD:=LENGTH(SOURCES);
IF LI_CD<WS
THEN RESULT:=''
ELSE BEGIN
RESULT:=COPY(SOURCES,LI_CD-WS+1,WS);
END;
END;
//将CS_SCC删除串 的' '清空
PROCEDURE QK_SCKK(VAR CS_SCC:STRING);
BEGIN
WHILE POS(' ',CS_SCC)>0 DO DELETE(CS_SCC,POS(' ',CS_SCC),1);
END;
//取SOURCES字符串的左WS位
FUNCTION WS_LEFT(SOURCES :STRING;WS:SHORTINT):STRING;
VAR LI_CD:SHORTINT;
BEGIN
LI_CD:=LENGTH(SOURCES);
IF LI_CD<WS
THEN RESULT:=''
ELSE BEGIN
RESULT:=COPY(SOURCES,1,WS);
END;
END;
//在目标串SOU中查找FGF分格符并将分格符前的串赋予DES返回
FUNCTION FH_JQZFC(FGF:STRING;VAR SOU:STRING):STRING;
VAR WZ:SHORTINT;
BEGIN
WZ:=POS(FGF,SOU);
RESULT:=COPY(SOU,1,WZ-1);
DELETE(SOU,1,WZ);
END;
//返回定长字符串
FUNCTION FHDCZFC(CD:SHORTINT;ZFC:STRING;HJ:BOOLEAN):STRING;
VAR FHC:STRING;
BEGIN
FHC:=ZFC;
WHILE LENGTH(FHC)<CD DO
BEGIN
IF HJ THEN FHC:=FHC+' '
ELSE FHC:=' '+FHC;
END;
RESULT:=FHC;
END;
//***************************大小写转换**********************//
function fenge(p:string):string;
var
qian,bai,shi,ge:string;
begin
if copy(p,1,1)='0' then
qian:=da[0]
else
qian:=da[strtoint(copy(p,1,1))]+'仟';
if copy(p,2,1)='0' then
bai:=da[0]
else
bai:=da[strtoint(copy(p,2,1))]+'佰';
if copy(p,3,1)='0' then
shi:=da[0]
else
shi:=da[strtoint(copy(p,3,1))]+'拾';
if copy(p,4,1)='0' then
ge:=''
else
ge:=da[strtoint(copy(p,4,1))];
qian:=qian+bai+shi+ge;
qian:=ansireplacestr(qian,'零零','零');
if qian='零零' then
result:=''
else
begin
if copy(qian,length(qian)-1,2)='零' then
delete(qian,length(qian)-1,2);
result:=qian;
end;
end;
function xiaotoda(money:string):string;
var
m,intpart:string;//存放金额字符串
n:double;//存放由字符串转成的金额
zf:string[2]; //正负金额
dotlocation,l:word;//存放小数点位置
jiao:string[4];//存放角
fen:string[4]; // 存放分
yi,wan,jiner:string;
begin
zf:='';
if copy(money,0,1)='-' then //四舍五入
begin
n:=strtofloat(money)-0.005;
n:=-n;
zf:='负';
end
else
n:=strtofloat(money)+0.005;
m:=floattostr(n); //金额数转成字符串
dotlocation:=pos('.',m);//小数点的位置
intpart:=copy(m,0,dotlocation-1);//金额数的整数部分
jiao:=copy(m,dotlocation+1,1);//获得角
fen:=copy(m,dotlocation+2,1);//获得分
l:=length(intpart);//金额整数位数
while l<12 do//最高只能表示千亿,用零填满前位
begin
insert('0',intpart,1);
l:=l+1;
end;
if copy(intpart,1,4)='0000' then//计算亿
yi:=''
else
yi:=fenge(copy(intpart,1,4))+'億';
if (copy(intpart,5,4)='0000')and (yi='') then //计算万
wan:=''
else
begin
if (copy(intpart,5,4)='0000') and (yi<>'') then
wan:='零'
else
wan:=fenge(copy(intpart,5,4))+'萬';
end;
jiner:=yi+wan+fenge(copy(intpart,9,4))+'圆'; //这里fenge计算千百拾个位,计算出整数位
jiner:=ansireplacestr(jiner,'零零','零') ;
if (copy(jiner,length(jiner)-3,2)='零') then
delete(jiner,length(jiner)-3,2);
if jiao='0' then //计算角
jiao:='零'
else
jiao:=da[strtoint(jiao)]+'角';
if fen='0' then //计算分
fen:=''
else
fen:=da[strtoint(fen)]+'分';
jiner:=jiner+jiao+fen;//初步合成
if (copy(jiner,length(jiner)-1,2)='零') then//如果没有分角则加"整"字
begin
delete(jiner,length(jiner)-1,2);//删除末尾"零"字
jiner:=jiner+'整';
end;
if (copy(jiner,1,2)='零') and (copy(jiner,3,2)<>'圆') then// 如果前导是"零",除去!
delete(jiner,1,2);
if copy(jiner,1,2)='圆'then jiner:='零'+jiner;//如果只有角分则加前导"零圆"!
result:=zf+jiner;
end;
//***************************大小写转换**********************//
(* -------------------------------------------------- *)
(* RightStr
(* =======
(* 取字串的右边若干字元
(* -------------------------------------------------- *)
function RightStr(const sAString: string; iCount: integer): string;
var
iLen: integer;
begin
iLen := Length(sAString);
if iCount > iLen then iCount := iLen;
Result := Copy(sAString, iLen - iCount + 1, iCount);
end; { RightStr }
(* -------------------------------------------------- *)
(* LeftStr
(* =======
(* 取字串的左边若干字元
(* -------------------------------------------------- *)
function LeftStr(const sAString: string; const iCount: integer):string;
begin
Result := Copy(sAString, 1, iCount);
end; { LeftStr }
{如果您要以中文字为单位, 在 2.0 中文应用组件中也有 AnsiStrCCopy()与
AnsiCopy()可以应用.
这类字串函数(像是PadR, PadL)自己练习写写看其实也挺有趣的; 如果急著要
用,
类似这样子的字串处理函数馆在网路上不少, 例如 Delphi 2.0 深度历险就有
一个叫做 XProc 的档案,
里头就有很多.}
//--------------------------------------
//判断是否为数字
function IsNum(str:string):boolean;
var
i:integer;
begin
for i:=1 to length(str) do
begin
if not (str[i] in ['0'..'9']) then
IsNum := False
else
IsNum := True;
end;
end;
//--------------------------------------
//**************************************//
function Encrypt(const S: String; Key: Word): String;//字符串加密
var
I: Integer;
begin
Result := S;
for I := 1 to Length(S) do
begin
Result[I] := char(byte(S[I]) xor (Key shr 11));
Key := (byte(Result[I]) + Key) * C1 + C2;
end;
end;
//**************************************//
function Decrypt(const S: String; Key: Word): String; //字符串解密
var
I: Integer;
begin
Result := S;
for I := 1 to Length(S) do
begin
Result[I] := char(byte(S[I]) xor (Key shr 11));
Key := (byte(S[I]) + Key) * C1 + C2;
end;
end;
//**************************************//
procedure EncryptFile(INFName, OutFName : String; Key : Word); //文件加密
VAR
MS, SS : TMemoryStream;
X : Integer;
C : Byte;
begin
MS := TMemoryStream.Create;
SS := TMemoryStream.Create;
TRY
MS.LoadFromFile(INFName);
MS.Position := 0;
FOR X := 0 TO MS.Size - 1 DO
begin
MS.Read(C, 1);
C := (C xor (Key shr 8));
Key := (C + Key) * C1 + C2;
SS.Write(C,1);
end;
SS.SaveToFile(OutFName);
FINALLY
SS.Free;
MS.Free;
end;
end;
//**************************************//
procedure DecryptFile(INFName, OutFName : String; Key : Word); //文件解密
VAR
MS, SS : TMemoryStream;
X : Integer;
C, O : Byte;
begin
MS := TMemoryStream.Create;
SS := TMemoryStream.Create;
TRY
MS.LoadFromFile(INFName);
MS.Position := 0;
FOR X := 0 TO MS.Size - 1 DO
begin
MS.Read(C, 1);
O := C;
C := (C xor (Key shr 8));
Key := (O + Key) * C1 + C2;
SS.Write(C,1);
end;
SS.SaveToFile(OutFName);
FINALLY
SS.Free;
MS.Free;
end;
end;
//处理网络资源的永久连接
Function Connettion(FileListName,ServerIP,UserName,UserPWD:String):integer;
Var
NR: NETRESOURCE;
Ret: DWORD;
S: string;
Ret_dir:Integer;
f: TSearchRec;
Begin
{***************用于网络资源的永久连接***********************}
Ret_dir:=FindFirst(FileListName, faAnyFile, f);
if Ret_dir<>0 then
Begin
S := '//'+ServerIP;
NR.dwType := RESOURCETYPE_ANY;
NR.lpLocalName := nil;
NR.lpRemoteName := PChar(S);
NR.lpProvider := nil;
//调用WNetAddConnection2,此函数在windows单元中,建立永久连接
Ret := WNetAddConnection2(NR,PChar(UserPWD),PChar(UserName),CONNECT_UPDATE_PROFILE);
//if Ret <> NO_ERROR then
//Begin
//if Ret <> ERROR_EXTENDED_ERROR then RaiseLastWin32Error
//else CallNetExtError;
//End;
End;
RESULT:=Ret;
End;
//**************************************//
Function GetFileText(Filename,ReamName,FilePath:String):TStringList;//处理读取文件内容
Var
DirName,sText,FileDate: string;
FTextFile:TextFile; //
DstList: TStringList;
Begin
FileDate:='';
DirName:='';
sText:='';
FileDate:=formatdatetime('yyyymmdd',now);
DstList:=TStringList.Create;
DirName:=FilePath+Filename+FileDate+'.'+ReamName;
try
//读取文件
if FileExists(DirName) then
Begin
AssignFile(FTextFile,DirName); //load file
Reset(FTextFile); //setting file read only
DstList.Clear;
while not eof(FTextFile) do
Begin
readln(FTextFile,sText); //read a line of file
DstList.Text:=DstList.Text + sText;
End;
CloseFile(FTextFile);
End;
finally
DstList.Free;
End;
RESULT:=DstList;
End;
//***************************大小写转换**********************//
//***************************Unicode转换*********************//
function ChangeOrder(OriStr:String;TotalLen:Integer):String;
var
i:Integer;
TempStr:String;
begin
OriStr:=OriStr+Copy('FFFFFFFFFF',1,TotalLen-Length(OriStr));
TempStr:='';
for i:=1 to (TotalLen Div 2) do
TempStr:=TempStr+OriStr[i*2]+OriStr[i*2-1];
Result:=TempStr;
end;
function ResumeOrder(OriStr:String):String;
var
i:Integer;
TempStr:String;
begin
TempStr:='';
for i:=1 to (Length(OriStr) Div 2) do
TempStr:=TempStr+OriStr[i*2]+OriStr[i*2-1];
Result:=StringReplace(TempStr,'F','',[rfReplaceAll]);
end;
Function Mix2PDU(CenterNumber,CalledNumber,ShortMsg:String):String;
var
TempStr,MsgContent:String;
PDURec:TPDUFormatRec;
begin
PDURec.CenterLen := '08';
PDURec.CenterType := '91';
TempStr := ChangeOrder(CenterNumber,14);
Move(TempStr[1],PDURec.CenterNumber[0],14);
PDURec.FileHeader := '11';
PDURec.SMType := '00';
PDURec.CalledLen := '0B';
PDURec.CalledType := '81';
TempStr := ChangeOrder(CalledNumber,12);
Move(TempStr[1],PDURec.CalledNumber[0],12);
PDURec.SMCodeType := '0000A7';
MsgContent := EnCodeUniCode(ShortMsg);
Move(IntToHex(Length(ShortMsg),2)[1],PDURec.SMLen[0],2);
SetLength(Result,SizeOf(PDURec));
Move(PDURec,Result[1],SizeOf(PDURec));
Result:=Result+MsgContent;
end;
function EncodeUniCode(s:WideString):String;
var
i,len:Integer;
cur:Integer;
t:String;
begin
Result:='';
len:=Length(s);
i:=1;
while i<=len do
begin
cur:=ord(s[i]);
//BCD转换
//FmtStr(t,'%4.4X',[cur]);
Result:=Result+IntToHex(Cur,4)+' ';
inc(i);
end;
end;
function DecodeUniCode(s:String):WideString;
var
p:PWord;
i,len:Integer;
cur:Integer;
TempChar:WideChar;
t:String;
begin
New(p);
Result:='';
len:=Length(s) div 4;
i:=1;
for i:=0 to Len-1 do
begin
t:=Copy(s,4*i+1,4);
p^:=HexToInt(t);
Move(p^,TempChar,2);
Result:=Result+TempChar+' ';
end;
Dispose(p);
end;
function MixSendPDU(Phone,ShortMsg:String;Var SendLen:String;SMType:Integer):String;
var
PDUSendRec:TPDUSendRec;
TempStr:String;
begin
PDUSendRec.SMSCLength := '00';
PDUSendRec.FirstOctet := '11';
PDUSendRec.MessageReference := '00';
PDUSendRec.PhoneLength := '0B';
PDUSendRec.AddressType := '91';
TempStr:=ChangeOrder(Phone,12);
Move(TempStr[1],PDUSendRec.Phone[0],12);
PDUSendRec.TPPID := '00';
Case SMType of
0://Englsih
PDUSendRec.TPDCS := '00';
4://8Bits
PDUSendRec.TPDCS := '04';
else //Chinese
PDUSendRec.TPDCS := '08';
end;
PDUSendRec.TPValidityPeriod := 'AA';
Case SMType of
0://Englsih
begin
Move(IntToHex(Length(ShortMsg),2)[1],PDUSendRec.TPUserDataLength[0],2);
SetLength(Result,SizeOf(PDUSendRec));
Move(PDUSendRec,Result[1],SizeOf(PDUSendRec));
Result:=Result+EncodeEnglish(ShorTMsg);
SendLen:=IntToStr((Length(Result)-2) Div 2);
end;
4://8Bits
begin
Move(IntToHex(Length(ShortMsg),2)[1],PDUSendRec.TPUserDataLength[0],2);
SetLength(Result,SizeOf(PDUSendRec));
Move(PDUSendRec,Result[1],SizeOf(PDUSendRec));
Result:=Result+Encode8Bits(ShorTMsg);
SendLen:=IntToStr((Length(Result)-2) Div 2);
end;
else //Chinese
begin
//TempStr:=EnCodeUniCode(ShortMsg);
TempStr:= ShortMsg;
Move(IntToHex(Length(TempStr) Div 2,2)[1],PDUSendRec.TPUserDataLength[0],2);
SetLength(Result,SizeOf(PDUSendRec));
Move(PDUSendRec,Result[1],SizeOf(PDUSendRec));
Result:=Result+TempStr;
SendLen:=IntToStr((Length(Result)-2) Div 2);
end;
end;
end;
function EncodeEnglish(s:String):String;
var
i,j,len:Integer;
cur,Int1:Integer;
begin
len:=Length(s);
//j 用于移位计数
i:=1;
j:=0;
while i<=len do
begin
if i<len then
//数据变换
cur:=(ord(s[i]) shr j) or ((ord(s[i+1]) shl (7-j)) and $ff)
else
cur:=(ord(s[i]) shr j) and $7f;
Result:=Result+IntToHex(cur,2);
inc(i);
//移位计数达到7位的特别处理
j:=(j+1) mod 7;
if j=0 then inc(i);
end;
end;
function DecodeEnglish(s:String):String;
var
i,j,len:Integer;
TempIntArray:Array of Integer;
TempStr:String;
cur,Int1:Integer;
begin
len:=Length(s) div 2;
SetLength(TempIntArray,Len);
for i:=0 to Len-1 do
begin
TempStr:=Copy(s,i*2+1,2);
TempIntArray[i]:=HexToInt(TempStr);
end;
//j 用于移位计数
i:=0;
j:=0;
while i<=len-1 do
begin
if i<>0 then
//数据变换
cur:=((TempIntArray[i] shl j) and $7f) or (TempIntArray[i-1] shr (8-j))
else
cur:=(TempIntArray[i] shl j) and $7f;
Result:=Result+Chr(cur);
//移位计数达到7位的特别处理
j:=(j+1) mod 7;
if j=0 then
begin
cur:=TempIntArray[i] shr 1;
Result:=Result+Chr(cur);
end;
inc(i);
end;
end;
function DisposeReadPDU(PDUData:String;Var Phone,MsgContent:String):Integer;
var
TempInt,Len:Integer;
FirstReadRec:TPDUFirstReadRec;
SecondReadRec:TPDUSecondReadRec;
TempStr:String;
begin
//First Read Record
Move(PDUData[1],FirstReadRec,SizeOf(FirstReadRec));
TempInt:=HexToInt(FirstReadRec.SendPhoneLength);
if (TempInt mod 2 = 1) then
Inc(TempInt);
//Phone
Phone:=Copy(PDUData,SizeOf(FirstReadRec)+1,TempInt);
Phone:=ResumeOrder(Phone);
//Second Read Record
Move(PDUData[SizeOf(FirstReadRec)+TempInt+1],SecondReadRec,SizeOf(SecondReadRec));
//Message Length
Len:=HexToInt(SecondReadRec.TPUserDataLength)*2;
//Short Message Content
TempStr:=Copy(PDUData,SizeOf(FirstReadRec)+TempInt+SizeOf(SecondReadRec)+1,Len);
Case HexToInt(SecondReadRec.TPDCS) of
0..3://7 Bits
begin
MsgContent:=DecodeEnglish(TempStr);
end;
4..7://8 Bits
begin
MsgContent:=Decode8Bits(TempStr);
end;
8..11://UniCode
begin
MsgContent:=DecodeUniCode(TempStr);
end;
else
begin
Result:=1; //type Error
Exit;
end;
end;
end;
function Encode8Bits(s:String):String;
var
i:Integer;
begin
Result:='';
for i:=1 to Length(s) do
Result:=Result+IntToHex(Ord(s[i]),2);
end;
function Decode8Bits(s:String):String;
var
i,Len:Integer;
TempStr:String;
begin
Result:='';
Len:=Length(s) Div 2;
for i:=0 to Len-1 do
begin
TempStr:=Copy(s,i*2+1,2);
Result:=Result+Chr(HexToInt(TempStr));
end;
end;
//****************************Unicode转换******************//
//================================================================
Procedure DyDbgDataLine(sValue:string;tab:Ttable;dsr:TDatasource);
var
bookmark:TBookMark;
begin
//记录当前标记的行;
bookmark:=tab.GetBookmark;
tab.first;
while not tab.Eof do
begin
if tab.FieldByName('cpbh').AsString= sValue then
begin
bookmark:=tab.GetBookmark;
break;
end;
tab.Next;
end;
dsr.DataSet.GotoBookmark(pointer(bookmark));
End;
procedure DrawLine(tab:Ttable;const Rect:Trect;Field:Tfield;state:TgridDrawState;dbg:TDBGrid);
begin
if (tab.fieldbyname('zdm').asstring = '9')then
begin
dbg.canvas.font.color:=clred;
dbg.canvas.brush.color:=clyellow;
end;
dbg.DefaultDrawDataCell(Rect,Field,State);
end;
function myround(const yuan: Extended; const pp: Integer): Extended;
//yuan:原浮点数,PP保留 小数点后第几位
var
p,l,m,l2:Longint;
s:string; // 原浮点数
sq:string; // 小数点前
sh:string;//小数点后
begin
if yuan=0 then exit;// 原浮点数 0
if pp<0 then exit; //非法小数点后第几位
s:=floattostr(yuan);
p:=pos('.',s); //小数点位置
sq:=midstr(s,1,p-1);
sh:=midstr(s,p+1,length(s)-length(sq)-1);
l:=length(sh);//小数位数
l2:=length(sq);//整数位数
if pp>=l then
begin//0
result:=strtofloat(s);
exit;//比如 11。06 要保留到 小数点后第3位显然 不合理
end;//
{ if pp=l then //比如 11。06 要保留到 小数点后第2位不用处理 直接返回
begin//1
Result:=s;
exit;
end;//1 }
if pp<l then //比如 11。06 要保留到 小数点后第1位 ,。。。
begin//2
m:=strtoint(sh[pp+1]);
if m>=5 then
begin
if pp>=1 then //保留到 小数点后第1,2。。。位
begin//3
sh:=midstr(sh,1,pp);
sh := inttostr(strtoint(sh)+1);
if length(sh)>pp then
begin
sh:= midstr(sh,2,pp);
sq:= inttostr(strtoint(sq)+1);
end;
Result:=strtofloat(sq+'.'+sh);
exit;
end//3
else //保留到 小数点后第0位
begin//4
sq[l2]:=chr(ord(sq[l2])+1);
Result:=strtofloat(sq);
exit;
end;//4
end
else
begin
if pp>=1 then //保留到 小数点后第1,2。。。位
begin//3
sh:=midstr(sh,1,pp);
Result:=strtofloat(sq+'.'+sh);
exit;
end//3
else //保留到 小数点后第0位
begin//4
Result:=strtofloat(sq);
exit;
end;//4
end;
end;//2
end;
//================================================================
{=================================================================
功 能:得到汉字笔画
参 数: chnstr(汉字)
返回值: integer(笔画)
备 注:
版 本:
1.0 2005/10/09 09:55:00
=================================================================}
function GetBiHua(chnstr:string):integer;
const
BiHuaTable=#10#7#10#10#8#10#9#11#17#14#13#5#13#10#12#15
+#10#6#10#9#12#8#10#10#8#8#10#5#10#14#16#9
+#12#12#15#15#7#10#5#5#7#10#2#9#4#8#12#13
+#7#10#7#21#10#8#5#9#6#13#8#8#9#13#12#10
+#13#7#10#10#8#8#7#8#7#19#5#4#8#6#9#10
+#14#14#9#12#15#10#15#12#12#8#9#5#15#10#16#13
+#9#12#8#8#8#7#15#10#13#19#8#13#12#8#5#12
+#9#4#9#10#7#8#12#12#10#8#8#5#11#11#11#9
+#9#18#9#12#14#4#13#10#8#14#13#14#6#10#9#4
+#7#13#6#11#14#5#13#16#17#16#9#18#5#12#8#9
+#9#8#4#16#16#17#12#9#11#15#8#19#15#7#15#11
+#12#16#13#10#13#7#6#9#5#8#9#9#10#6#9#11
+#15#8#10#8#12#9#13#10#14#7#8#11#11#14#12#8
+#7#10#2#10#7#11#4#5#7#19#10#8#17#11#12#7
+#3#7#13#15#8#11#11#14#16#8#10#9#11#11#7#7
+#10#4#7#17#16#16#15#11#9#8#12#8#5#9#7#19
+#12#3#9#9#9#14#12#14#7#9#8#8#10#10#12#11
+#11#12#11#13#11#6#11#19#8#11#6#9#11#4#11#7
+#2#12#8#11#10#12#7#9#12#15#15#11#7#8#4#7
+#15#12#7#15#10#6#7#6#11#7#7#7#12#8#15#10
+#9#16#6#7#8#12#12#15#8#8#10#10#10#6#13#9
+#11#6#7#6#6#10#8#8#4#7#10#5#9#6#6#6
+#11#8#8#13#12#14#13#13#13#4#11#14#4#10#7#5
+#16#12#18#12#13#12#9#13#10#12#24#13#13#5#12#3
+#9#13#6#11#12#7#9#12#15#7#6#6#7#8#11#13
+#8#9#13#15#10#11#7#21#18#11#11#9#14#14#13#13
+#10#7#6#8#12#6#15#12#7#5#4#5#11#11#15#14
+#9#19#16#12#14#11#13#10#13#14#11#14#7#6#3#14
+#15#12#11#10#13#12#6#12#14#5#3#7#4#12#17#9
+#9#5#9#11#9#11#9#10#8#4#8#10#11#9#5#12
+#7#11#11#8#11#11#6#9#10#9#10#2#10#17#10#7
+#11#6#8#15#11#12#11#15#11#8#19#6#12#12#17#14
+#4#12#7#14#8#10#11#7#10#14#14#7#8#6#12#11
+#9#7#10#12#16#11#13#13#9#8#16#9#5#7#7#8
+#11#12#11#13#13#5#16#10#2#11#6#8#10#12#10#14
+#15#8#11#13#2#7#5#7#8#12#13#8#4#6#5#5
+#12#15#6#9#8#9#7#9#11#7#4#9#7#10#12#10
+#13#9#12#9#10#11#13#12#7#14#7#9#12#7#14#12
+#14#9#11#12#11#7#4#5#15#7#19#12#10#7#9#9
+#12#11#9#6#6#9#13#6#13#11#8#12#11#13#10#12
+#9#15#6#10#10#4#7#12#11#10#10#6#2#6#5#9
+#9#2#9#5#9#12#6#4#9#8#9#18#6#12#18#15
+#8#8#17#3#10#4#7#8#8#5#7#7#7#7#4#8
+#8#6#7#6#6#7#8#11#8#11#3#8#10#10#7#8
+#8#8#9#7#11#7#8#4#7#7#12#7#10#8#6#8
+#12#12#4#9#8#13#10#12#4#9#11#10#5#13#6#8
+#4#7#7#4#15#8#14#7#8#13#12#9#11#6#9#8
+#10#11#13#11#5#7#7#11#10#10#8#11#12#8#14#9
+#11#18#12#9#12#5#8#4#13#6#12#4#7#6#13#8
+#15#14#8#7#13#9#11#12#3#5#7#9#9#7#10#13
+#8#11#21#4#6#9#9#7#7#7#12#7#16#10#10#14
+#10#16#13#15#15#7#10#14#12#4#11#10#8#12#9#12
+#10#12#9#12#11#3#6#9#10#13#10#7#8#19#10#10
+#11#3#7#5#10#11#8#10#4#9#3#6#7#9#7#6
+#9#4#7#8#8#9#8#8#11#12#11#8#14#7#8#8
+#8#13#5#11#9#7#8#9#10#8#12#8#5#9#14#9
+#13#8#8#8#12#6#8#9#6#14#11#23#11#20#8#6
+#3#10#13#8#6#11#5#7#9#6#9#8#9#10#8#13
+#9#8#12#13#12#12#10#8#8#14#6#9#15#9#10#10
+#6#10#9#12#15#7#12#7#11#12#8#12#7#16#16#10
+#7#16#10#11#6#5#5#8#10#17#17#14#11#9#6#10
+#5#10#8#12#10#11#10#5#8#7#6#11#13#9#8#11
+#14#14#15#9#15#12#11#9#9#9#10#7#15#16#9#8
+#9#10#9#11#9#7#5#6#12#9#12#7#9#10#6#8
+#5#8#13#10#12#9#15#8#15#12#8#8#11#7#4#7
+#4#7#9#6#12#12#8#6#4#8#13#9#7#11#7#6
+#8#10#7#12#10#11#10#12#13#11#10#9#4#9#12#11
+#16#15#17#9#11#12#13#10#13#9#11#6#9#12#17#9
+#12#6#13#10#15#5#12#11#10#11#6#10#5#6#9#9
+#9#8#11#13#9#11#17#9#6#4#10#8#12#16#8#11
+#5#6#11#6#13#15#10#14#6#5#9#16#4#7#10#11
+#12#6#7#12#13#20#12#3#9#10#6#7#13#6#9#2
+#10#3#13#7#16#8#6#11#8#11#9#11#11#4#5#9
+#7#7#7#10#6#14#9#6#8#10#5#9#12#10#5#10
+#11#15#6#9#8#13#7#10#7#6#11#7#13#10#8#8
+#6#12#9#11#9#14#12#8#10#13#9#11#11#9#14#13
+#12#9#4#13#15#6#10#10#9#8#11#12#12#8#15#9
+#9#10#6#19#12#10#9#6#6#13#8#15#12#17#12#10
+#6#8#9#9#9#20#12#11#11#8#11#9#7#9#16#9
+#13#11#14#10#10#5#12#12#11#9#11#12#6#14#7#5
+#10#8#11#13#14#9#9#13#8#7#17#7#9#10#4#9
+#9#8#3#12#4#8#4#9#18#10#13#4#13#7#13#10
+#13#7#10#10#6#7#9#14#8#13#12#16#8#11#14#13
+#8#4#19#12#11#14#14#12#16#8#10#13#11#10#8#9
+#12#12#7#5#7#9#3#7#2#10#11#11#5#6#13#8
+#12#8#17#8#8#10#8#8#11#7#8#9#9#8#14#7
+#11#4#8#11#15#13#10#5#11#8#10#10#12#10#10#11
+#8#10#15#23#7#11#10#17#9#6#6#9#7#11#9#6
+#7#10#9#12#10#9#10#12#8#5#9#4#12#13#8#12
+#5#12#11#7#9#9#11#14#17#6#7#4#8#6#9#10
+#15#8#8#9#12#15#14#9#7#9#5#12#7#8#9#10
+#8#11#9#10#7#7#8#10#4#11#7#3#6#11#9#10
+#13#8#14#7#12#6#9#9#13#10#7#13#8#7#10#12
+#6#12#7#10#8#11#7#7#3#11#8#13#12#9#13#11
+#12#12#12#8#8#10#7#9#6#13#12#8#8#12#14#12
+#14#11#10#7#13#13#11#9#8#16#12#5#15#14#12#9
+#16#12#9#13#11#12#10#11#8#10#10#10#7#7#6#8
+#9#13#10#10#11#5#13#18#16#15#11#17#9#16#6#9
+#8#12#13#7#9#11#11#15#16#10#10#13#11#7#7#15
+#5#10#9#6#10#7#5#5#10#4#7#12#8#9#12#5
+#11#7#8#2#14#10#9#12#10#7#18#13#8#10#8#11
+#11#12#10#9#8#13#10#11#13#7#7#11#12#12#9#10
+#15#11#14#7#16#14#5#15#2#14#17#14#10#6#12#10
+#6#11#12#8#17#16#9#7#20#11#15#10#7#8#9#11
+#13#13#10#7#11#10#7#10#8#11#5#5#13#11#14#12
+#13#10#6#15#10#9#4#5#11#8#11#16#11#8#8#7
+#13#9#12#12#14#8#7#5#11#7#8#11#7#8#12#19
+#13#21#13#10#11#16#11#8#7#15#7#6#11#8#10#15
+#12#12#10#12#9#11#13#11#9#10#9#13#7#7#11#11
+#7#8#6#4#7#7#6#11#17#8#11#13#14#14#13#12
+#9#9#9#6#11#7#8#9#3#9#14#6#10#6#7#8
+#6#9#15#14#12#13#14#11#14#14#13#6#9#8#8#6
+#10#11#8#13#4#5#10#5#8#9#12#14#9#3#8#8
+#11#14#15#13#7#9#12#14#7#9#9#12#8#12#3#7
+#5#11#13#17#13#13#11#11#8#11#16#19#17#9#11#8
+#6#10#8#8#14#11#12#12#10#11#11#7#9#10#12#9
+#8#11#13#17#9#12#8#7#14#5#5#8#5#11#10#9
+#8#16#8#11#6#8#13#13#14#19#14#14#16#15#20#8
+#5#10#15#16#8#13#13#8#11#6#9#8#7#7#8#5
+#13#14#13#12#14#4#5#13#8#16#10#9#7#9#6#9
+#7#6#2#5#9#8#9#7#10#22#9#10#9#8#11#8
+#10#4#14#10#8#16#10#8#5#7#7#10#13#9#13#14
+#8#6#15#15#11#8#10#14#5#7#10#10#19#11#15#15
+#10#11#9#8#16#5#8#8#4#7#9#7#10#9#6#7
+#5#7#9#3#13#9#8#9#17#20#10#10#8#9#8#18
+#7#11#7#11#9#8#8#8#12#8#11#12#11#12#9#19
+#15#11#15#9#10#7#9#6#8#10#16#9#7#8#7#9
+#10#12#8#8#9#11#14#12#10#10#8#7#12#9#10#8
+#11#15#12#13#12#13#16#16#8#12#11#13#8#9#21#7
+#8#15#12#9#11#12#10#5#4#12#15#7#20#15#11#4
+#12#15#14#16#11#14#16#9#13#8#9#13#6#8#8#11
+#5#8#10#7#9#8#8#11#11#10#14#8#11#10#5#12
+#4#10#12#11#13#10#6#10#12#10#14#19#18#12#12#10
+#11#8#2#10#14#9#7#8#12#8#7#11#11#10#6#14
+#8#6#11#10#6#3#6#7#9#9#16#4#6#7#7#8
+#5#11#9#9#9#6#8#10#3#6#13#5#12#11#16#10
+#10#9#15#13#8#15#11#12#4#14#8#7#12#7#14#14
+#12#7#16#14#14#10#10#17#6#8#5#16#15#12#10#9
+#10#4#8#5#8#9#9#9#9#10#12#13#7#15#12#13
+#7#8#9#9#10#10#11#16#12#12#11#8#10#6#12#7
+#9#5#7#11#7#5#9#8#12#4#11#6#11#8#7#11
+#8#11#17#15#5#11#23#6#16#9#6#11#10#4#8#4
+#10#8#16#7#13#14#12#11#12#13#12#16#5#9#22#20
+#20#20#5#9#7#9#12#10#4#4#2#7#7#6#4#3
+#7#6#5#4#4#6#9#13#9#16#14#13#10#9#4#12
+#9#6#9#20#16#17#6#10#8#6#2#15#8#6#15#13
+#12#7#10#8#10#15#9#11#13#17#13#14#3#8#6#12
+#10#13#8#12#12#6#12#13#6#10#12#14#10#9#6#8
+#7#7#13#11#13#12#10#9#8#7#3#7#14#8#5#8
+#16#17#16#12#6#10#15#14#6#11#12#10#3#8#14#11
+#10#12#10#6#3#14#4#10#7#8#11#11#11#6#8#11
+#13#10#13#10#7#6#10#5#8#7#7#11#10#8#9#7
+#8#11#9#8#13#11#7#5#12#9#4#11#9#11#12#9
+#5#6#5#9#9#12#8#3#8#2#5#9#7#4#9#9
+#8#7#5#5#8#9#8#8#6#5#3#5#9#8#9#14
+#10#8#9#13#16#9#5#8#12#8#4#5#9#9#8#8
+#6#4#9#6#7#11#11#8#14#11#15#8#11#10#7#13
+#8#12#11#12#4#12#11#15#16#12#17#13#13#12#13#12
+#5#8#9#7#6#9#14#11#13#14#10#8#9#14#10#5
+#5#10#9#17#4#11#10#4#13#12#7#17#9#12#9#11
+#10#8#12#15#15#9#7#5#5#6#13#6#13#5#7#6
+#8#3#8#10#8#10#9#7#6#9#12#15#16#14#7#12
+#9#10#10#12#14#13#13#11#7#8#14#13#14#9#11#11
+#10#21#13#6#17#12#14#10#6#10#10#13#11#10#14#11
+#10#12#8#13#5#5#6#12#16#9#17#15#9#8#8#5
+#10#11#4#8#7#7#13#8#15#13#7#17#13#15#14#10
+#8#12#10#14#11#5#9#6#13#13#11#12#15#10#16#10
+#15#11#15#10#11#10#13#10#11#10#9#11#10#5#10#10
+#18#13#10#13#11#10#15#12#12#15#16#12#7#12#17#11
+#10#9#8#4#11#13#5#11#9#14#12#9#7#8#11#13
+#9#10#8#4#7#9#5#6#11#9#9#9#12#10#10#13
+#17#6#11#7#12#11#10#12#9#12#11#7#5#10#5#7
+#9#8#10#10#10#11#3#6#8#12#6#11#13#13#13#13
+#9#7#4#17#8#6#11#10#7#6#8#12#7#8#11#9
+#9#12#9#9#4#10#9#5#15#9#12#8#10#3#11#7
+#13#10#11#12#11#8#11#3#12#7#4#3#8#6#8#8
+#11#7#6#9#20#13#6#4#7#10#7#11#11#4#14#11
+#7#11#8#6#6#7#7#5#14#8#9#9#12#17#7#12
+#11#11#15#3#14#12#10#4#9#7#7#14#10#6#13#10
+#8#9#13#10#12#7#14#8#12#7#7#7#9#4#6#9
+#9#4#7#11#7#7#4#8#4#10#4#14#6#9#7#5
+#13#11#8#4#5#10#9#8#14#8#6#11#8#12#15#6
+#13#10#12#10#7#11#15#3#11#14#11#13#6#12#17#11
+#10#3#13#12#11#9#7#12#6#8#15#9#7#17#14#13
+#9#8#9#3#12#10#6#11#13#6#5#14#6#9#8#11
+#11#7#9#8#13#9#9#8#13#7#13#11#12#9#10#8
+#8#9#11#22#9#15#17#12#3#12#10#8#13#9#8#9
+#9#15#13#6#11#11#12#15#9#10#18#12#10#10#11#10
+#3#7#10#7#11#10#10#13#8#13#15#15#6#9#13#6
+#11#8#11#5#11#9#19#16#8#8#12#10#16#7#12#8
+#7#13#7#4#9#11#9#13#12#12#6#6#9#7#6#6
+#16#8#7#8#8#5#4#10#6#7#12#14#6#9#10#6
+#13#12#7#10#10#14#6#14#11#14#9#10#6#13#11#9
+#6#7#10#9#12#12#11#11#7#12#9#11#11#5#9#19
+#10#9#13#16#8#5#11#6#9#14#12#6#8#6#6#6
+#10#6#5#5#9#6#6#8#9#10#7#3#7#4#10#11
+#13#11#12#9#6#6#11#9#11#10#11#10#7#9#12#8
+#6#7#15#11#8#8#8#11#11#9#14#10#12#16#6#9
+#12#10#9#12#10#11#10#9#5#10#10#7#6#8#8#6
+#9#6#10#6#11#9#10#14#16#13#7#14#13#6#13#11
+#12#9#9#10#9#9#20#12#15#8#6#11#7#3#6#11
+#5#5#6#12#8#11#1#12#7#12#11#8#6#6#13#6
+#12#11#5#10#14#7#8#9#18#12#9#10#3#1#7#4
+#4#7#8#7#6#3#7#17#11#13#9#6#13#13#15#4
+#3#10#13#8#5#10#7#6#17#11#8#9#9#6#10#9
+#6#9#7#11#11#11#7#4#4#11#5#8#15#11#18#7
+#14#10#11#11#9#14#7#17#9#15#13#10#9#9#8#7
+#17#10#11#13#14#13#8#8#10#5#11#9#5#9#6#11
+#7#4#5#7#10#7#8#12#7#6#4#5#7#12#9#2
+#5#6#11#3#8#13#13#13#14#7#9#12#8#12#12#11
+#11#4#10#8#3#6#9#6#9#6#5#11#6#8#6#12
+#12#10#12#13#11#9#8#13#10#12#12#10#15#5#10#11
+#10#4#9#10#10#12#14#7#7#10#13#13#12#7#8#14
+#9#9#4#6#12#11#9#8#12#4#10#10#10#4#9#4
+#9#4#7#15#11#10#13#5#5#10#6#10#9#7#10#10
+#6#6#9#19#12#16#10#10#12#14#17#12#19#8#6#16
+#9#20#16#10#7#7#17#8#8#6#8#10#9#15#15#12
+#16#4#12#12#5#5#11#8#9#9#14#8#5#9#7#14
+#10#6#10#10#14#18#9#13#11#8#10#8#14#11#10#22
+#9#5#9#10#12#11#15#11#14#14#7#12#10#7#3#7
+#8#5#8#16#13#8#9#7#8#9#13#13#6#14#5#14
+#7#10#12#16#8#13#14#7#10#9#13#10#13#10#16#6
+#7#8#8#10#7#15#10#15#6#13#9#11#8#9#6#8
+#16#9#5#9#9#10#8#7#6#8#4#7#14#8#8#10
+#5#3#8#11#8#12#12#6#10#8#7#9#4#11#5#6
+#7#7#10#11#6#10#13#8#9#8#12#10#13#8#8#11
+#12#8#11#4#9#8#9#10#8#9#8#9#6#6#6#8
+#6#9#7#12#9#7#8#8#10#8#9#17#10#10#12#6
+#11#10#8#10#6#10#12#8#17#15#5#11#9#7#11#8
+#12#12#7#8#9#8#7#4#9#4#9#8#15#14#15#10
+#6#12#6#15#6#7#12#13#9#14#7#11#10#10#10#8
+#8#10#12#8#10#11#11#7#9#9#9#10#9#12#11#7
+#12#5#9#13#3#6#11#6#18#12#15#8#11#9#7#7
+#7#9#12#10#7#8#11#9#7#7#8#10#20#16#15#12
+#13#12#15#9#5#7#9#11#7#7#10#0#0#0#0#0
+#3#3#3#4#4#4#5#6#6#10#10#16#0#9#0#2
+#3#4#4#5#5#6#9#11#14#14#19#0#8#14#2#6
+#4#7#7#11#14#4#6#10#11#12#14#15#16#0#5#8
+#11#11#15#8#7#0#4#6#7#8#8#8#9#10#10#10
+#13#13#14#14#15#16#0#8#0#4#4#4#5#5#5#5
+#6#6#6#6#6#6#6#6#6#7#7#7#7#7#7#7
+#7#7#8#8#8#8#8#8#8#8#8#8#8#8#9#9
+#9#9#9#9#9#9#9#10#10#10#10#10#10#10#10#10
+#10#10#10#10#11#11#11#11#11#11#11#12#12#12#13#14
+#14#14#14#14#14#15#15#5#6#7#7#8#17#6#8#4
+#12#16#17#18#21#0#9#9#11#6#6#7#0#8#10#10
+#11#12#12#12#13#16#19#19#0#6#8#8#10#0#10#10
+#0#5#5#5#6#6#6#7#7#7#7#7#7#8#8#8
+#8#8#8#8#8#8#8#8#9#9#9#9#10#10#10#10
+#10#10#10#11#11#11#11#11#11#11#11#11#11#11#12#12
+#12#12#12#13#13#14#14#14#15#15#19#0#8#0#5#5
+#6#6#7#7#7#7#8#9#9#10#10#10#11#11#11#16
+#5#5#5#5#6#6#7#7#7#7#7#7#8#8#8#8
+#8#8#8#9#9#9#9#9#10#10#11#11#13#13#13#14
+#14#16#19#20#5#7#5#7#7#8#10#10#11#15#9#17
+#20#0#0#6#10#2#5#10#12#7#9#9#14#16#16#17
+#6#6#6#6#6#6#6#7#7#7#8#8#8#8#8#8
+#8#8#8#8#9#9#9#9#9#9#9#9#9#10#10#10
+#10#10#10#11#11#11#11#11#11#11#11#11#11#12#12#12
+#12#13#13#14#14#14#15#20#21#22#0#5#5#6#6#6
+#6#6#6#6#7#7#7#7#7#7#7#7#7#7#7#7
+#7#7#7#7#7#7#7#7#7#7#7#8#8#8#8#8
+#8#8#8#8#8#8#8#8#8#8#8#8#8#8#9#9
+#9#9#9#9#9#9#9#9#9#9#9#9#9#9#9#9
+#9#9#9#9#9#9#9#9#9#9#9#9#9#10#10#10
+#10#10#10#10#10#10#10#10#10#10#10#10#10#10#10#10
+#10#11#11#11#11#11#11#11#11#11#11#11#11#11#11#11
+#11#11#11#11#11#11#11#11#11#11#11#12#12#12#12#12
+#12#12#12#12#12#12#12#12#12#12#12#12#12#13#13#13
+#13#13#13#13#13#13#13#13#13#13#13#13#13#14#14#14
+#14#14#14#14#14#14#14#14#15#15#15#15#15#15#15#15
+#15#16#16#16#16#16#16#16#16#16#17#17#17#17#17#18
+#19#19#19#20#20#22#0#9#6#7#9#9#10#10#11#0
+#6#7#13#0#6#7#8#8#8#8#9#9#9#10#10#10
+#11#11#11#11#11#11#11#11#11#11#11#11#12#12#12#12
+#12#12#12#12#12#12#13#13#13#13#13#13#13#13#14#14
+#14#14#14#15#15#15#15#16#16#16#17#17#19#23#25#3
+#7#8#12#5#5#5#5#5#5#6#6#6#7#7#7#7
+#7#7#7#7#7#7#7#8#8#8#8#8#8#8#8#8
+#8#8#9#9#9#9#9#9#9#9#9#9#9#9#9#9
+#9#9#9#9#9#9#9#9#9#9#10#10#10#10#10#10
+#10#10#10#10#10#11#11#11#11#11#11#11#11#11#11#11
+#11#11#11#11#11#11#11#11#12#12#12#12#12#12#12#12
+#12#12#12#12#12#12#12#12#12#13#13#13#13#13#13#13
+#13#13#13#13#13#13#13#13#13#13#13#13#13#13#14#14
+#14#14#14#14#14#14#14#15#15#15#15#15#15#15#15#15
+#15#15#16#16#16#16#16#16#17#17#19#25#0#6#6#7
+#7#8#9#10#11#11#16#7#8#8#8#10#11#11#11#12
+#14#14#15#15#6#6#7#7#7#7#7#7#7#7#7#8
+#8#8#8#8#8#8#8#8#8#9#9#9#9#10#10#11
+#11#11#11#11#11#11#12#12#12#12#12#12#12#12#12#12
+#13#13#13#14#15#15#17#17#19#3#7#8#9#9#9#10
+#11#11#12#13#15#16#24#0#0#5#6#6#6#7#7#8
+#8#8#9#9#9#9#10#10#10#10#10#10#10#11#11#11
+#11#11#11#11#12#12#12#12#12#12#14#14#15#15#16#17
+#20#6#14#12#14#0#0#6#7#7#7#7#7#8#9#10
+#10#11#12#12#13#13#14#15#15#25#5#7#7#8#9#9
+#11#11#11#11#12#13#14#15#16#16#17#0#5#6#6#7
+#7#7#7#7#7#7#7#7#7#7#8#8#8#8#8#8
+#8#8#8#8#8#9#9#9#9#9#9#9#10#10#10#10
+#10#10#10#10#11#11#11#11#11#11#11#11#12#12#12#12
+#12#12#12#13#13#14#15#15#15#16#16#18#8#17#4#6
+#7#7#7#7#9#9#10#10#10#11#11#11#11#11#11#12
+#12#13#13#13#14#0#4#8#0#6#6#6#7#7#7#7
+#7#7#7#7#7#7#7#7#8#8#8#8#8#8#8#8
+#8#8#8#8#8#8#8#8#9#9#9#9#9#9#9#9
+#9#9#9#9#9#9#9#9#9#9#10#10#10#10#10#10
+#10#10#10#10#10#11#11#11#11#11#11#11#11#11#11#11
+#11#11#11#11#12#12#12#12#12#12#12#12#12#12#12#12
+#13#13#13#13#13#13#13#13#13#13#13#13#13#13#13#13
+#13#14#14#14#14#14#14#14#14#14#14#14#14#14#14#15
+#15#15#15#15#15#16#16#16#16#16#16#17#17#17#17#17
+#19#19#19#20#20#21#24#0#5#8#8#9#10#12#13#14
+#14#15#16#16#17#17#0#7#7#8#8#8#8#8#8#8
+#9#9#10#10#10#10#10#10#11#11#11#11#12#12#12#12
+#13#13#13#13#15#15#16#16#17#17#18#0#11#9#12#5
+#9#10#10#12#14#15#21#8#8#9#11#12#22#0#6#6
+#7#7#7#7#7#7#7#7#7#7#8#8#8#8#9#9
+#9#9#9#9#9#10#10#10#10#10#10#10#10#11#11#11
+#11#11#11#11#12#12#12#12#13#13#13#13#13#13#14#14
+#14#14#14#14#14#15#16#16#17#17#20#5#9#7#8#12
+#3#3#8#8#8#8#8#8#8#8#9#9#9#10#11#11
+#11#11#12#12#13#13#13#14#14#15#19#20#0#6#6#6
+#6#6#7#7#7#8#8#8#8#8#8#8#9#9#9#10
+#10#10#11#11#11#11#11#11#11#11#11#11#11#12#12#12
+#12#12#12#12#12#12#12#13#13#13#13#13#13#13#13#14
+#14#14#14#14#15#15#15#16#16#16#16#19#3#15#3#8
+#10#6#6#8#8#8#9#9#9#9#9#9#9#9#10#10
+#10#10#10#10#10#10#10#11#12#12#12#12#12#12#12#12
+#12#12#13#13#13#13#13#14#14#15#15#15#15#15#15#15
+#16#17#17#17#18#20#19#13#13#14#7#7#7#7#7#8
+#8#8#8#8#8#8#8#8#8#8#8#8#9#9#9#9
+#9#9#9#9#9#9#9#9#9#9#9#9#9#9#9#10
+#10#10#10#10#10#10#10#10#10#10#10#10#10#10#10#10
+#10#10#11#11#11#11#11#11#11#12#12#12#12#12#12#12
+#12#12#12#12#12#13#13#13#13#13#13#13#13#13#13#13
+#13#13#13#13#13#13#13#13#14#14#14#14#14#14#14#14
+#14#14#14#14#14#15#15#15#15#15#15#15#14#16#16#16
+#16#16#16#16#16#16#16#16#17#17#17#17#18#13#14#8
+#9#9#9#11#11#11#12#12#14#16#7#8#9#9#9#9
+#9#9#9#9#9#10#10#10#10#11#12#12#12#12#13#15
+#16#10#5#8#11#12#12#13#13#13#14#14#8#9#12#16
+#16#17#4#6#6#7#8#8#8#8#8#8#8#9#9#9
+#9#9#9#10#10#10#10#10#10#11#11#12#13#13#14#14
+#16#18#18#20#21#9#9#9#9#10#10#10#10#11#11#11
+#12#12#14#9#10#11#12#13#14#15#15#9#16#6#8#9
+#11#11#12#12#12#13#14#10#11#12#14#17#10#10#12#12
+#12#13#16#16#16#22#5#6#7#7#9#10#10#11#13#0
+#11#13#12#13#15#9#15#6#7#7#7#8#8#8#8#8
+#8#8#8#9#9#9#9#9#9#9#9#9#9#9#9#9
+#10#10#10#10#10#10#10#10#10#11#11#11#11#11#11#12
+#12#12#12#12#12#12#13#13#13#13#13#13#13#13#14#14
+#14#15#15#16#17#17#17#17#17#16#7#11#12#13#13#16
+#9#9#12#13#16#16#4#13#13#17#12#15#16#8#10#10
+#10#11#11#13#14#7#8#8#8#9#9#9#9#9#10#10
+#11#11#11#12#12#13#13#13#13#13#13#13#13#14#15#15
+#15#15#16#16#16#18#21#30#0#11#13#16#8#8#9#11
+#12#0#7#8#8#9#9#9#9#9#9#9#10#10#12#12
+#13#14#16#21#7#7#9#10#10#10#10#10#10#11#13#13
+#14#16#16#17#17#25#0#6#8#9#12#7#8#8#9#9
+#9#9#9#9#9#10#10#10#10#10#10#10#10#10#10#11
+#11#11#11#11#11#11#11#12#13#13#13#13#13#14#14#14
+#14#14#15#15#15#16#16#17#17#18#19#18#21#11#12#17
+#19#8#9#9#9#9#9#10#10#10#11#11#11#11#12#12
+#12#12#13#13#13#13#14#14#14#14#15#15#16#16#16#17
+#18#7#8#9#9#9#10#12#13#17#9#10#10#12#13#14
+#14#16#17#17#10#16#23#0#6#6#7#7#7#8#8#8
+#8#8#8#9#9#9#9#9#9#9#9#9#9#10#10#10
+#10#10#10#10#10#10#10#10#10#10#10#10#10#10#10#10
+#11#11#11#11#11#11#11#11#11#11#11#11#11#11#11#11
+#11#11#11#11#11#11#11#11#11#11#12#12#12#12#12#12
+#12#12#12#12#12#12#12#12#12#12#12#13#13#13#13#13
+#13#13#13#13#13#13#13#14#14#14#14#14#14#14#14#14
+#14#14#14#15#15#15#15#15#15#15#15#16#16#16#16#16
+#16#16#16#17#17#17#17#17#17#17#17#17#17#18#18#18
+#19#20#14#9#12#13#9#9#10#10#11#12#12#12#13#13
+#15#15#16#17#18#22#9#11#12#13#17#10#11#7#7#8
+#9#9#10#10#10#10#10#10#11#11#11#11#11#12#12#12
+#12#12#12#13#13#13#13#13#14#14#14#14#14#15#15#16
+#16#16#17#17#17#17#19#18#22#0#7#7#8#8#9#9
+#10#10#10#10#10#10#10#10#11#11#12#12#12#12#12#12
+#13#13#13#13#13#13#13#14#14#14#14#14#14#14#15#15
+#15#15#16#16#16#16#16#16#16#16#17#18#18#18#18#21
+#23#11#12#8#8#9#9#10#11#13#13#14#14#14#15#0
+#8#9#9#9#9#10#11#11#11#11#12#12#12#12#13#13
+#13#13#13#13#14#14#14#14#14#15#15#16#17#19#24#5
+#9#11#12#9#6#9#10#11#12#13#14#15#15#16#16#22
+#12#8#11#11#11#12#15#16#12#9#10#10#12#12#12#12
+#13#15#15#16#16#16#18#20#21#0#10#7#8#9#9#9
+#9#10#10#10#10#10#10#10#10#10#10#11#11#11#11#11
+#11#11#11#11#11#11#12#12#12#12#12#12#12#12#12#12
+#12#12#13#13#13#13#13#13#13#13#14#14#14#14#14#14
+#14#14#14#14#14#14#14#14#15#15#15#15#15#15#15#15
+#15#15#15#15#15#15#16#16#16#16#16#16#16#16#16#16
+#17#17#17#17#17#17#17#17#17#17#17#18#18#18#18#19
+#19#19#19#20#21#24#26#6#14#17#17#10#8#9#9#9
+#10#10#10#10#10#11#11#11#11#11#11#11#11#11#11#11
+#11#12#12#12#12#12#12#13#13#13#13#13#13#14#14#14
+#14#14#14#14#14#14#14#14#14#15#15#15#15#16#16#16
+#16#16#17#17#17#17#17#17#18#18#18#19#19#19#8#9
+#11#12#10#10#9#9#9#10#10#10#10#11#11#11#11#12
+#13#13#14#15#17#18#19#10#10#11#13#13#19#11#11#13
+#15#15#16#9#10#10#11#11#12#12#13#14#14#14#15#15
+#15#15#15#16#18#6#14#9#11#12#14#14#15#15#16#17
+#6#12#14#14#17#25#11#19#9#12#13#13#23#11#15#10
+#11#9#10#10#10#12#12#12#13#13#13#14#14#14#14#14
+#15#15#16#16#16#17#17#18#19#19#19#20#20#21#7#16
+#10#13#14#18#18#10#10#11#11#11#12#12#12#12#12#12
+#12#12#13#13#13#13#13#13#13#14#14#15#15#15#15#15
+#15#15#15#16#16#16#16#16#16#16#16#17#17#17#19#19
+#19#19#19#20#21#22#22#23#24#7#12#13#13#17#17#11
+#11#12#12#13#13#14#15#13#18#12#11#12#12#14#14#15
+#16#16#19#19#20#22#10#13#13#13#14#14#15#15#17#8
+#12#20#8#10#10#13#14#18#18#14#14#15#16#17#18#18
+#21#24#12#12#13#13#13#13#13#13#13#13#14#14#14#14
+#14#14#14#14#15#15#15#15#15#15#15#15#15#15#16#16
+#16#16#16#16#16#16#16#16#16#16#17#17#17#17#17#17
+#17#17#18#18#18#18#18#19#19#19#19#19#19#20#20#20
+#21#14#14#15#15#16#18#18#18#19#19#13#13#14#14#14
+#15#15#17#17#18#18#19#19#22#14#14#15#16#16#17#19
+#12#15#18#22#22#10#13#14#15#15#16#16#16#18#19#20
+#23#25#14#15#17#13#16#16#17#19#19#21#23#17#17#17
+#18#18#19#20#20#20#20#21#17#18#20#23#23#16#17#23;
var
no:integer;
BiHua:integer;
str:string; // str[40]
BiHuaI:integer;
ch1:char;
ch2:char;
len:integer;
begin
str:=chnstr;
BiHuaI:=1;
BiHua:=0;
len:=length(str);
while BiHuaI<=len do
begin
ch1:=str[BiHuaI];
BiHuaI:=BiHuaI+1;
if (ord(ch1)>=176) and (BiHuaI<=len) then
begin
ch2:=str[BiHuaI];
//BiHuaI:=BiHuaI+1; ----这一行在只查一个汉字的时候用不着 2002.10
no:=(ord(ch1)-176)*94+(ord(ch2)-160);
BiHua:=ord(BiHuaTable[no]);
end else
begin
BiHua:=0;
end;
break; // 只要查出第一个汉字即可
end;
result:=BiHua;
end;
end.