H
hgptm
Unregistered / Unconfirmed
GUEST, unregistred user!
Dll 代碼:library ComDll;uses SysUtils, Classes, windows, //SPComm30 in 'SPComm30.pas', wiComm in 'wiComm.pas', ComUnit in 'ComUnit.pas';{$R *.res}var ACommServer: TCommServer;//場宎 揹諳 勤砉function InitObject: BOOL; stdcall;begin ACommServer := TCommServer.Create; Result := Assigned(ACommServer);end;//庋溫 揹諳 勤砉procedure UninitObject; stdcall;begin if Assigned(ACommServer) then begin ACommServer.Destroy; end;end;//扢离 隙覃滲杅procedure SetCallBackProc(LpCallBackProc: TCallBackProc); stdcall;begin if Assigned(ACommServer) then ACommServer.CallBackProc := LpCallBackProc;end;//扢离揹諳統杅function SetCommPara(aComID:integer; aRateIdx : integer; var aMsg: string):bool;stdcall;begin Result := false; if Assigned(ACommServer) then Result :=ACommServer.SetCommPara(aComID,aRateIdx,aMsg);end;//湖羲揹諳function OpenComm(aComID:integer; aRateIdx : integer; var aMsg: string):bool;stdcall;begin Result := false; if Assigned(ACommServer) then Result :=ACommServer.OpenComm(aComID,aRateIdx,aMsg);end;//壽敕揹諳function CloseComm(aComID:integer; var aMsg: string):bool;stdcall;begin Result := false; if Assigned(ACommServer) then Result :=ACommServer.CloseComm(aComID,aMsg);end;function ChgType(aComID,aAddress,aSetType:integer; var aMsg: string):bool; stdcall;begin Result := false; if Assigned(ACommServer) then Result :=ACommServer.ChgType(aComID,aAddress,aSetType, aMsg);end;function ChgAddress(aComID,aOldAddress,aNewAddress:integer; var aMsg: string):Bool; stdcall;begin Result := false; if Assigned(ACommServer) then Result :=ACommServer.ChgAddress(aComID,aOldAddress,aNewAddress, aMsg);end;function ChgGain(aComID,aAddress,aGain1,aGain2:integer; var aMsg: string):Bool; stdcall;begin Result := false; if Assigned(ACommServer) then Result :=ACommServer.ChgGain(aComID,aAddress,aGain1,aGain2, aMsg);end;function ChgBRate(aComID,aAddress,aNewBRateIdx:integer; var aMsg: string):Bool; stdcall;begin Result := false; if Assigned(ACommServer) then Result :=ACommServer.ChgBRate(aComID,aAddress,aNewBRateIdx,aMsg);end;Procedure GetCommIsOpen(aComID:integer;var IsOpen:bool; var aMsg: string); stdcall;begin IsOpen := false; if Assigned(ACommServer) then ACommServer.GetCommIsOpen(aComID,IsOpen,aMsg);end;Function GetGBT(aComID,aAddress: integer; var aRecGain1,aRecGain2,aRecRateidx,aRecType:integer):Bool; stdcall;var B: boolean;begin Result := false; B := false; if Assigned(ACommServer) then begin B :=ACommServer.GetGBT(aComID,aAddress,aRecGain1,aRecGain2,aRecRateidx,aRecType); end; Result := B;end;Function AddNewAddress(aComID,aNewAddress:integer; var aMsg: string):Bool;stdcall;begin Result := false; if Assigned(ACommServer) then Result :=ACommServer.AddNewAddress(aComID,aNewAddress,aMsg);end;Function DelAddress(aComID,aAddress:integer; var aMsg: string):Bool; stdcall;begin Result := false; if Assigned(ACommServer) then Result :=ACommServer.DelAddress(aComID,aAddress,aMsg);end;Function GetAllAddress(aComID:integer; aDisChr: Char; var aAddressCnt:integer; var aAddressLst: string; var aMsg: string):Bool; stdcall;begin Result := false; if Assigned(ACommServer) then Result :=ACommServer.GetAllAddress(aComID,aDisChr,aAddressCnt,aAddressLst,aMsg);end;exports InitObject, UninitObject, SetCallBackProc, SetCommPara, OpenComm, CloseComm, ChgType, ChgAddress, ChgGain, ChgBRate, GetGBT, AddNewAddress, DelAddress, GetAllAddress, GetCommIsOpen;beginend.unit ComUnit;interfaceuses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, DateUtils,wiComm,ExtCtrls;Const cnCardCntInPacket: integer =255; cnTimeOut: integer=200; cnComID: array[0..9] of integer=(1,2,3,4,5,6,7,8,9,10); //2-1 植涴饜离 褫 堍俴 嗣屾跺揹諳 cnRate: array[0..9] of integer=(600,1200,2400,4800,9600,14400,19200,38400,57600,115200); cnGain1: array[0..3] of integer=(0,1,2,3); cnGain2: array[0..30] of integer=(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31); cnType: array[0..8] of integer=(1,2,3,4,5,6,7,8,9); cnHead: string='head'; //'7E'; //; // cnHeadEx: string='7E'; cnHead1 : string ='#'; cnTail1 : string='*'; //char cnHead2 : string ='<'; cnTail2 : string ='>'; CRCTbl : array [0..255] of word= (0, 49345, 49537, 320, 49921, 960, 640, 49729, 50689, 1728, 1920, 51009, 1280, 50625, 50305, 1088, 52225, 3264, 3456, 52545, 3840, 53185, 52865, 3648, 2560, 51905, 52097, 2880, 51457, 2496, 2176, 51265, 55297, 6336, 6528, 55617, 6912, 56257, 55937, 6720, 7680, 57025, 57217, 8000, 56577, 7616, 7296, 56385, 5120, 54465, 54657, 5440, 55041, 6080, 5760, 54849, 53761, 4800, 4992, 54081, 4352, 53697, 53377, 4160, 61441, 12480, 12672, 61761, 13056, 62401, 62081, 12864, 13824, 63169, 63361, 14144, 62721, 13760, 13440, 62529, 15360, 64705, 64897, 15680, 65281, 16320, 16000, 65089, 64001, 15040, 15232, 64321, 14592, 63937, 63617, 14400, 10240, 59585, 59777, 10560, 60161, 11200, 10880, 59969, 60929, 11968, 12160, 61249, 11520, 60865, 60545, 11328, 58369, 9408, 9600, 58689, 9984, 59329, 59009, 9792, 8704, 58049, 58241, 9024, 57601, 8640, 8320, 57409, 40961, 24768, 24960, 41281, 25344, 41921, 41601, 25152, 26112, 42689, 42881, 26432, 42241, 26048, 25728, 42049, 27648, 44225, 44417, 27968, 44801, 28608, 28288, 44609, 43521, 27328, 27520, 43841, 26880, 43457, 43137, 26688, 30720, 47297, 47489, 31040, 47873, 31680, 31360, 47681, 48641, 32448, 32640, 48961, 32000, 48577, 48257, 31808, 46081, 29888, 30080, 46401, 30464, 47041, 46721, 30272, 29184, 45761, 45953, 29504, 45313, 29120, 28800, 45121, 20480, 37057, 37249, 20800, 37633, 21440, 21120, 37441, 38401, 22208, 22400, 38721, 21760, 38337, 38017, 21568, 39937, 23744, 23936, 40257, 24320, 40897, 40577, 24128, 23040, 39617, 39809, 23360, 39169, 22976, 22656, 38977, 34817, 18624, 18816, 35137, 19200, 35777, 35457, 19008, 19968, 36545, 36737, 20288, 36097, 19904, 19584, 35905, 17408, 33985, 34177, 17728, 34561, 18368, 18048, 34369, 33281, 17088, 17280, 33601, 16640, 33217, 32897, 16448);type TAddressInfo = Record AddressID: integer; //華硊 Gain1,Gain2,TypeID: integer; isSetParaIng: boolean; //岆瘁淏婓扢离統杅 ,淏婓扢离腔奀緊, 撈溫鞣"MCU楷冞杅擂"腔薹 Active: Boolean; // 岆瘁岆慾魂袨怓 LastRecDt: Tdatetime; //郔摽諉彶奀潔 Sn: Byte; // 序唗 end; TCommRec = Record Com: TwiComm; isSetParaIng: boolean; //岆瘁淏婓扢离統杅 ,淏婓扢离腔奀緊, 撈溫鞣"MCU楷冞杅擂"腔薹 ComID: integer; Rate : integer; Sn: Byte; SendAddress: integer; RecStr: string; AddressLst: array of TAddressInfo; end; TCardState = Record CardID: integer; //卡縐瘍 Normal: integer; //是否正常 0=正常, 1=被拆過 VState: integer; //是否電壓低 0=正常,1=電壓低 GainState: integer; //增益 0,1,2,3 end;type TCallBackProc = Function(aComID,aAddress:integer; aCardID: array of TCardState; aRecDt: Tdatetime):bool of Object; TCommServer = Class private FIsRecing: boolean; FCallBackProc : TCallBackProc; Function TriggerRec(aComID:integer; aBuff:String; aBufferLength: Word; var aRecCardID :array of TCardState ; var aRecGain1,aRecGain2,aRecRateidx,aRecAddress,aRecType,aAddress:integer; var IsRecErr:Bool):bool; procedure OnTimerTimer(Sender: TObject); Procedure RefreshAddressTo(aComID,aAddress:integer; aSn: Byte); Function PcAskMCUSendData(aComID,aAddress:integer;aSn: Byte; var aMsg: string):bool; Function FindAddRessIdx(aComID,aAddress: integer):integer; Function SetInterval(amSec: integer; aisStartScan:boolean; var aMsg: string):boolean; //stdcall; Procedure ProcessRecStr(CommIdx: integer; PacketStartChr,PacketEndChr: string; var FRecStr: string); function FindNextAddRess(aComID, aAddress: integer; var aNextAddress: integer; var aNextSn: Byte): integer; protected public Comm: array[0..9] of TCommRec; //2-2 植涴饜离 褫 堍俴 嗣屾跺揹諳 迵 cnComID 饜杶扢离 Timer : TTimer; constructor Create; //override; destructor Destroy; override; Function SetCommPara(aComID:integer; aRateIdx : integer; var aMsg: string):boolean; stdcall; Function OpenComm(aComID:integer; aRateIdx : integer; var aMsg: string):boolean; stdcall; Function CloseComm(aComID:integer; var aMsg: string):boolean; stdcall; Function ChgType(aComID,aAddress,aSetType:integer; var aMsg: string):bool; stdcall; Function ChgAddress(aComID,aOldAddress,aNewAddress:integer; var aMsg: string):Bool; stdcall; Function ChgGain(aComID,aAddress,aGain1,aGain2:integer; var aMsg: string):Bool; stdcall; Function ChgBRate(aComID,aAddress,aNewBRateIdx:integer; var aMsg: string):Bool; stdcall; Procedure GetCommIsOpen(aComID:integer;var IsOpen:bool; var aMsg: string); stdcall; Function GetGBT(aComID,aAddress: integer; var aRecGain1,aRecGain2,aRecRateidx,aRecType:integer):Bool; stdcall ; Function AddNewAddress(aComID,aNewAddress:integer; var aMsg: string):Bool;stdcall; Function DelAddress(aComID,aAddress:integer; var aMsg: string):Bool; stdcall; Function GetAllAddress(aComID:integer; aDisChr: Char; var aAddressCnt:integer; var aAddressLst: string; var aMsg: string):Bool; Published Property CallBackProc: TCallBackProc Read FCallBackProc write FCallBackProc; end; Function addCRC(PreResult : Word; curChr : char) : Word; Procedure ConvByCRC(var CmdChr: String); procedure WriteFloat(V: Single;idx : integer;var Buff : array of char);//4 bytes Function ReadFloat(idx : integer;Buff : array of char): Single;//4 bytes function Readbyte(Idx : integer; Buff : array of char): byte; procedure WriteByte(V: byte;idx : integer; var Buff : array of char); //byte 1byte procedure WriteWord(V: word;idx : integer;var Buff : array of char); //word 2bytes function ReadWord(Idx : integer; Buff : array of char): Word; function ReadWordEx(Idx : integer; Buff : array of Byte): Word; function ReadSmallint(Idx : integer; Buff : array of char): Smallint; procedure WriteSmallint(V: Smallint;idx : integer;var Buff : array of char); //word 2bytes Function ReadInteger(Idx: integer; Buff : array of char): integer; Function ReadIntegerEx(Idx: integer; Buff : array of byte): integer; procedure WriteInteger(V: Integer;idx : integer; var Buff : array of char); function ReadInt64(n : integer; T : array of char):string; //蚳峈馱瘍 function ReadString(Len: Integer;idx : integer; T : array of char): string; function ReadStringEx(Len: Integer;idx : integer; T : array of Byte): string; Function ReadDateTime(n:integer;T: array of Char; DefaultDateTime:Tdatetime): Tdatetime; Function ReadDateTimeEx(n:integer;T: array of Char; DefaultDateTime:Tdatetime): Tdatetime; Procedure WriteDateTime(curDatetime:Tdatetime; n:integer;var T: array of Char); Procedure WriteDateTimeEx(curDatetime:Tdatetime; n:integer;var T: array of Char); procedure WriteInt64(I: int64;idx : integer;var b : array of char); //int64 4bytes procedure WriteIntegerEx(I: Integer;idx : integer;var B : array of char); //楷砃萇齟integer 4bytes procedure WriteString(s: String; Len: Integer;idx : integer;var B : array of char);//string //function GetComClass: ICom; stdcall; procedure Delay(const MilliSecond: LongWord); Function FormatStr(Str: string; Len: integer; FillChr:string):string; Function IntToBin(value : Longint;Size : integer): string; Function BinToInt(value : string) : longint;implementationprocedure TCommServer.OnTimerTimer(Sender: TObject);var i,j,hi,Lo,aHi,aLo,aLen,p: integer; msg : string; B : bool; aBufCnt,aCnt: integer; aR: boolean; St: longword; aSS,str: string; aRecCardID,aRecGain,aRecRateidx,aRecAddress,aRecType,aAddress,aNextAddress:integer; // st : longword; aNextSn: Byte; Flt : Double; Function CheckIsSeting(CommIdx: integer): boolean; var i,j,Hi,Lo: integer; R1,R2: boolean; begin Result :=false; R1 := false; R2 := False; try with Comm[CommIdx] do begin R1 :=isSetParaIng; if not R1 then begin Hi := High(AddressLst); Lo := Low(AddressLst); for j:=Lo to Hi do begin R2:=AddressLst[j].isSetParaIng; if R2 then Break; end; end; end; Finally Result := R1 or R2; end; end;begin st := Gettickcount; //(Sender as TTimer).Enabled := false; FIsRecing := true; try Lo := low(Comm); Hi := High(Comm); for i:=Lo to Hi do begin with Comm do begin if not (Com.Active) then continue; aR := CheckIsSeting(i); if aR then begin continue; end; aBufCnt :=0; Com.ReceiveString(ass,aBufCnt); if aBufCnt>0 then begin RecStr := RecStr + ass; str := Recstr; ProcessRecStr(i,CnHead2,cnTail2,RecStr); end; PcAskMCUSendData(ComID,SendAddress,Sn,msg); p :=FindNextAddRess(ComID,SendAddress,aNextAddress,aNextSn); SendAddress := aNextAddress; // Sn := aNextSn; if p<>-1 then AddressLst[p].Active := (now -AddressLst[p].LastRecDt)*24*3600<=10; //10鏃眕囀,拸杅擂 寀絞釬 帤慾魂 end; end; //str := floattostr((Gettickcount-st)/1000); Finally begin FIsRecing := False; Flt := Gettickcount-St; str := FormatFloat('00.00000',Flt); str :=Str; end; end;end;Procedure TCommServer.ProcessRecStr(CommIdx: integer; PacketStartChr,PacketEndChr: string; var FRecStr: string);var FPacketStart: integer; //報頭位置 FPacketEnd: integer; //報尾位置 FII,i,idx: integer; Fstr,FcurProcessStr,FTmpstr : string; //每次接收的內容 B : Boolean; aRecCardID: array[0..254] of TCardState; aRecGain1,aRecGain2,aRecRateidx,aRecAddress,aRecType,aAddress:integer; IsRecErr: Bool;begin if length(FRecStr)<>0 then begin FPacketStart := pos(PacketStartChr,FRecstr); FPacketEnd := pos(PacketEndChr,FRecStr); Repeat //1.報頭位置>0,報尾位置=0 //2.報頭位置=0,報尾位置>0 if (FPacketStart=0) and (FPacketEnd >0) then Delete(FRecstr,1,FPacketEnd+length(PacketEndChr)-1); //3.報頭位置=0,報尾位置=0 //4.報頭位置>0,報尾位置>0 if (FPacketStart>0) and (FPacketEnd >0) then begin //4.1.報尾位置<報頭位置 if (FPacketEnd <FPacketStart) then Delete(FRecstr,1,FPacketStart-1); //4.2.報尾位置>報頭位置 注意現象: [報頭1***報頭2*****報尾2]中間夾著"報頭2" // 實際上完整的報是:[報頭2*****報尾2],[報頭1***]是壞報 if (FPacketEnd >=FPacketStart) then begin Fstr :=copy(FRecStr, FPacketStart+length(PacketStartChr), FPacketEnd-(FPacketStart+length(PacketStartChr))); FII:= Pos(PacketStartChr,Fstr); while FII>0 do begin FPacketStart:= FPacketStart+length(PacketStartChr)-1+FII; delete(Fstr,1,FII+length(PacketStartChr)-1); FII:= Pos(PacketStartChr,Fstr); end; FTmpstr := Copy(FRecStr,1,FPacketStart-1); delete(FRecStr,1,FPacketStart-1); //關鍵 FPacketStart := pos(PacketStartChr,FRecstr); FPacketEnd := pos(PacketEndChr,FRecStr); FcurProcessStr :=copy(fRecstr,fPacketStart,fPacketEnd+length(PacketEndChr)-fPacketStart); //當前處理的包 try B :=TriggerRec(Comm[CommIdx].ComID, FcurProcessStr, Length(FcurProcessStr), aRecCardID, aRecGain1,aRecGain2,aRecRateidx,aRecAddress,aRecType,aAddress,IsRecErr); B := B and (not IsRecErr); if B then begin if Assigned(FCallBackProc) then begin //蚚隙覃滲杅 籵眭 諷璃妏蚚氪 FCallBackProc(Comm[CommIdx].ComID,aAddress, aRecCardID,now); // Delay(1); end; end; Except end; delete(FRecstr,FPacketStart,FPacketEnd+length(PacketEndChr)-FPacketStart); end; end; FPacketStart := pos(PacketStartChr,FRecstr); FPacketEnd := pos(PacketEndChr,FRecStr); Until (FPacketStart=0) or (FPacketEnd=0) or (length(trim(FRecStr))=0); end else begin end;end;//aBuff = 含報頭,報尾後Function TCommServer.TriggerRec(aComID:integer; aBuff:String; aBufferLength: Word; var aRecCardID :array of TCardState ; var aRecGain1,aRecGain2,aRecRateidx,aRecAddress,aRecType,aAddress:integer; var IsRecErr:Bool):bool;var Len,i,j,p,idx,Hi,Lo,aSn,aRecCnt: integer; Recstr,Msg,str: string; aCardID: integer; Sn: Byte; aCmd: String; FSumAsc,tmpSumAsc: word; S,S1,S2,S3,S4,S5,S6,S7,S8: String; B : Boolean;begin try Result := false; Hi := high(aRecCardID); Lo := low(aRecCardID); for i:=Lo to Hi do begin with aRecCardID do begin CardID:=0; //卡號 Normal:=0; //是否正常 0=正常, 1=被拆過 VState:=0; //是否電壓低 0=正常,1=電壓低 GainState:=0; //增益 0,1,2,3 end; end; aRecGain1:=0; aRecGain2:=0; aRecRateidx:=0; aRecAddress:=0; aRecType:=0; IsRecErr :=False; //1-3 苺桄 FSumAsc:=0; Hi := aBufferLength - Length(cnTail2)-4; Lo := length(cnHead2)+1; for i:=Lo to Hi do begin FSumAsc := addCRC(FSumAsc,aBuff); //if i<=aBufferLength-4 - length(cnHead2)-Length(cnTail2) then end; S := Format('%0x',[FSumAsc]); S := FormatStr(S,4,'0'); S1 := S[1]; S2 := S[2]; S3 := S[3]; S4 := S[4]; S5 :=aBuff[Hi+1]; S6 :=aBuff[Hi+2]; S7 :=aBuff[Hi+3]; S8 :=aBuff[Hi+4]; B := (S1=S5) and (S2=S6) and (S3=S7) and (S4=S8); if not B then begin //CRC效驗不ok Exit; end; //2 腕韜鍔晤瘍, 華硊 idx :=2; Str := '$' + Copy(aBuff,idx,2); inc(idx,2); aAddress := strToint(str); aCmd :=Uppercase(trim(aBuff[idx])); inc(idx); //3.1 Read Data if aCmd=Uppercase(trim('R')) then begin str := '$' + aBuff[idx] + aBuff[idx+1]; inc(idx,2); aSn := strToint(str); str := '$' + aBuff[idx]; inc(idx); aRecGain1:= strToint(str); str := '$' + aBuff[idx] + aBuff[idx+1]; inc(idx,2); aRecGain2:= strToint(str); str := '$' + aBuff[idx]; inc(idx); aRecType:= strToint(str); str := '$' + aBuff[idx]; inc(idx); aRecRateidx:= strToint(str); str := '$' + aBuff[idx]+ aBuff[idx+1]; inc(idx,2); aRecCnt:= strToint(str); if (aRecCnt>cnCardCntInPacket) or (aRecCnt<0) then begin Result := false; exit; end; Lo := Low(aRecCardID); for i:=1 to aRecCnt do begin Str := Copy(aBuff,idx,6); inc(idx,6); S := '$' + Str; p := strToint(S); Str := IntToBin(P,24); aRecCardID[Lo].Normal := StrToint(Str[1]); aRecCardID[Lo].VState := StrToint(Str[2]); S := Str[3] + str[4]; aRecCardID[Lo].GainState := BinToInt(s); S := Copy(Str,5,20); aRecCardID[Lo].CardID := BinToInt(s); inc(Lo); end; //aAddressIdx :=aAddress-1; RefreshAddressTo(aComID,aAddress,aRecCnt); Result := true; exit; end; //3.2 Chg Gain if aCmd=Uppercase(trim('G')) then begin Str := Copy(aBuff,idx,2); inc(idx,2); Result := Uppercase(trim(Str))=Uppercase(trim('OK')); exit; end; //3.3 chg Address if aCmd=Uppercase(trim('A')) then begin Str := Copy(aBuff,idx,2); inc(idx,2); Result := Uppercase(trim(Str))=Uppercase(trim('OK')); exit; end; //3.4 chg Type if aCmd=Uppercase(trim('T')) then begin Str := Copy(aBuff,idx,2); inc(idx,2); Result := Uppercase(trim(Str))=Uppercase(trim('OK')); exit; end; //3.5 chg BoRate if aCmd=Uppercase(trim('B')) then begin Str := Copy(aBuff,idx,2); inc(idx,2); Result := Uppercase(trim(Str))=Uppercase(trim('OK')); exit; end; //3.6 CRC Err if aCmd=Uppercase(trim('E')) then begin IsRecErr := True; Str := Copy(aBuff,idx,2); inc(idx,2); Result := Uppercase(trim(Str))=Uppercase(trim('RR')); exit; end; Except end;end;Function TCommServer.SetInterval(amSec: integer; aisStartScan:boolean; var aMsg: string):boolean;begin Result := false; try //IsEnable := Timer.Enabled ; Timer.Enabled := false; Timer.Interval := amSec ; Timer.Enabled := aisStartScan; Result := true; exit; Except on E:Exception do aMsg := E.Message; end;end;constructor TCommServer.Create;var i,Lo,Hi,aLo,aHi,j : integer; msg : string;begin inherited Create; try //Self.FCallBackProc := aCallBackProc; Hi := High(Comm); Lo := Low(Comm); For i:=Lo to Hi do begin Comm.Com := TwiComm.Create(nil); Comm.isSetParaIng:=false; //岆瘁淏婓扢离統杅 ,淏婓扢离腔奀緊, 撈溫鞣"MCU楷冞杅擂"腔薹 Comm.Sn :=0; Comm.SendAddress :=-1; Comm.RecStr:=''; Setlength(Comm.AddressLst,0); end; FIsRecing := False; Timer := TTimer.Create(nil); Timer.OnTimer := OnTimerTimer; SetInterval(333,true,msg); Except end;end;destructor TCommServer.Destroy;var i,Lo,Hi : integer; msg : string; st : longword; Flt : double;begin try SetInterval(333,false,msg); St := Gettickcount; Flt := (Gettickcount-St)/1000; Repeat Timer.Enabled:= false; Flt := Gettickcount-St; Until (Flt>=3) or (not FisRecing); if Timer<>nil then FreeAndNil(Timer); Hi := High(Comm); Lo := Low(Comm); For i:=Lo to Hi do begin if Comm.Com<>Nil then begin Comm.com.Destroy; end; end; Except end; //inherited Destroy; inherited;end;Function TCommServer.FindAddRessIdx(aComID,aAddress: integer):integer;var i,Lo,Hi,aComIdx: integer;begin Result := -1; try aComIdx := aComID-1; with Comm[aComIdx] do begin hi := high(AddressLst); Lo := low(AddressLst); For i:=Lo to hi do begin if AddressLst.AddressID =aAddress then begin Result := i; Exit; end; end; end; Except end;end;Function TCommServer.FindNextAddRess(aComID,aAddress: integer; var aNextAddress: integer; var aNextSn: Byte):integer;var i,Lo,Hi,aComIdx,aCnt,p: integer;begin Result := -1; aNextAddress :=-1; aNextSn := 0; try aComIdx := aComID-1; with Comm[aComIdx] do begin hi := high(AddressLst); Lo := low(AddressLst); aCnt := hi-Lo+1; For i:=Lo to hi do begin if AddressLst.AddressID =aAddress then begin if i=hi then p:=Lo-1; inc(p); aNextAddress:= AddressLst[p].AddressID; aNextSn := AddressLst[p].Sn; Result :=p; Exit; end; end; if (aNextAddress=-1) and (aCnt>0) then begin aNextAddress:= AddressLst[Lo].AddressID; aNextSn := AddressLst[Lo].Sn; Result := Lo; end; end; Except end;end;Procedure TCommServer.RefreshAddressTo(aComID,aAddress:integer; aSn: Byte);var aComIdx,p,Cnt,Hi,Lo : integer; Str : string;begin try aComIdx := aComID-1; p := FindAddRessIdx(aComID,aAddress); if p=-1 then begin with Comm[aComIdx] do begin hi := high(AddressLst); Lo := Low(AddressLst); cnt := hi-lo+1+1 ; Setlength(AddressLst,cnt); AddressLst[Cnt-1].AddressID := aAddress; AddressLst[Cnt-1].Active := true; AddressLst[Cnt-1].LastRecDt := now; AddressLst[Cnt-1].Sn :=0; end; end else begin with Comm[aComIdx].AddressLst[p] do begin //AddressID:= aAddress; //華硊 Active:=true; // 岆瘁岆慾魂袨怓 LastRecDt:=now; //郔摽諉彶奀潔 Sn := Sn + aSn; Str := inttostr( Sn); Active:=true; // 岆瘁岆慾魂袨怓 LastRecDt:=now; //郔摽諉彶奀潔 end; end; Except end;end;//=======================================================//扢离 揹諳 統杅Function TCommServer.SetCommPara(aComID:integer; aRateIdx : integer; var aMsg: string):boolean;var i,hi,Lo,aComIdx: integer; B : Boolean;begin Result := false; aMsg:=''; aComIdx := aComID-1; B := Timer.Enabled; Timer.Enabled := false; while (Timer.Enabled) or (FIsRecing) do begin Timer.Enabled := false; end; try try with Comm[aComIdx] do begin isSetParaIng := true; try Com.ClosePort; Com.OpenPort(aComID,cnRate[aRateIdx],'n',8,1); Com.Tag := aComID; // ComID := aComID; Rate := cnRate[aRateIdx]; RecStr:=''; Finally isSetParaIng := false; end; end; Result := true; exit; Except on E:Exception do aMsg := E.Message; end; Finally timer.Enabled := B; end;end;//羲 揹諳 Function TCommServer.OpenComm(aComID:integer; aRateIdx : integer; var aMsg: string):boolean;var i,hi,Lo,aComIdx: integer;begin Result := false; aMsg:=''; aComIdx := aComID-1; try if not SetCommPara(aComID,aRateIdx,aMsg) then begin Exit; end; Result := true; exit; Except on E:Exception do aMsg := E.Message; end;end;//壽敕 揹諳Function TCommServer.CloseComm(aComID:integer; var aMsg: string):boolean;var i,hi,Lo,aComIdx: integer;begin Result := false; aMsg:=''; aComIdx := aComID-1; try Comm[aComIdx].com.ClosePort; Result := true; exit; Except on E:Exception do aMsg := E.Message; end;end;//楷冞 "PcMCU楷冞杅擂"硌鍔 //var aRecCardID:integer;Function TCommServer.PcAskMCUSendData(aComID,aAddress:integer;aSn: Byte; var aMsg: string):bool;var i,hi,Lo,aComIdx,Cnt,idx: integer; CmdChr : String; //array[0..1024] of Byte; s: string; str : string; aRecGain,aRecRateidx,aRecAddress,aRecType:integer;begin Result := false; aMsg:=''; aComIdx := aComID-1; CmdChr :=''; try CmdChr := CmdChr + cnHead1[1] ; S := Format('%0x',[aAddress]); S := FormatStr(S,2,'0'); CmdChr := CmdChr + S; CmdChr := CmdChr + 'R'; s := Format('%0x',[aSn]); S := FormatStr(S,2,'0'); CmdChr := CmdChr + S; ConvByCRC(CmdChr); Comm[aComIdx].Com.SendString(cmdChr); // Sendbuffer(cmdChr,idx); exit; Except on E:Exception do aMsg := E.Message; end;end;//楷冞 "扢隅濬倰"硌鍔 善 揹諳Function TCommServer.ChgType(aComID,aAddress,aSetType:integer; var aMsg: string):bool;var i,j,hi,Lo,aComIdx,Cnt,idx,p,Len: integer; CmdChr,buff : string; //BuffChr : array[0..1024] of Char; s: string; B : Boolean; aRecCardID: array[0..254] of TCardState; aRecGain1,aRecGain2,aRecRateidx,aRecAddress,aRecType: integer; aIsRecErr: Bool;begin Result := false; aMsg:=''; aComIdx := aComID-1; Timer.Enabled := false; while (Timer.Enabled) or (FIsRecing) do begin Timer.Enabled := false; end; try p := FindAddRessIdx(aComID,aAddress); if p<>-1 then begin Comm[aComIdx].AddressLst[p].isSetParaIng := true; end else begin Exit; end; CmdChr :=''; try CmdChr := CmdChr + cnHead1[1] ; s := Format('%0x',[aAddress]); S := FormatStr(S,2,'0'); CmdChr := CmdChr + S; CmdChr := CmdChr + 'T'; s := Format('%0x',[aSetType]); S := FormatStr(S,1,'0'); CmdChr := CmdChr + S; ConvByCRC(CmdChr); Len := Length(CmdChr); for i:=1 to 10 do begin buff := CmdChr; idx := Len; Result :=Comm[aComIdx].Com.ReceiveDataByString(buff,idx,11,cnTimeOut)<>-1; if Result then begin B :=TriggerRec(aComID,buff,idx,aRecCardID,aRecGain1,aRecGain2,aRecRateidx,aRecAddress,aRecType,aAddress,aIsRecErr); Result := B and (not aIsRecErr); end; if Result then begin Comm[aComIdx].AddressLst[p].TypeID := aSetType; break; end; end; if not Result then begin aMsg :='党蜊濬梗 囮啖.'; end; exit; Except on E:Exception do aMsg := E.Message; end; Finally begin if p<>-1 then begin Comm[aComIdx].AddressLst[p].isSetParaIng := false; end; Timer.Enabled := true; end; end;end;Function TCommServer.ChgAddress(aComID,aOldAddress,aNewAddress:integer; var aMsg: string):Bool;var i,j,hi,Lo,aComIdx,Cnt,idx,p,Len: integer; CmdChr,buff : string; s: string; B : Boolean; aRecCardID: array[0..254] of TCardState; aRecGain1,aRecGain2,aRecRateidx,aRecAddress,aRecType: integer; aIsRecErr: Bool;begin Result := false; aMsg:=''; aComIdx := aComID-1; Timer.Enabled := false; while (Timer.Enabled) or (FIsRecing) do begin Timer.Enabled := false; end; try p := FindAddRessIdx(aComID,aOldAddress); if p<>-1 then begin Comm[aComIdx].AddressLst[p].isSetParaIng := true; end else begin Exit; end; CmdChr :=''; try CmdChr := CmdChr + cnHead1[1] ; s := Format('%0x',[aOldAddress]); S := FormatStr(S,2,'0'); CmdChr := CmdChr + S; CmdChr := CmdChr + 'A'; s := Format('%0x',[aNewAddress]); S := FormatStr(S,2,'0'); CmdChr := CmdChr + S; ConvByCRC(CmdChr); Len := Length(CmdChr); for i:=1 to 10 do begin buff := CmdChr; idx := Len; Result :=Comm[aComIdx].Com.ReceiveDataByString(buff,idx,11,cnTimeOut)<>-1; if Result then begin B :=TriggerRec(aComID,buff,idx,aRecCardID,aRecGain1,aRecGain2,aRecRateidx,aRecAddress,aRecType,aOldAddress,aIsRecErr); Result := B and (not aIsRecErr); end; if Result then begin break; end; end; if not Result then begin aMsg :='党蜊華硊 囮啖.'; end; exit; Except on E:Exception do aMsg := E.Message; end; Finally begin if p<>-1 then begin Comm[aComIdx].AddressLst[p].isSetParaIng := false; end; Timer.Enabled := true; end; end;end;Function TCommServer.ChgGain(aComID,aAddress,aGain1,aGain2:integer; var aMsg: string):Bool;var i,j,hi,Lo,aComIdx,Cnt,idx,p,Len: integer; CmdChr,buff : string; //BuffChr : array[0..1024] of Char; s: string; B : Boolean; aRecCardID: array[0..254] of TCardState; aRecGain1,aRecGain2,aRecRateidx,aRecAddress,aRecType: integer; aIsRecErr: Bool; St : longword; Flt : Double;begin Result := false; aMsg:=''; aComIdx := aComID-1; Timer.Enabled := false; (*St := Gettickcount; Flt := (Gettickcount-St)/1000; while (Timer.Enabled) or (FIsRecing) or (Flt<=3) do begin Timer.Enabled := false; Flt := (Gettickcount-St)/1000; end;*) St := Gettickcount; Flt := (Gettickcount-St)/1000; Repeat Timer.Enabled:= false; Flt := Gettickcount-St; Until (Flt>=3) or (not FisRecing); try p := FindAddRessIdx(aComID,aAddress); if p<>-1 then begin Comm[aComIdx].AddressLst[p].isSetParaIng := true; end else begin Exit; end; CmdChr :=''; try CmdChr := CmdChr + cnHead1[1] ; s := Format('%0x',[aAddress]); S := FormatStr(S,2,'0'); CmdChr := CmdChr + S; CmdChr := CmdChr + 'G'; s := Format('%0x',[aGain1]); S := FormatStr(S,1,'0'); CmdChr := CmdChr + S; s := Format('%0x',[aGain2]); S := FormatStr(S,2,'0'); CmdChr := CmdChr + S; ConvByCRC(CmdChr); Len := Length(CmdChr); for i:=1 to 10 do begin buff := CmdChr; idx := Len; Result :=Comm[aComIdx].Com.ReceiveDataByString(buff,idx,11,cnTimeOut)<>-1; if Result then begin B :=TriggerRec(aComID,buff,idx,aRecCardID,aRecGain1,aRecGain2,aRecRateidx,aRecAddress,aRecType,aAddress,aIsRecErr); Result := B and (not aIsRecErr); end; if Result then begin Comm[aComIdx].AddressLst[p].Gain1 := aGain1; Comm[aComIdx].AddressLst[p].Gain2 := aGain2; break; end; end; if not Result then begin aMsg :='党蜊崝祔 統杅 囮啖.'; end; exit; Except on E:Exception do aMsg := E.Message; end; Finally begin if p<>-1 then begin Comm[aComIdx].AddressLst[p].isSetParaIng := false; end; Timer.Enabled := true; end; end;end;Function TCommServer.ChgBRate(aComID,aAddress,aNewBRateIdx:integer; var aMsg: string):Bool;var i,j,hi,Lo,aComIdx,Cnt,idx,p,Len: integer; CmdChr,buff : string; s: string; B : Boolean; aRecCardID: array[0..254] of TCardState; aRecGain1,aRecGain2,aRecRateidx,aRecAddress,aRecType: integer; aIsRecErr: Bool;begin Result := false; aMsg:=''; aComIdx := aComID-1; Timer.Enabled := false; while (Timer.Enabled) or (FIsRecing) do begin Timer.Enabled := false; end; try p := FindAddRessIdx(aComID,aAddress); if p<>-1 then begin Comm[aComIdx].AddressLst[p].isSetParaIng := true; end else begin Exit; end; CmdChr :=''; try CmdChr := CmdChr + cnHead1[1] ; s := Format('%0x',[aAddress]); S := FormatStr(S,2,'0'); CmdChr := CmdChr + S; CmdChr := CmdChr + 'B'; s := Format('%0x',[aNewBRateIdx]); S := FormatStr(S,1,'0'); CmdChr := CmdChr + S; ConvByCRC(CmdChr); Len := Length(CmdChr); for i:=1 to 10 do begin buff := CmdChr; idx := Len; Result :=Comm[aComIdx].Com.ReceiveDataByString(buff,idx,11,cnTimeOut)<>-1; if Result then begin B :=TriggerRec(aComID,buff,idx,aRecCardID,aRecGain1,aRecGain2,aRecRateidx,aRecAddress,aRecType,aAddress,aIsRecErr); Result := B and (not aIsRecErr); end; if Result then begin Comm[aComIdx].Rate := cnRate[aNewBRateIdx]; break; end; end; if not Result then begin aMsg :='党蜊疏杻薹 囮啖.'; end; exit; Except on E:Exception do aMsg := E.Message; end; Finally begin if p<>-1 then begin Comm[aComIdx].AddressLst[p].isSetParaIng := false; end; Timer.Enabled := true; end; end;end;Procedure TCommServer.GetCommIsOpen(aComID:integer;var IsOpen:bool; var aMsg: string);var aComIdx : integer; B: boolean;begin try IsOpen := false; aComIdx := aComID-1; B := Comm[aComIdx].Com.Active ; if B then IsOpen := True else IsOpen:= false; //aMsg :='hellow'; Except on E:Exception do aMsg := E.Message; end;end;Function TCommServer.GetGBT(aComID,aAddress: integer; var aRecGain1,aRecGain2,aRecRateidx,aRecType:integer):Bool;var i,j,hi,Lo,aComIdx,Cnt,idx,p,Len: integer; s: string; B : Boolean;begin Result := false; aComIdx := aComID-1; p := FindAddRessIdx(aComID,aAddress); if p=-1 then begin Exit; end; with Comm[aComIdx].AddressLst[P] do begin aRecGain1 :=Gain1; aRecGain2 :=Gain2; aRecType := TypeID; end; with Comm[aComIdx] do begin aRecRateidx := -1; hi:= high(cnRate); Lo:= low(cnRate); for i:= Lo to Hi do begin if cnRate= Rate then begin aRecRateidx := i; end; end; end; Result := true;end;//Add New AddressFunction TCommServer.AddNewAddress(aComID,aNewAddress:integer; var aMsg: string):Bool;var i,j,hi,Lo,aComIdx,Cnt,idx,p,Len: integer; CmdChr,buff : string; s: string; B : Boolean; aRecCardID: array[0..254] of TCardState; aRecGain1,aRecGain2,aRecRateidx,aRecAddress,aRecType: integer; aIsRecErr: Bool; aActive: boolean; aCnt: integer;begin Result := false; aMsg:=''; aComIdx := aComID-1; Comm[aComIdx].isSetParaIng :=true; Timer.Enabled := false; while (Timer.Enabled) or (FIsRecing) do begin Timer.Enabled := false; end; try p := FindAddRessIdx(aComID,aNewAddress); if p<>-1 then begin aMsg :='華硊: ' + inttostr(aNewAddress) + ' 眒冪湔婓.'; exit; end; with Comm[aComIdx] do begin Try hi:= High(AddressLst); Lo := Low(AddressLst); aCnt := Hi-Lo+1; Setlength(AddressLst,aCnt+1); AddressLst[aCnt].Gain1:=cnGain1[3]; AddressLst[aCnt].Gain2 :=cnGain2[14]; AddressLst[aCnt].TypeID:=cnType[8]; AddressLst[aCnt].AddressID := aNewAddress; //場扢 華硊 AddressLst[aCnt].Active := false; // 岆瘁岆慾魂袨怓 AddressLst[aCnt].LastRecDt :=-1; //郔摽諉彶奀潔 AddressLst[aCnt].isSetParaIng := false; AddressLst[aCnt].Sn :=0; Except end; end; Result := true; Finally begin Comm[aComIdx].isSetParaIng :=false; Timer.Enabled := true; end; end;end;//Get All Address Function TCommServer.GetAllAddress(aComID:integer; aDisChr: Char; var aAddressCnt:integer; var aAddressLst: string; var aMsg: string):Bool;var i,Lo,Hi,aComIdx:integer;begin Result := false; aMsg:=''; aAddressCnt :=0; aAddressLst :=''; aComIdx := aComID-1; (*if not (assigned(Comm[aComIdx])) then begin aMsg :='揹諳祥湔婓.'; exit; end;*) try with Comm[aComIdx] do begin Try hi:= High(AddressLst); Lo := Low(AddressLst); aAddressCnt := Hi-Lo+1; for i:=Lo to Hi do begin aAddressLst := aAddressLst + inttostr(AddressLst.AddressID)+ aDisChr; end; if trim(aAddressLst)<>'' then Delete(aAddressLst,length(aAddressLst),1); Except end; end; Result := true; Finally end;end;//Del AddressFunction TCommServer.DelAddress(aComID,aAddress:integer; var aMsg: string):Bool;var i,j,hi,Lo,aComIdx,Cnt,idx,p,Len: integer; CmdChr,buff : string; s: string; B : Boolean; aRecCardID: array[0..254] of TCardState; aRecGain1,aRecGain2,aRecRateidx,aRecAddress,aRecType: integer; aIsRecErr: Bool; aBackUpLst : array of TAddressInfo; aActive: boolean; aCnt,aoldCnt,aidx: integer;begin Result := false; aMsg:=''; aComIdx := aComID-1; Comm[aComIdx].isSetParaIng :=true; Timer.Enabled := false; while (Timer.Enabled) or (FIsRecing) do begin Timer.Enabled := false; end; try p := FindAddRessIdx(aComID,aAddress); if p=-1 then begin aMsg :='華硊: ' + inttostr(aAddress) + ' 祥湔婓.'; exit; end; with Comm[aComIdx] do begin Try try hi:= High(AddressLst); Lo := Low(AddressLst); aoldCnt := Hi -Lo +1; //aCnt := Hi-Lo+1 - (p+1) ; aCnt := Hi-p; //Hi-Lo+1 -1; Setlength(aBackUpLst,aCnt); aidx :=0; if aCnt>0 then begin for i:= p+1 to Hi do begin aBackUpLst[aidx].AddressID:= AddressLst.AddressID ; aBackUpLst[aidx].Gain1:= AddressLst.Gain1; aBackUpLst[aidx].Gain2:= AddressLst.Gain2 ; aBackUpLst[aidx].TypeID:= AddressLst.TypeID ; aBackUpLst[aidx].isSetParaIng:= AddressLst.isSetParaIng ; aBackUpLst[aidx].Active:= AddressLst.Active ; aBackUpLst[aidx].LastRecDt:= AddressLst.LastRecDt ; aBackUpLst[aidx].Sn:= AddressLst.Sn ; end; end; for i:= Lo to Hi do begin AddressLst.isSetParaIng := true; end; for i:= p to Hi-1 do begin AddressLst.AddressID:= AddressLst[i+1].AddressID ; AddressLst.Gain1:= AddressLst[i+1].Gain1; AddressLst.Gain2:= AddressLst[i+1].Gain2 ; AddressLst.TypeID:= AddressLst[i+1].TypeID ; AddressLst.isSetParaIng:= AddressLst[i+1].isSetParaIng ; AddressLst.Active:= AddressLst[i+1].Active ; AddressLst.LastRecDt:= AddressLst[i+1].LastRecDt ; AddressLst.Sn:= AddressLst[i+1].Sn ; end; Setlength(AddressLst,aoldCnt-1); hi:= High(AddressLst); Lo := Low(AddressLst); for i:= Lo to Hi do begin AddressLst.isSetParaIng := false; end; Except begin //Setlength(AddressLst,aCnt); exit; end; end; Finally end; end; Result := true; Finally begin Comm[aComIdx].isSetParaIng :=false; Timer.Enabled := true; end; end;end;//================Function addCRC(PreResult : Word; curChr : char) : Word;var curV : integer; idx : integer; temp : Word ;begin curV := byte(curChr); idx := (PreResult and 255) xor curV; Temp:=PreResult shr 8; Result := (Temp) xor CrcTbl[idx] ;end;//2005/1/9 黍佼唗蜊曹(迵菴珨唳炵苀祥肮)procedure WriteWord(V: word;idx : integer;var Buff : array of char); //word 2bytesvar p: PByte;begin try p := PByte(@V); buff[idx +1] := chr(p^); Inc(p); buff[idx+0] := chr(p^); Except // end;end;Procedure ConvByCRC(var CmdChr: String);var i,Len: integer; tmp : array[0..3] of char; FSumAsc: word; //虴桄鎢 s : string;begin Len := Length(CmdChr); FSumAsc:=0; For i:=2 to Len do begin FSumAsc := addCRC(FSumAsc,CmdChr); end; s := Format('%0x',[FSumAsc]); S := FormatStr(S,4,'0'); CmdChr := CmdChr + S + cnTail1[1]; Len := Length(CmdChr);end;//2005/1/9 黍佼唗蜊曹(迵菴珨唳炵苀祥肮)procedure WriteFloat(v : single;idx : integer;var Buff : array of char);//4 bytesvar i : integer; P: Pbyte; Temp : array[0..3] of Byte;begin try p := pbyte(@V); For i:=0 to 3 do begin Temp:=P^; inc(P); end; if (temp[0]=255) and (temp[0]=255) and (temp[0]=255) and (temp[0]=255) then For i:=0 to 3 do Temp:=0; Buff[idx]:=chr(Temp[3]); Buff[idx+1]:=chr(Temp[2]); Buff[idx+2]:=chr(Temp[1]); Buff[idx+3]:=chr(Temp[0]); Except // end;end;//2005/1/9 黍佼唗蜊曹(迵菴珨唳炵苀祥肮)Function ReadFloat(idx : integer;Buff : array of char):Single;//4 bytesvar Temp : array[0..3] of Byte; i : integer; P1,P2
byte;begin try For i:=0 to 3 do Temp:=Ord(Buff[idx+i]); if (temp[0]=127) or (temp[0]=255) then begin if (temp[1]>=128) and (temp[1]<=255) then begin Result :=0; Exit; end; end; P2:=Pbyte(@Result); p2^ :=Temp[3]; inc(p2); p2^ :=Temp[2]; inc(p2); p2^ :=Temp[1]; inc(p2); p2^ :=Temp[0]; Except Result:=0; end;end;function Readbyte(Idx : integer; Buff : array of char): byte;var Temp : Byte; p: PByte;begin try Temp:=ord(Buff[idx]); if not ((Temp>=0) and (Temp<=255)) then begin Result :=0; exit; end; p := PByte(@Result); p^ := Temp;; Except Result :=0; end;end;procedure WriteByte(V: byte;idx : integer; var Buff : array of char); //byte 1bytevar p: PByte;begin try p := PByte(@V); Buff[idx +0] := chr(p^); Except // end;end;//2005/1/9 黍佼唗蜊曹(迵菴珨唳炵苀祥肮)function ReadWord(Idx : integer; Buff : array of char): Word;var Temp : array[0..1] of Byte; p: PByte; i: integer;begin try For i:=0 to 1 do Temp:=Ord(Buff[idx+i]); p := PByte(@Result); p^ := Temp[1]; Inc(p); p^ := Temp[0]; Inc(p); Except Result :=0; end;end;//2005/1/9 黍佼唗蜊曹(迵菴珨唳炵苀祥肮)function ReadWordEx(Idx : integer; Buff : array of Byte): Word;var Temp : array[0..1] of Byte; p: PByte; i: integer;begin try p := PByte(@Result); p^ := Buff[idx+1]; Inc(p); p^ := Buff[idx]; Inc(p); Except Result :=0; end;end;//2005/1/9 黍佼唗蜊曹(迵菴珨唳炵苀祥肮)function ReadSmallint(Idx : integer; Buff : array of char): Smallint;var Temp : array[0..1] of Byte; p: PByte; i: integer;begin try For i:=0 to 1 do Temp:=Ord(Buff[idx+i]); p := PByte(@Result); p^ := Temp[1]; Inc(p); p^ := Temp[0]; Inc(p); Except Result :=0; end;end;//2005/1/9 黍佼唗蜊曹(迵菴珨唳炵苀祥肮)procedure WriteSmallint(V: Smallint;idx : integer;var Buff : array of char); //word 2bytesvar p: PByte;begin try p := PByte(@V); buff[idx +1] := chr(p^); Inc(p); buff[idx+0] := chr(p^); Except // end;end;Function ReadInteger(Idx: integer; Buff : array of char): integer;//Function ReadInteger(n: integer;T : array of char): integer;var Temp : array[0..3] of Byte; P: PByte; i: integer;begin try For i:=0 to 3 do Temp:=Ord(Buff[idx+i]); P:=PByte(@Result); if true then begin// 蚚黺等儂 p^ := Temp[0]; Inc(p); p^ := Temp[1]; Inc(p); p^ := Temp[2]; Inc(p); p^ := Temp[3]; end else begin //蚚黺萇齟 p^ := Temp[3]; Inc(p); p^ := Temp[2]; Inc(p); p^ := Temp[1]; Inc(p); p^ := Temp[0]; end; Except Result :=0; end; end;Function ReadIntegerEx(Idx: integer; Buff : array of byte): integer;//Function ReadInteger(n: integer;T : array of char): integer;var Temp : array[0..3] of Byte; P: PByte; i: integer;begin try //For i:=0 to 3 do // Temp:=Ord(Buff[idx+i]); P:=PByte(@Result); if NOT true then begin// 蚚黺等儂 p^ := Buff[idx]; Inc(p); p^ := Buff[idx+1]; Inc(p); p^ := Buff[idx+2]; Inc(p); p^ := Buff[idx+3]; end else begin //蚚黺萇齟 p^ := Buff[Idx+3]; Inc(p); p^ := Buff[Idx+2]; Inc(p); p^ := Buff[Idx+1]; Inc(p); p^ := Buff[Idx]; end; Except Result :=0; end; end;procedure WriteInteger(V: Integer;idx : integer; var Buff : array of char);//procedure WriteInteger(I: Integer;idx : integer;var B : array of char); //楷砃等儂integer 4bytesvar p: PByte; Temp : char;begin try p := PByte(@V); buff[Idx+0] := chr(p^); Inc(p); buff[Idx+1] := chr(p^); Inc(p); buff[Idx+2] := chr(p^); Inc(p); buff[Idx+3] := chr(p^); temp := buff[idx]; buff[idx] := buff[idx+3]; buff[idx+3] := Temp; temp := buff[idx+1]; buff[idx+1] := buff[idx+2]; buff[idx+2]:=temp; Except // end;end;function ReadInt64(n : integer; T : array of char):string; //蚳峈馱瘍begin Result :=''; try Result :=T[n]+T[n+1]+T[n+2]+T[n+3]+T[n+4]+T[n+5]+T[n+6]+T[n+7]; Except Result :=''; end;end;function ReadString(Len: Integer;idx : integer; T : array of char): string;var i: Integer;begin try SetLength(Result, Len); for i := 1 to Len do Result := T[idx+i-1]; Result := TrimRight(Result); Except Result :=''; end;end;function ReadStringEx(Len: Integer;idx : integer; T : array of Byte): string;var i: Integer;begin try SetLength(Result, Len); for i := 1 to Len do Result := char(T[idx+i-1]); Result := TrimRight(Result); Except Result :=''; end;end;Function ReadDateTime(n:integer;T: array of Char; DefaultDateTime:Tdatetime): Tdatetime;var mm,dd,hh,nn,ss: integer; y,m,d:word;begin try DecodeDate(now,y,m,d); mm := Readbyte(n,T); inc
; dd := Readbyte(n,T); inc; hh := Readbyte(n,T); inc; nn := Readbyte(n,T); inc; ss := Readbyte(n,T); inc; if (not (mm in [1..12])) or (not (dd in [1..31])) or (not (hh in [0..24])) or (not (nn in [0..60])) or (not (ss in [0..60])) then begin Result :=DefaultDateTime; Exit; end; Result := StrTodatetime(inttostr
+'/'+inttostr(mm) + '/' + inttostr(dd) +' ' + inttostr(hh) +':' + inttostr(nn) + ':' + inttostr(ss)); Except Result := DefaultDateTime; end;end;Function ReadDateTimeEx(n:integer;T: array of Char; DefaultDateTime:Tdatetime): Tdatetime;var yy,mm,dd,hh,nn,ss: integer;begin try yy := Readword(n,T); inc(n,2); mm := Readbyte(n,T); inc; dd := Readbyte(n,T); inc; hh := Readbyte(n,T); inc; nn := Readbyte(n,T); inc; ss := Readbyte(n,T); inc; if (not (mm in [1..12])) or (not (dd in [1..31])) or (not (hh in [0..24])) or (not (nn in [0..60])) or (not (ss in [0..60])) then begin Result :=DefaultDateTime; Exit; end; Result := StrTodatetime(inttostr(yy)+'/'+inttostr(mm) + '/' + inttostr(dd) +' ' + inttostr(hh) +':' + inttostr(nn) + ':' + inttostr(ss)); Except Result := DefaultDateTime; end;end;Procedure WriteDateTimeEx(curDatetime:Tdatetime; n:integer;var T: array of Char);var yy,mm,dd,hh,nn,ss,zzz: word;begin try DecodeDate(curDatetime,yy,mm,dd); DecodeTime(curDatetime,hh,nn,ss,zzz); WriteWord(yy,n,T); inc(n,2); writebyte(mm,n,T); inc; writebyte(dd,n,T); inc; writebyte(hh,n,T); inc; writebyte(nn,n,T); inc; writebyte(ss,n,T); inc; Except end;end;Procedure WriteDateTime(curDatetime:Tdatetime; n:integer;var T: array of Char);var yy,mm,dd,hh,nn,ss,zzz: word;begin try DecodeDate(curDatetime,yy,mm,dd); DecodeTime(curDatetime,hh,nn,ss,zzz); writebyte(mm,n,T); inc; writebyte(dd,n,T); inc; writebyte(hh,n,T); inc; writebyte(nn,n,T); inc; writebyte(ss,n,T); inc; Except end;end;procedure WriteInt64(I: int64;idx : integer;var b : array of char); //int64 4bytesvar p: PByte;begin try p := PByte(@I); b[Idx+0] := chr(p^); Inc(p); b[Idx+1] := chr(p^); Inc(p); b[Idx+2] := chr(p^); Inc(p); b[Idx+3] := chr(p^); Inc(p); b[Idx+4] := chr(p^); Inc(p); b[Idx+5] := chr(p^); Inc(p); b[Idx+6] := chr(p^); Inc(p); b[Idx+7] := chr(p^); Except // end;end;procedure WriteIntegerEx(I: Integer;idx : integer;var B : array of char); //楷砃萇齟integer 4bytesvar p: PByte;begin try p := PByte(@I); b[Idx+0] := chr(p^); Inc(p); b[Idx+1] := chr(p^); Inc(p); b[Idx+2] := chr(p^); Inc(p); b[Idx+3] := chr(p^); Except // end;end;procedure WriteString(s: String; Len: Integer;idx : integer;var B : array of char);//stringvar i: Integer;begin try if Length(s) < Len then s := s + StringOfChar(' ', Len-Length(s)); for i := 1 to Len do b[Idx+i-1] := s; Except // end;end;procedure Delay(const MilliSecond: LongWord);var aTime: LongWord;begin aTime := GetTickCount(); repeat Application.Processmessages; until(GetTickCount()-aTime>=MilliSecond);end;Function FormatStr(Str: string; Len: integer; FillChr:string):string;var i,j: integer;begin Result :=''; j := length(trim(str)); if j>len then begin Result := Copy(str,1,Len); end else begin for i:=1 to Len-j do Result := Result + FillChr; Result := Result + Str; end;end;Function IntToBin(value : Longint;Size : integer): string;var i : integer;begin result := ''; size := size -1; For i:= size downto 0 do begin if value and (1 shl i)<>0 then begin result := result + '1'; end else begin result := result +'0'; end; end ;end;Function BinToInt(value : string) : longint;var i ,size ,j: integer;begin result :=0 ; size := length(Value); j:= size; For i:=size downto 1 do begin j:= size-i; if copy(value,i,1)='1' then result := Result + (1 shl j); end;end;end.unit wiComm;interfaceuses Windows, SysUtils, Classes;type TwiComm = class(TComponent) private FPortHandle: THandle; FActive: boolean; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; property Handle: THandle read FPortHandle; procedure OpenPort( PortIndex: Word; BaudRate: integer; Parity: string; DataBit: Word; StopBit: Word); procedure ClosePort; procedure SetParity(const AParity: string); property Active: boolean read FActive; procedure SendBuffer(var buff: array of byte; Count: Integer); procedure SendString(const s: string); function ReceiveBuffer(var buff: array of byte;var BuffCount:integer; WillRecCount: Integer): Integer; //function ReceiveBuffer(var buff: array of word; Count: Integer): Integer; procedure ReceiveString(var s: String; var Count: Integer); function InBufferCount: Integer; procedure Flush; //Send out a command, immediately read response //--------------------------------------------- //s :command & response string. //Timeout :ms //StopChar :if receive the StopChar, stop loop //Return: // -1 :time out // >=0 :communicating time function ReceiveData(var s: string; Timeout: Longword; StopChar: char): Integer; //ReceiveData腔蜊輛唳 function ReceiveDataEx(var s: string; Timeout1, Timeout2: longword; StopChar: char): Integer; function ReceiveDataByBuff(var buff: array of byte; var buffCount:integer; AskRecCount:integer; Timeout: longword): Integer; function ReceiveDataByString(var Str:String; var StrCount:integer; AskRecCount:integer; Timeout: longword): Integer; //聆毀茼奀潔: 楷冞珨沭韜鍔ㄛ艘郔辦猁嗣屾奀潔衄毀茼﹝ //2002/11/21 function TestResponse(const s: string; Timeout: longword): Integer; //published // property ComHandle:THandle read hCommFile; end;function GetCheckSum(const data: String): Integer;function RemoveCheckSum(const InStr: String): String;//============================================================================//// IMPLEMENTATION ////============================================================================//implementation function GetCheckSum(const data: String): Integer; var i :integer; begin Result := 0; for i:=1 to length(data) do Result := (Result + ord(data)) and $FF; end; function RemoveCheckSum(const InStr: String): String; var data, ssum :string; begin Result := ''; if Length(InStr) > 2 then begin data := copy(InStr, 1, Length(InStr)-2); ssum := copy(InStr, Length(InStr)-1, 2); if GetCheckSum(data) = StrToIntDef('$'+ssum, -1) then Result := data; end; end;{ TwiComm }constructor TwiComm.Create(AOwner: TComponent);begin inherited Create(AOwner); FPortHandle := INVALID_HANDLE_VALUE; setupcomm(FPortHandle,4096,4096); FActive := false;end;destructor TwiComm.Destroy;begin ClosePort; inherited Destroy;end;//羲揹諳procedure TwiComm.OpenPort(PortIndex: Word; BaudRate: integer; Parity: string; DataBit: Word; StopBit: Word);var dcb :TDCB; {device control block }begin { close port if open already } ClosePort; FPortHandle := CreateFile(PChar('COM'+IntToStr(PortIndex)), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, LongInt(0)); { If created stream ok, set the baud rate and other parameters } if (FPortHandle <> INVALID_HANDLE_VALUE) then begin GetCommState(FPortHandle, dcb); //疏杻薹 case BaudRate of 300: dcb.BaudRate := CBR_300; 600: dcb.BaudRate := CBR_600; 1200: dcb.BaudRate := CBR_1200; 2400: dcb.BaudRate := CBR_2400; 4800: dcb.BaudRate := CBR_4800; 9600: dcb.BaudRate := CBR_9600; 19200: dcb.BaudRate := CBR_19200; 38400 : dcb.BaudRate := CBR_38400; 57600 : dcb.BaudRate := CBR_57600; 115200 : dcb.BaudRate := CBR_115200; else dcb.BaudRate := CBR_9600; end; //苺桄鎢 case Parity[1] of 'N': dcb.Parity := NOPARITY; 'O': dcb.Parity := ODDPARITY; 'E': dcb.Parity := EVENPARITY; 'M': dcb.Parity := MARKPARITY; 'S': dcb.Parity := SPACEPARITY; else dcb.Parity := NOPARITY; end; //杅擂弇 dcb.ByteSize := Byte(DataBit); //礿砦弇 case StopBit of 1: dcb.StopBits := ONESTOPBIT; 2: dcb.StopBits := TWOSTOPBITS; end; dcb.Flags := 0; //?? SetCommState(FPortHandle, dcb); end; { return True if handle is valid } FActive := (FPortHandle <> INVALID_HANDLE_VALUE);end;//壽敕揹諳procedure TwiComm.ClosePort;begin if FActive then begin CloseHandle(FPortHandle); FPortHandle := INVALID_HANDLE_VALUE; FActive := false; end;end;procedure TwiComm.SetParity(const AParity: string);var dcb: TDCB;begin if (FPortHandle <> INVALID_HANDLE_VALUE) then begin GetCommState(FPortHandle, dcb); case AParity[1] of 'N': dcb.Parity := NOPARITY; 'O': dcb.Parity := ODDPARITY; 'E': dcb.Parity := EVENPARITY; 'M': dcb.Parity := MARKPARITY; 'S': dcb.Parity := SPACEPARITY; else dcb.Parity := NOPARITY; end; SetCommState(FPortHandle, dcb); end;end;{Send Buffer}procedure TwiComm.SendBuffer(var buff: array of byte; Count: Integer);var BytesWritten: DWord;begin if FActive then try WriteFile(FPortHandle, buff, Count, BytesWritten, nil); except end;end;(*var statPort :TCOMSTAT; dwErrorCode 
Word;begin Result := 0; if FActive then begin ClearCommError(FPortHandle, dwErrorCode, @statPort); Result := statPort.cbInQue; end;*){Send String}procedure TwiComm.SendString(const s: string);var BytesWritten: DWord; outCnt: integer; str : string; statPort :TCOMSTAT; dwErrorCode Word;begin if FActive and (s <> '') then begin ClearCommError(FPortHandle, dwErrorCode, @statPort); outCnt := statPort.cbOutQue; str := inttostr(outCnt); try WriteFile(FPortHandle, pchar(s)^, length(s), BytesWritten, nil); except end; outCnt := statPort.cbOutQue; str := inttostr(outCnt); end;end;{Receive buffer, return bytes being read}function TwiComm.ReceiveBuffer(var buff: array of byte; var BuffCount:integer; WillRecCount: Integer): Integer;var BytesRead Word; str : string;begin Result := 0; if not FActive then exit; BuffCount := InBufferCount(); if BuffCount > 0 then begin //in-buffer must has data //how many bytes to read if WillRecCount = 0 then WillRecCount := BuffCount; if WillRecCount > BuffCount then WillRecCount := BuffCount; //SetLength(buff, Count); //allocate space try ReadFile(FPortHandle, buff, WillRecCount, BytesRead, nil); Result := BytesRead; except end; end;end;// add by me2003/4/21{function TwiComm.ReceiveBuffer(var buff: array of word; Count: Integer): Integer;var BuffCount :Integer; BytesRead Word;begin Result := 0; if not FActive then exit; BuffCount := InBufferCount(); if BuffCount > 0 then //in-buffer must has data begin //how many bytes to read if Count = 0 then Count := BuffCount; if Count > BuffCount then Count := BuffCount; //SetLength(buff, Count); //allocate space try ReadFile(FPortHandle, buff, Count, BytesRead, nil); Result := BytesRead; except end; end;end; }{Receive string}//if Count is 0, means read allprocedure TwiComm.ReceiveString(var s: String; var Count: Integer);var BuffCount :Integer; BytesRead Word;begin s := ''; if not FActive then exit; BuffCount := InBufferCount(); if BuffCount > 0 then //in-buffer must has data begin //how many bytes to read if Count = 0 then Count := BuffCount; if Count > BuffCount then Count := BuffCount; SetLength(s, Count); //allocate space try ReadFile(FPortHandle, PChar(s)^, Count, BytesRead, nil); SetLength(s, BytesRead); //adjust length except s := ''; end; end;end;//怀遣喳趼誹杅function TwiComm.InBufferCount: Integer;var statPort :TCOMSTAT; dwErrorCode Word;begin Result := 0; if FActive then begin ClearCommError(FPortHandle, dwErrorCode, @statPort); Result := statPort.cbInQue; end;end;//諾遣喳procedure TwiComm.Flush;begin if FPortHandle <> INVALID_HANDLE_VALUE then begin PurgeComm(FPortHandle, PURGE_TXABORT or PURGE_RXABORT or PURGE_TXCLEAR or PURGE_RXCLEAR); end;end;//Send out a command, immediately read response//Return:// -1 : time out// >=0 : communicating timefunction TwiComm.ReceiveData(var s: string; Timeout: longword; StopChar: char): Integer;var st: longword; rs: string; recCnt: integer;begin Result := -1; //assume timeout //start time before sending (old) //st := gettickcount; //send Flush; SendString(s); //start time after sending (New!) st := gettickcount; //receive s := ''; repeat recCnt :=0; ReceiveString(rs, recCnt); if rs <> '' then if pos(StopChar, rs) = 0 then s := s + rs else begin delete(rs, pos(StopChar, rs), 999); s := s + rs; Result := gettickcount-st; //ok, return time break; end; until gettickcount >= st + Timeout;end;//聆毀茼奀潔: 楷冞珨沭韜鍔ㄛ艘郔辦猁嗣屾奀潔衄毀茼﹝//Return:// -1 : time out// >=0 : response timefunction TwiComm.TestResponse(const s: string; Timeout: longword): Integer;var st: longword;begin Result := -1; //assume timeout //send Flush; SendString(s); //start time st := gettickcount; //receive repeat if InBufferCount() > 0 then begin Result := gettickcount-st; //ok, return time break; end; until gettickcount >= st + Timeout;end;// ReceiveData腔蜊輛唳// 婓Timeout1奀潔囀羶衄隙茼ㄛ蕾撈溫function TwiComm.ReceiveDataEx(var s: string; Timeout1, Timeout2: longword; StopChar: char): Integer;var st: longword; rs: string; RecCnt: integer;begin Result := -1; //assume timeout Flush; SendString(s); //send s := ''; //clear receive //wait for response st := gettickcount; repeat until (InBufferCount() > 0) or (gettickcount >= st + Timeout1); if InBufferCount() = 0 then exit; //receive repeat RecCnt :=0; ReceiveString(rs, RecCnt); if rs <> '' then if pos(StopChar, rs) = 0 then s := s + rs else begin delete(rs, pos(StopChar, rs), 999); s := s + rs; Result := gettickcount-st; //ok, return time break; end; until gettickcount >= st + Timeout2;end;// ReceiveData腔蜊輛唳// 婓Timeout1奀潔囀羶衄隙茼ㄛ蕾撈溫function TwiComm.ReceiveDataByBuff(var buff: array of byte; var buffCount:integer; AskRecCount:integer; Timeout: longword): Integer;var st: longword; hi,Lo : integer; rs: string; str: string;begin Result := -1; //assume timeout Flush; Sendbuffer(buff,buffcount); //send hi :=high(buff); lo := low(buff); Fillchar(buff,hi-lo+1,0); //clear receive //wait for response st := gettickcount; repeat until (InBufferCount() >= AskRecCount) or (gettickcount >= st + Timeout); if InBufferCount() = 0 then begin str :=inttostr(st); exit; end; //receive Result := ReceiveBuffer(buff,buffCount,0);end;function TwiComm.ReceiveDataByString(var Str:String; var StrCount:integer; AskRecCount:integer; Timeout: longword): Integer;var st: longword; hi,Lo : integer; rs: string;begin Result := -1; //assume timeout Flush; SendString(str); Str :=''; //wait for response st := gettickcount; repeat until (InBufferCount() >= AskRecCount) or (gettickcount >= st + Timeout); if InBufferCount() = 0 then begin //str :=inttostr(st); exit; end; //receive StrCount:=0; ReceiveString(str,StrCount); Result := StrCount; end;end.
byte;begin try For i:=0 to 3 do Temp:=Ord(Buff[idx+i]); if (temp[0]=127) or (temp[0]=255) then begin if (temp[1]>=128) and (temp[1]<=255) then begin Result :=0; Exit; end; end; P2:=Pbyte(@Result); p2^ :=Temp[3]; inc(p2); p2^ :=Temp[2]; inc(p2); p2^ :=Temp[1]; inc(p2); p2^ :=Temp[0]; Except Result:=0; end;end;function Readbyte(Idx : integer; Buff : array of char): byte;var Temp : Byte; p: PByte;begin try Temp:=ord(Buff[idx]); if not ((Temp>=0) and (Temp<=255)) then begin Result :=0; exit; end; p := PByte(@Result); p^ := Temp;; Except Result :=0; end;end;procedure WriteByte(V: byte;idx : integer; var Buff : array of char); //byte 1bytevar p: PByte;begin try p := PByte(@V); Buff[idx +0] := chr(p^); Except // end;end;//2005/1/9 黍佼唗蜊曹(迵菴珨唳炵苀祥肮)function ReadWord(Idx : integer; Buff : array of char): Word;var Temp : array[0..1] of Byte; p: PByte; i: integer;begin try For i:=0 to 1 do Temp:=Ord(Buff[idx+i]); p := PByte(@Result); p^ := Temp[1]; Inc(p); p^ := Temp[0]; Inc(p); Except Result :=0; end;end;//2005/1/9 黍佼唗蜊曹(迵菴珨唳炵苀祥肮)function ReadWordEx(Idx : integer; Buff : array of Byte): Word;var Temp : array[0..1] of Byte; p: PByte; i: integer;begin try p := PByte(@Result); p^ := Buff[idx+1]; Inc(p); p^ := Buff[idx]; Inc(p); Except Result :=0; end;end;//2005/1/9 黍佼唗蜊曹(迵菴珨唳炵苀祥肮)function ReadSmallint(Idx : integer; Buff : array of char): Smallint;var Temp : array[0..1] of Byte; p: PByte; i: integer;begin try For i:=0 to 1 do Temp:=Ord(Buff[idx+i]); p := PByte(@Result); p^ := Temp[1]; Inc(p); p^ := Temp[0]; Inc(p); Except Result :=0; end;end;//2005/1/9 黍佼唗蜊曹(迵菴珨唳炵苀祥肮)procedure WriteSmallint(V: Smallint;idx : integer;var Buff : array of char); //word 2bytesvar p: PByte;begin try p := PByte(@V); buff[idx +1] := chr(p^); Inc(p); buff[idx+0] := chr(p^); Except // end;end;Function ReadInteger(Idx: integer; Buff : array of char): integer;//Function ReadInteger(n: integer;T : array of char): integer;var Temp : array[0..3] of Byte; P: PByte; i: integer;begin try For i:=0 to 3 do Temp:=Ord(Buff[idx+i]); P:=PByte(@Result); if true then begin// 蚚黺等儂 p^ := Temp[0]; Inc(p); p^ := Temp[1]; Inc(p); p^ := Temp[2]; Inc(p); p^ := Temp[3]; end else begin //蚚黺萇齟 p^ := Temp[3]; Inc(p); p^ := Temp[2]; Inc(p); p^ := Temp[1]; Inc(p); p^ := Temp[0]; end; Except Result :=0; end; end;Function ReadIntegerEx(Idx: integer; Buff : array of byte): integer;//Function ReadInteger(n: integer;T : array of char): integer;var Temp : array[0..3] of Byte; P: PByte; i: integer;begin try //For i:=0 to 3 do // Temp:=Ord(Buff[idx+i]); P:=PByte(@Result); if NOT true then begin// 蚚黺等儂 p^ := Buff[idx]; Inc(p); p^ := Buff[idx+1]; Inc(p); p^ := Buff[idx+2]; Inc(p); p^ := Buff[idx+3]; end else begin //蚚黺萇齟 p^ := Buff[Idx+3]; Inc(p); p^ := Buff[Idx+2]; Inc(p); p^ := Buff[Idx+1]; Inc(p); p^ := Buff[Idx]; end; Except Result :=0; end; end;procedure WriteInteger(V: Integer;idx : integer; var Buff : array of char);//procedure WriteInteger(I: Integer;idx : integer;var B : array of char); //楷砃等儂integer 4bytesvar p: PByte; Temp : char;begin try p := PByte(@V); buff[Idx+0] := chr(p^); Inc(p); buff[Idx+1] := chr(p^); Inc(p); buff[Idx+2] := chr(p^); Inc(p); buff[Idx+3] := chr(p^); temp := buff[idx]; buff[idx] := buff[idx+3]; buff[idx+3] := Temp; temp := buff[idx+1]; buff[idx+1] := buff[idx+2]; buff[idx+2]:=temp; Except // end;end;function ReadInt64(n : integer; T : array of char):string; //蚳峈馱瘍begin Result :=''; try Result :=T[n]+T[n+1]+T[n+2]+T[n+3]+T[n+4]+T[n+5]+T[n+6]+T[n+7]; Except Result :=''; end;end;function ReadString(Len: Integer;idx : integer; T : array of char): string;var i: Integer;begin try SetLength(Result, Len); for i := 1 to Len do Result := T[idx+i-1]; Result := TrimRight(Result); Except Result :=''; end;end;function ReadStringEx(Len: Integer;idx : integer; T : array of Byte): string;var i: Integer;begin try SetLength(Result, Len); for i := 1 to Len do Result := char(T[idx+i-1]); Result := TrimRight(Result); Except Result :=''; end;end;Function ReadDateTime(n:integer;T: array of Char; DefaultDateTime:Tdatetime): Tdatetime;var mm,dd,hh,nn,ss: integer; y,m,d:word;begin try DecodeDate(now,y,m,d); mm := Readbyte(n,T); inc; dd := Readbyte(n,T); inc; hh := Readbyte(n,T); inc; nn := Readbyte(n,T); inc; ss := Readbyte(n,T); inc; if (not (mm in [1..12])) or (not (dd in [1..31])) or (not (hh in [0..24])) or (not (nn in [0..60])) or (not (ss in [0..60])) then begin Result :=DefaultDateTime; Exit; end; Result := StrTodatetime(inttostr+'/'+inttostr(mm) + '/' + inttostr(dd) +' ' + inttostr(hh) +':' + inttostr(nn) + ':' + inttostr(ss)); Except Result := DefaultDateTime; end;end;Function ReadDateTimeEx(n:integer;T: array of Char; DefaultDateTime:Tdatetime): Tdatetime;var yy,mm,dd,hh,nn,ss: integer;begin try yy := Readword(n,T); inc(n,2); mm := Readbyte(n,T); inc; dd := Readbyte(n,T); inc; hh := Readbyte(n,T); inc; nn := Readbyte(n,T); inc; ss := Readbyte(n,T); inc; if (not (mm in [1..12])) or (not (dd in [1..31])) or (not (hh in [0..24])) or (not (nn in [0..60])) or (not (ss in [0..60])) then begin Result :=DefaultDateTime; Exit; end; Result := StrTodatetime(inttostr(yy)+'/'+inttostr(mm) + '/' + inttostr(dd) +' ' + inttostr(hh) +':' + inttostr(nn) + ':' + inttostr(ss)); Except Result := DefaultDateTime; end;end;Procedure WriteDateTimeEx(curDatetime:Tdatetime; n:integer;var T: array of Char);var yy,mm,dd,hh,nn,ss,zzz: word;begin try DecodeDate(curDatetime,yy,mm,dd); DecodeTime(curDatetime,hh,nn,ss,zzz); WriteWord(yy,n,T); inc(n,2); writebyte(mm,n,T); inc; writebyte(dd,n,T); inc; writebyte(hh,n,T); inc; writebyte(nn,n,T); inc; writebyte(ss,n,T); inc; Except end;end;Procedure WriteDateTime(curDatetime:Tdatetime; n:integer;var T: array of Char);var yy,mm,dd,hh,nn,ss,zzz: word;begin try DecodeDate(curDatetime,yy,mm,dd); DecodeTime(curDatetime,hh,nn,ss,zzz); writebyte(mm,n,T); inc; writebyte(dd,n,T); inc; writebyte(hh,n,T); inc; writebyte(nn,n,T); inc; writebyte(ss,n,T); inc; Except end;end;procedure WriteInt64(I: int64;idx : integer;var b : array of char); //int64 4bytesvar p: PByte;begin try p := PByte(@I); b[Idx+0] := chr(p^); Inc(p); b[Idx+1] := chr(p^); Inc(p); b[Idx+2] := chr(p^); Inc(p); b[Idx+3] := chr(p^); Inc(p); b[Idx+4] := chr(p^); Inc(p); b[Idx+5] := chr(p^); Inc(p); b[Idx+6] := chr(p^); Inc(p); b[Idx+7] := chr(p^); Except // end;end;procedure WriteIntegerEx(I: Integer;idx : integer;var B : array of char); //楷砃萇齟integer 4bytesvar p: PByte;begin try p := PByte(@I); b[Idx+0] := chr(p^); Inc(p); b[Idx+1] := chr(p^); Inc(p); b[Idx+2] := chr(p^); Inc(p); b[Idx+3] := chr(p^); Except // end;end;procedure WriteString(s: String; Len: Integer;idx : integer;var B : array of char);//stringvar i: Integer;begin try if Length(s) < Len then s := s + StringOfChar(' ', Len-Length(s)); for i := 1 to Len do b[Idx+i-1] := s; Except // end;end;procedure Delay(const MilliSecond: LongWord);var aTime: LongWord;begin aTime := GetTickCount(); repeat Application.Processmessages; until(GetTickCount()-aTime>=MilliSecond);end;Function FormatStr(Str: string; Len: integer; FillChr:string):string;var i,j: integer;begin Result :=''; j := length(trim(str)); if j>len then begin Result := Copy(str,1,Len); end else begin for i:=1 to Len-j do Result := Result + FillChr; Result := Result + Str; end;end;Function IntToBin(value : Longint;Size : integer): string;var i : integer;begin result := ''; size := size -1; For i:= size downto 0 do begin if value and (1 shl i)<>0 then begin result := result + '1'; end else begin result := result +'0'; end; end ;end;Function BinToInt(value : string) : longint;var i ,size ,j: integer;begin result :=0 ; size := length(Value); j:= size; For i:=size downto 1 do begin j:= size-i; if copy(value,i,1)='1' then result := Result + (1 shl j); end;end;end.unit wiComm;interfaceuses Windows, SysUtils, Classes;type TwiComm = class(TComponent) private FPortHandle: THandle; FActive: boolean; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; property Handle: THandle read FPortHandle; procedure OpenPort( PortIndex: Word; BaudRate: integer; Parity: string; DataBit: Word; StopBit: Word); procedure ClosePort; procedure SetParity(const AParity: string); property Active: boolean read FActive; procedure SendBuffer(var buff: array of byte; Count: Integer); procedure SendString(const s: string); function ReceiveBuffer(var buff: array of byte;var BuffCount:integer; WillRecCount: Integer): Integer; //function ReceiveBuffer(var buff: array of word; Count: Integer): Integer; procedure ReceiveString(var s: String; var Count: Integer); function InBufferCount: Integer; procedure Flush; //Send out a command, immediately read response //--------------------------------------------- //s :command & response string. //Timeout :ms //StopChar :if receive the StopChar, stop loop //Return: // -1 :time out // >=0 :communicating time function ReceiveData(var s: string; Timeout: Longword; StopChar: char): Integer; //ReceiveData腔蜊輛唳 function ReceiveDataEx(var s: string; Timeout1, Timeout2: longword; StopChar: char): Integer; function ReceiveDataByBuff(var buff: array of byte; var buffCount:integer; AskRecCount:integer; Timeout: longword): Integer; function ReceiveDataByString(var Str:String; var StrCount:integer; AskRecCount:integer; Timeout: longword): Integer; //聆毀茼奀潔: 楷冞珨沭韜鍔ㄛ艘郔辦猁嗣屾奀潔衄毀茼﹝ //2002/11/21 function TestResponse(const s: string; Timeout: longword): Integer; //published // property ComHandle:THandle read hCommFile; end;function GetCheckSum(const data: String): Integer;function RemoveCheckSum(const InStr: String): String;//============================================================================//// IMPLEMENTATION ////============================================================================//implementation function GetCheckSum(const data: String): Integer; var i :integer; begin Result := 0; for i:=1 to length(data) do Result := (Result + ord(data)) and $FF; end; function RemoveCheckSum(const InStr: String): String; var data, ssum :string; begin Result := ''; if Length(InStr) > 2 then begin data := copy(InStr, 1, Length(InStr)-2); ssum := copy(InStr, Length(InStr)-1, 2); if GetCheckSum(data) = StrToIntDef('$'+ssum, -1) then Result := data; end; end;{ TwiComm }constructor TwiComm.Create(AOwner: TComponent);begin inherited Create(AOwner); FPortHandle := INVALID_HANDLE_VALUE; setupcomm(FPortHandle,4096,4096); FActive := false;end;destructor TwiComm.Destroy;begin ClosePort; inherited Destroy;end;//羲揹諳procedure TwiComm.OpenPort(PortIndex: Word; BaudRate: integer; Parity: string; DataBit: Word; StopBit: Word);var dcb :TDCB; {device control block }begin { close port if open already } ClosePort; FPortHandle := CreateFile(PChar('COM'+IntToStr(PortIndex)), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, LongInt(0)); { If created stream ok, set the baud rate and other parameters } if (FPortHandle <> INVALID_HANDLE_VALUE) then begin GetCommState(FPortHandle, dcb); //疏杻薹 case BaudRate of 300: dcb.BaudRate := CBR_300; 600: dcb.BaudRate := CBR_600; 1200: dcb.BaudRate := CBR_1200; 2400: dcb.BaudRate := CBR_2400; 4800: dcb.BaudRate := CBR_4800; 9600: dcb.BaudRate := CBR_9600; 19200: dcb.BaudRate := CBR_19200; 38400 : dcb.BaudRate := CBR_38400; 57600 : dcb.BaudRate := CBR_57600; 115200 : dcb.BaudRate := CBR_115200; else dcb.BaudRate := CBR_9600; end; //苺桄鎢 case Parity[1] of 'N': dcb.Parity := NOPARITY; 'O': dcb.Parity := ODDPARITY; 'E': dcb.Parity := EVENPARITY; 'M': dcb.Parity := MARKPARITY; 'S': dcb.Parity := SPACEPARITY; else dcb.Parity := NOPARITY; end; //杅擂弇 dcb.ByteSize := Byte(DataBit); //礿砦弇 case StopBit of 1: dcb.StopBits := ONESTOPBIT; 2: dcb.StopBits := TWOSTOPBITS; end; dcb.Flags := 0; //?? SetCommState(FPortHandle, dcb); end; { return True if handle is valid } FActive := (FPortHandle <> INVALID_HANDLE_VALUE);end;//壽敕揹諳procedure TwiComm.ClosePort;begin if FActive then begin CloseHandle(FPortHandle); FPortHandle := INVALID_HANDLE_VALUE; FActive := false; end;end;procedure TwiComm.SetParity(const AParity: string);var dcb: TDCB;begin if (FPortHandle <> INVALID_HANDLE_VALUE) then begin GetCommState(FPortHandle, dcb); case AParity[1] of 'N': dcb.Parity := NOPARITY; 'O': dcb.Parity := ODDPARITY; 'E': dcb.Parity := EVENPARITY; 'M': dcb.Parity := MARKPARITY; 'S': dcb.Parity := SPACEPARITY; else dcb.Parity := NOPARITY; end; SetCommState(FPortHandle, dcb); end;end;{Send Buffer}procedure TwiComm.SendBuffer(var buff: array of byte; Count: Integer);var BytesWritten: DWord;begin if FActive then try WriteFile(FPortHandle, buff, Count, BytesWritten, nil); except end;end;(*var statPort :TCOMSTAT; dwErrorCode Word;begin Result := 0; if FActive then begin ClearCommError(FPortHandle, dwErrorCode, @statPort); Result := statPort.cbInQue; end;*){Send String}procedure TwiComm.SendString(const s: string);var BytesWritten: DWord; outCnt: integer; str : string; statPort :TCOMSTAT; dwErrorCode Word;begin if FActive and (s <> '') then begin ClearCommError(FPortHandle, dwErrorCode, @statPort); outCnt := statPort.cbOutQue; str := inttostr(outCnt); try WriteFile(FPortHandle, pchar(s)^, length(s), BytesWritten, nil); except end; outCnt := statPort.cbOutQue; str := inttostr(outCnt); end;end;{Receive buffer, return bytes being read}function TwiComm.ReceiveBuffer(var buff: array of byte; var BuffCount:integer; WillRecCount: Integer): Integer;var BytesRead Word; str : string;begin Result := 0; if not FActive then exit; BuffCount := InBufferCount(); if BuffCount > 0 then begin //in-buffer must has data //how many bytes to read if WillRecCount = 0 then WillRecCount := BuffCount; if WillRecCount > BuffCount then WillRecCount := BuffCount; //SetLength(buff, Count); //allocate space try ReadFile(FPortHandle, buff, WillRecCount, BytesRead, nil); Result := BytesRead; except end; end;end;// add by me2003/4/21{function TwiComm.ReceiveBuffer(var buff: array of word; Count: Integer): Integer;var BuffCount :Integer; BytesRead Word;begin Result := 0; if not FActive then exit; BuffCount := InBufferCount(); if BuffCount > 0 then //in-buffer must has data begin //how many bytes to read if Count = 0 then Count := BuffCount; if Count > BuffCount then Count := BuffCount; //SetLength(buff, Count); //allocate space try ReadFile(FPortHandle, buff, Count, BytesRead, nil); Result := BytesRead; except end; end;end; }{Receive string}//if Count is 0, means read allprocedure TwiComm.ReceiveString(var s: String; var Count: Integer);var BuffCount :Integer; BytesRead Word;begin s := ''; if not FActive then exit; BuffCount := InBufferCount(); if BuffCount > 0 then //in-buffer must has data begin //how many bytes to read if Count = 0 then Count := BuffCount; if Count > BuffCount then Count := BuffCount; SetLength(s, Count); //allocate space try ReadFile(FPortHandle, PChar(s)^, Count, BytesRead, nil); SetLength(s, BytesRead); //adjust length except s := ''; end; end;end;//怀遣喳趼誹杅function TwiComm.InBufferCount: Integer;var statPort :TCOMSTAT; dwErrorCode Word;begin Result := 0; if FActive then begin ClearCommError(FPortHandle, dwErrorCode, @statPort); Result := statPort.cbInQue; end;end;//諾遣喳procedure TwiComm.Flush;begin if FPortHandle <> INVALID_HANDLE_VALUE then begin PurgeComm(FPortHandle, PURGE_TXABORT or PURGE_RXABORT or PURGE_TXCLEAR or PURGE_RXCLEAR); end;end;//Send out a command, immediately read response//Return:// -1 : time out// >=0 : communicating timefunction TwiComm.ReceiveData(var s: string; Timeout: longword; StopChar: char): Integer;var st: longword; rs: string; recCnt: integer;begin Result := -1; //assume timeout //start time before sending (old) //st := gettickcount; //send Flush; SendString(s); //start time after sending (New!) st := gettickcount; //receive s := ''; repeat recCnt :=0; ReceiveString(rs, recCnt); if rs <> '' then if pos(StopChar, rs) = 0 then s := s + rs else begin delete(rs, pos(StopChar, rs), 999); s := s + rs; Result := gettickcount-st; //ok, return time break; end; until gettickcount >= st + Timeout;end;//聆毀茼奀潔: 楷冞珨沭韜鍔ㄛ艘郔辦猁嗣屾奀潔衄毀茼﹝//Return:// -1 : time out// >=0 : response timefunction TwiComm.TestResponse(const s: string; Timeout: longword): Integer;var st: longword;begin Result := -1; //assume timeout //send Flush; SendString(s); //start time st := gettickcount; //receive repeat if InBufferCount() > 0 then begin Result := gettickcount-st; //ok, return time break; end; until gettickcount >= st + Timeout;end;// ReceiveData腔蜊輛唳// 婓Timeout1奀潔囀羶衄隙茼ㄛ蕾撈溫function TwiComm.ReceiveDataEx(var s: string; Timeout1, Timeout2: longword; StopChar: char): Integer;var st: longword; rs: string; RecCnt: integer;begin Result := -1; //assume timeout Flush; SendString(s); //send s := ''; //clear receive //wait for response st := gettickcount; repeat until (InBufferCount() > 0) or (gettickcount >= st + Timeout1); if InBufferCount() = 0 then exit; //receive repeat RecCnt :=0; ReceiveString(rs, RecCnt); if rs <> '' then if pos(StopChar, rs) = 0 then s := s + rs else begin delete(rs, pos(StopChar, rs), 999); s := s + rs; Result := gettickcount-st; //ok, return time break; end; until gettickcount >= st + Timeout2;end;// ReceiveData腔蜊輛唳// 婓Timeout1奀潔囀羶衄隙茼ㄛ蕾撈溫function TwiComm.ReceiveDataByBuff(var buff: array of byte; var buffCount:integer; AskRecCount:integer; Timeout: longword): Integer;var st: longword; hi,Lo : integer; rs: string; str: string;begin Result := -1; //assume timeout Flush; Sendbuffer(buff,buffcount); //send hi :=high(buff); lo := low(buff); Fillchar(buff,hi-lo+1,0); //clear receive //wait for response st := gettickcount; repeat until (InBufferCount() >= AskRecCount) or (gettickcount >= st + Timeout); if InBufferCount() = 0 then begin str :=inttostr(st); exit; end; //receive Result := ReceiveBuffer(buff,buffCount,0);end;function TwiComm.ReceiveDataByString(var Str:String; var StrCount:integer; AskRecCount:integer; Timeout: longword): Integer;var st: longword; hi,Lo : integer; rs: string;begin Result := -1; //assume timeout Flush; SendString(str); Str :=''; //wait for response st := gettickcount; repeat until (InBufferCount() >= AskRecCount) or (gettickcount >= st + Timeout); if InBufferCount() = 0 then begin //str :=inttostr(st); exit; end; //receive StrCount:=0; ReceiveString(str,StrCount); Result := StrCount; end;end.