⭐ 欢迎来到虫虫下载站！ | 📦 资源下载 📁 资源专辑 ℹ️ 关于我们
⭐ 虫虫下载站
📤 上传资源

📄 comm.pas

📁 县级供电企业电费核算源码, 在客户处正常运行8年以上, Delphi 5开发,数据库为Interbase/Firebird, 深入使用Procedure和Trigger等, 对入门者具有很好的参考价值
💻 PAS
字号:
🔍 
//定义通用过程和函数
unit Comm;

interface
uses
	sysutils,windows,db,dbtables,inifiles,classes,QuickRpt,QrPrntr,FileCtrl,Dialogs;

function ChgTo(S: String):String;//返回加密后的字符串
function ChgFrom(S: String):String;//返回解密后的字符串
function DateString(VDate:TDateTime):String;//把给定的日期转换为YYYYMMDD样的字串
function ZeroString(Str:String; MaxLen:Cardinal):String;//在STR的前面加上0,使STR的长度为MAXLEN
function f_GetID:String;//得到用户的唯一标识码
function F_Registed(Id:String):boolean;//检查软件的合法性,已注册返回TRUE
function f_GenID(UserID:String):string;//用用户的硬件号生成一个识别号
procedure P_OpenTable(DataSet:TDataSet);//打开数据集DataSet
Procedure P_CloseTable(DataSet:TDataSet);//关闭数据集DataSet
Function F_NextNumber(V_Number:String):String;//返回指定编号的下一编号
Function F_FloatToStrF(V_Val:Extended; Precision, Digits:SmallInt):String;//转换浮点数到字符串
Function F_StrToStrF(Value:String ;Precision, Digits:SmallInt):String;//转换浮点数字符串到字符串, 如果为0返回空
Function F_Warp(v_Str:String):String;//字符串回绕
Procedure SqlStrAdd(var SqlStr:String; AddStr:String);//加入指定的条件到SQL字符串
//执行程序或文件
function ExecuteFile(const FileName, Params, DefaultDir: string; ShowCmd: Integer): THandle;
Function IsNull(Val:Variant):boolean;//指定的值为空或''时返回true

//==================================Report======================================
procedure QR_Save(QRpt:TQuickRep;BackupPath:String);//存储报表
//procedure QR_LoadPreview(RptName:String);//装入报表并预览
//procedure QR_LoadPrint(RptName:String);//装入报表并打印
//==================================Report End==================================

//====================================CRC校验===================================
function CrcMtt(Var s:Array of Byte; len:Word):Word;stdcall; Overload;
function CrcMtt(crc,c:Word):Word;stdcall; Overload;
function CrcM16(Var s:Array of Byte;len:Word):Word;stdcall;Overload;
Function CrcM16(crc, c:Word):Word;stdcall; Overload;
function Crc16(Var puchMsg:Array Of Byte;usDataLen:Word):Word;stdcall;//简单的CRC校验程序
function Crc16Set(var puchMsg:Array of Byte;usDataLen:Word):Word;stdcall;//计算Crc16并填充校验码到串后
//====================================end of CRC校验===================================

implementation
uses
	ShellAPI, Variants;
Type
    PType = ^Byte;
//返回加密后的字符串
function ChgTo(S: String):String;
var
   I: Integer;
   DS: String;
Begin
	DS := S;
	for I:=1 to Length(S) do
   begin
   	DS[I] := Chr(Ord(S[I])*2);
   end;
   Result := DS;
End;

//返回解密后的字符串
function ChgFrom(S: String): String;
var
   I: Integer;
   DS: String;
Begin
	DS := S;
	for I:=1 to Length(S) do
   begin
   	DS[I] := Chr(Ord(S[I]) Div 2);
   end;
   ChgFrom := DS;
End;

//日期转换为YYYYMMDD样的串
function DateString(VDate: TDateTime):String;
var
	Year, Month, Day: Word;
    ret_String: String;
begin
	DecodeDate(VDate, Year, Month, Day);
    ret_String := ZeroString(IntToStr(Year),4)
    			+ ZeroString(IntToStr(Month),2)
                + ZeroString(IntToStr(Day),2);
	DateString := Ret_String;
end;

//返回前导0加上STR的串,最后长度为MAXLEN,如原串大于MAXLEN,则返回原串
function ZeroString(Str:String; MaxLen: Cardinal):String;
begin
	while (StrLen(PChar(Str)) < MaxLen) do
    begin
    	Str := '0' + Str;
    end;
    ZeroString := Str;
end;

function F_Registed(Id:String):boolean;
var
    IdUser	:String;
begin//比较注册的ID和用户的ID是否一致
	//用用户的硬件号生成一个识别号,并比较
	IdUser := F_GetID();
    If Id = F_GenID(IdUser) then
    	Result := True
    else
    	Result := False;
end;

function f_GetID:String;
var
//	BiosAdd	:Integer;
//    PCh		:^Char;
    I		:Integer;
    ID		:String;
    Str		:string;
begin
{	ID := '';
    Try
    	BiosAdd:=$FF478;//在DELPHI中内存地址为5BYTES
		For I:=0 to 19 do
   		begin
			PCh := Ptr(BiosAdd);
 			ID := ID + IntToHex(Ord(PCh^),2);
	        BiosAdd := BiosAdd + 1;
    	end;
    Finally
    	If Id = '' then
		begin
            Str := IntToStr(GetVersion()+$8421+GetVersion()+$1248);
			For I := 1 To Strlen(PChar(Str)) do
	 			ID := ID + IntToHex(Ord(Str[I]),2);
        End;
    End;
    Result := ID;}
    Str := IntToStr(GetVersion()+$8421+GetVersion()+$1248);
    For I := 1 To Strlen(PChar(Str)) do
    	ID := ID + IntToHex(Ord(Str[I]),2);
    Result := ID;
end;

function f_GenID(UserID:String):String;//用用户的硬件号生成一个识别号
var
	ID:String;
    I,N:Integer;
    B1, B2:integer;

begin//无须用可逆算法
	ID := '';
    I := 1;
    N := Length(UserID);
	while I < N do
   	begin
    	B1 := Ord(UserID[I]);
        B2 := Ord(UserID[N]);
        ID := ID + IntToHex((B1 * B2) Mod 256,2);
        Inc(I);
        Dec(N);
	end;
    Result := ID;
end;

Procedure P_OpenTable(DataSet:TDataSet);//打开数据集DataSet
Begin
	If Not DataSet.Active Then
    Begin
    	Try
	    	DataSet.Open()
//        	DataSet.Refresh;
        Finally
        	;
        End;
    End;
End;

Procedure P_CloseTable(DataSet:TDataSet);//关闭数据集DataSet
Begin
	If DataSet.Active Then
    	DataSet.Close();
End;

Function F_NextNumber(V_Number:String):String;//返回指定编号的下一编号
Var
	I,Len:SmallInt;
    v_Char: Char;
Begin
	V_Number := Trim(V_Number);
	Len := StrLen(PChar(V_Number));
	If Len > 0 Then
    Begin
    	I := Len;
    	v_Char := V_Number[I];
    	While (V_Char = '9') And (I > 0) Do
    	Begin
    		V_Number[I] := '0';
    	    I := I - 1;
    	    V_Char := V_Number[I];
    	End;
    	If I >= 0 Then
    		V_Number[I] := Chr(Ord(V_Char) + 1);
    End;
    Result := V_Number;
End;

//转换浮点数到字符串
//<>0
//如果精度为0作缺省转换，否则按指定精度和小数位数转换
//=0
//如果小数位数为负表示要返回非空串,即0值返回0.###
//否则返回空串
Function F_FloatToStrF(V_Val:Extended; Precision, Digits:SmallInt):String;
Var
	v_Str:String;
Begin
	If V_Val <> 0 Then
	Begin
    	If Digits < 0 Then//指定的小数位数为负
        	Digits := -Digits;
    	If Precision = 0 Then
        	V_Str := FloatToStr(V_Val)
        Else
	    	v_Str := FloatToStrF(V_Val, ffFixed,Precision,Digits);
	End
    Else
    Begin
    	If Digits < 0 Then//转换为零的字符串
	    Begin
        	If Precision = 0 Then
        		V_Str := FloatToStr(V_Val)
			Else
            	v_Str := FloatToStrF(V_Val, ffFixed,Precision,-Digits);
        End
        Else
       		V_Str := '';
	End;
    Result := V_Str;
End;

//转换浮点数字符串到字符串, 如果为0返回空
//指定的长度为0作缺省转换
Function F_StrToStrF(Value:String ;Precision, Digits:SmallInt):String;
Var
	V_Val:Extended;
Begin
	V_Val := StrToFloat(Value);
	Result := F_FloatToStrF(V_Val, Precision, Digits);
End;

//将字符串中的回车换成空格即可
Function F_Warp(v_Str:String):String;//字符串回绕
var
	sLen, I:SmallInt;
    rStr:String;
Begin
	rStr := v_Str;
	sLen := Length(rStr);
    For I := 1 TO  sLen Do
    Begin
    	if (rStr[I] = #13) Or (rStr[I] = #10) Then
        	rStr[I] := ' ';
    End;
    Result := rStr;
End;

Procedure SqlStrAdd(var SqlStr:String; AddStr:String);//加入指定的条件到SQL字符串
Begin
	if AddStr <> '' then
	Begin
    	if SqlStr <> '' then
	    	SqlStr := SqlStr + ' And (' + AddStr + ')'
        else
        	SqlStr := '(' + AddStr + ')';
    End;
End;

function ExecuteFile(const FileName, Params, DefaultDir: string;
  ShowCmd: Integer): THandle;
var
  zFileName, zParams, zDir: array[0..79] of Char;
begin
  Result := ShellExecute(0, nil,
    StrPCopy(zFileName, FileName), StrPCopy(zParams, Params),
    StrPCopy(zDir, DefaultDir), ShowCmd);
end;

Function IsNull(Val:Variant):boolean;//指定的值为空或''时返回true
Begin
	If (Val = Null) Or (Trim(Val) = '') Then
    	IsNull := True
    Else
    	IsNull := False;
End;

//存储报表
procedure QR_Save(QRpt:TQuickRep;BackupPath:String);
Begin
    if Not DirectoryExists(BackupPath) Then
    Begin
		BackupPath := GetCurrentDir() + '\' + BackupPath;
    	if Not ForceDirectories(BackupPath) Then
        Begin
        	ShowMessage('目录'+BackupPath+'不能建立，报表存储失败!');
        	Exit;
        End
    End;
    With QRpt Do
    Begin
		Try
	    	Prepare();
		    QRPrinter.Save(BackupPath+'\'+Name+'.QRP');
        finally
        	QRPrinter.Free;
	        QRPrinter := nil;
        End;
    End;
End;

{
//装入报表并预览
procedure QR_LoadPreview(RptName:String);
Var
	QRPinter: TQRPrinter;
Begin
    Try
		QRPrinter.Load(RptName);
        QRPrinter.PreviewModal();
    finally
       	QRPrinter.Free;
    End;
End;
}
//装入报表并打印
{
procedure QR_LoadPrint(RptName:String);
Var
	QRPinter: TQRPrinter;
Begin
    try
       	QRPrinter.Load(RptName);
        QRPrinter.Print();
    finally
       	QRPrinter.Free();
    End;
End;
}
//CRC校验函数
// compute crc's checksum*/
// crc-16 is based on the polynomial x^16+x^15+x^2+1 */
//  The data is assumed to be fed in from least to most significant bit */
// crc-ccitt is based on the polynomial x^16+x^12+x^5+1 */
//  The data is fed in from most to least significant bit */
{ The prescription for determining the mask to use for a given polynomial
	is as follows:
		1.  Represent the polynomial by a 17-bit number
		2.  Assume that the most and least significant bits are 1
		3.  Place the right 16 bits into an integer
		4.  Bit reverse if serial LSB's are sent first
}
function CrcMtt(Var s:Array of Byte; len:Word):Word;stdcall;
Var
    crc,i:Word;
Begin
	crc := 0;
	for i:=0 to len-1 do
    	crc := CrcMtt(crc, s[i]);

    result := crc;
End;

function CrcMtt(crc,c:Word):Word;stdcall;
const
    MTT:Word = $1021;		// crc-ccitt mask */
Var
	i:Integer;
Begin
	c := c shl 8;
	for i:=0 to 7 do
	Begin
		if ((crc xor c) and $8000) <> 0 Then
        	crc := (crc shl 1) xor MTT
		else
        	crc := crc shl 1;
		c := c shl 1;
	End;
	result := crc;
End;

function CrcM16(Var s:Array of Byte;len:Word):Word;stdcall;
Var
    crc,i:Word;
Begin
	crc:=0;

	for i:=0 To len-1 Do
    	crc := CrcM16(crc, s[i]);

    result := crc;
End;

// update crc reverse */
Function CrcM16(crc, c:Word):Word;stdcall;
const
    M16:Word = $A001;		// crc-16 mask */
Var
	i:Word;
Begin

	for i:=0 To 7 Do
	Begin
		if((crc xor c) And 1) <> 0 Then
        	crc := (crc shr 1) xor M16
		else
        	crc := crc shr 1;
		c := c shr 1;
	End;
	result := crc;
End;

//=============================================================================
{ CRC 高位字节值表 }
Var
    auchCRCHi:Array[0..255] Of Byte = (
$00, $C1, $81, $40, $01, $C0, $80, $41, $01, $C0,
$80, $41, $00, $C1, $81, $40, $01, $C0, $80, $41,
$00, $C1, $81, $40, $00, $C1, $81, $40, $01, $C0,
$80, $41, $01, $C0, $80, $41, $00, $C1, $81, $40,
$00, $C1, $81, $40, $01, $C0, $80, $41, $00, $C1,
$81, $40, $01, $C0, $80, $41, $01, $C0, $80, $41,
$00, $C1, $81, $40, $01, $C0, $80, $41, $00, $C1,
$81, $40, $00, $C1, $81, $40, $01, $C0, $80, $41,
$00, $C1, $81, $40, $01, $C0, $80, $41, $01, $C0,
$80, $41, $00, $C1, $81, $40, $00, $C1, $81, $40,
$01, $C0, $80, $41, $01, $C0, $80, $41, $00, $C1,
$81, $40, $01, $C0, $80, $41, $00, $C1, $81, $40,
$00, $C1, $81, $40, $01, $C0, $80, $41, $01, $C0,
$80, $41, $00, $C1, $81, $40, $00, $C1, $81, $40,
$01, $C0, $80, $41, $00, $C1, $81, $40, $01, $C0,
$80, $41, $01, $C0, $80, $41, $00, $C1, $81, $40,
$00, $C1, $81, $40, $01, $C0, $80, $41, $01, $C0,
$80, $41, $00, $C1, $81, $40, $01, $C0, $80, $41,
$00, $C1, $81, $40, $00, $C1, $81, $40, $01, $C0,
$80, $41, $00, $C1, $81, $40, $01, $C0, $80, $41,
$01, $C0, $80, $41, $00, $C1, $81, $40, $01, $C0,
$80, $41, $00, $C1, $81, $40, $00, $C1, $81, $40,
$01, $C0, $80, $41, $01, $C0, $80, $41, $00, $C1,
$81, $40, $00, $C1, $81, $40, $01, $C0, $80, $41,
$00, $C1, $81, $40, $01, $C0, $80, $41, $01, $C0,
$80, $41, $00, $C1, $81, $40);

// CRC低位字节值表
    auchCRCLo:Array[0..255] Of Byte = (
$00, $C0, $C1, $01, $C3, $03, $02, $C2, $C6, $06,
$07, $C7, $05, $C5, $C4, $04, $CC, $0C, $0D, $CD,
$0F, $CF, $CE, $0E, $0A, $CA, $CB, $0B, $C9, $09,
$08, $C8, $D8, $18, $19, $D9, $1B, $DB, $DA, $1A,
$1E, $DE, $DF, $1F, $DD, $1D, $1C, $DC, $14, $D4,
$D5, $15, $D7, $17, $16, $D6, $D2, $12, $13, $D3,
$11, $D1, $D0, $10, $F0, $30, $31, $F1, $33, $F3,
$F2, $32, $36, $F6, $F7, $37, $F5, $35, $34, $F4,
$3C, $FC, $FD, $3D, $FF, $3F, $3E, $FE, $FA, $3A,
$3B, $FB, $39, $F9, $F8, $38, $28, $E8, $E9, $29,
$EB, $2B, $2A, $EA, $EE, $2E, $2F, $EF, $2D, $ED,
$EC, $2C, $E4, $24, $25, $E5, $27, $E7, $E6, $26,
$22, $E2, $E3, $23, $E1, $21, $20, $E0, $A0, $60,
$61, $A1, $63, $A3, $A2, $62, $66, $A6, $A7, $67,
$A5, $65, $64, $A4, $6C, $AC, $AD, $6D, $AF, $6F,
$6E, $AE, $AA, $6A, $6B, $AB, $69, $A9, $A8, $68,
$78, $B8, $B9, $79, $BB, $7B, $7A, $BA, $BE, $7E,
$7F, $BF, $7D, $BD, $BC, $7C, $B4, $74, $75, $B5,
$77, $B7, $B6, $76, $72, $B2, $B3, $73, $B1, $71,
$70, $B0, $50, $90, $91, $51, $93, $53, $52, $92,
$96, $56, $57, $97, $55, $95, $94, $54, $9C, $5C,
$5D, $9D, $5F, $9F, $9E, $5E, $5A, $9A, $9B, $5B,
$99, $59, $58, $98, $88, $48, $49, $89, $4B, $8B,
$8A, $4A, $4E, $8E, $8F, $4F, $8D, $4D, $4C, $8C,
$44, $84, $85, $45, $87, $47, $46, $86, $82, $42,
$43, $83, $41, $81, $80, $40);

//简单的CRC校验程序
function Crc16(Var puchMsg:Array Of Byte;usDataLen:Word):Word;stdcall;
Var
	uchCRCHi:Byte;
	uchCRCLo:Byte;
	uIndex:Word; // CRC循环中的索引 */
    i:Word;
Begin
	uchCRCHi := $FF ; // 高CRC字节初始化 */
	uchCRCLo := $FF ; // 低CRC 字节初始化 */

	For i:=0 To usDataLen-1 Do// 传输消息缓冲区 */
	Begin
		uIndex := uchCRCHi xor puchMsg[i];// 计算CRC */
		uchCRCHi := uchCRCLo xor auchCRCHi[uIndex] ;
		uchCRCLo := auchCRCLo[uIndex];
	End;
	result :=  (uchCRCHi shl 8) or uchCRCLo ;
End;
//=============================================================================

//计算Crc16并填充校验码到串后
function Crc16Set(Var puchMsg:Array of Byte;usDataLen:Word):Word;stdcall;
Var
	crc:Word;
Begin
	crc := Crc16(puchMsg, usDataLen);
    puchMsg[usDataLen] := (crc shr 8) And $FF;
    puchMsg[usDataLen+1] := crc And $FF;

    result := crc;
End;


end.

⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -