unit PTCom232;
{
设计：张世平
时间:2005-6-24
注意:需要Config232.ini文件配合
全双工-内存数据库通讯
}
interface
uses
StrUtils,
Classes,
windows,
Dialogs,
WinSock,
ScktComp,
IniFiles,
SysUtils,
ExtCtrls,
SPComm,
GlobalDefine;
resourcestring
StatusDateTimeFormat = 'yyyy/mm/dd" - "hh:nn:ss:zzz AM/PM';
type
TCFG = record
CommName: pchar;
BaudRate: integer;
ByteSize: pchar;
StopBits: pchar;
Parity: pchar;
NeedWriteLog: integer;
end;
PMyPobject = ^MyPobject;
MyPobject = record
Msg: PByte;
Len: Integer
end;
TCom232 = class
private
AComm: TComm;
TimerSend: TTimer; //如果com232 通，并且发送队列有数据，则发送
procedure TimerSendTimer(Sender: tobject);
procedure CommReceiveData(Sender: TObject; Buffer: Pointer; BufferLength: Word);
procedure CommReceiveError(Sender: TObject; EventMask: Cardinal);
function LoadUDPParameter(): BOOLEAN;
function SetUDPParameter(): BOOLEAN;
public
constructor Create();
destructor DESTROY; override;
function Open(): boolean;
function Execute(): BOOLEAN;
procedure WriteLog(ErrStr: string);
end;
function FreeBuf(Buffer: PTThreadList): Boolean;
function ReadFromBuf(var MyObject: PMyPobject; var
Buffer: PTThreadList): Boolean;
function HaveData(Buffer: PTThreadList): Boolean;
function WriteToBuf(var MyObject: PMyPobject; var
Buffer: PTThreadList; Capacity: Integer): Boolean;
procedure Log(LogFilename: string; ErrStr: string);
procedure SendLog(ErrStr: string);
procedure RecLog(ErrStr: string);
procedure HexStrToBytes(hHexStr: string; pbyteArray: Pointer);
procedure BytesToHexStr(var hHexStr: string; pbyteArray: PByte; InputLength: WORD);
const
iCapacity = 1024;
CONFIG = 'CONFIG232.INI';
SelfLog = 'log_232.Log';
SendDataQueue_log = 'log_232_send.log';
ReceiveDataQueue_Log = 'log_232_Rec.log';
var SendDataQueue: PTThreadList; //待发送数据队列
ReceiveDataQueue: PTThreadList; //接收数据
CurPath: string;
CFG: TCFG;
implementation
procedure HexStrToBytes(hHexStr: string; pbyteArray: Pointer);
{pbyteArray must point to enough memory to hold the output}
var
i, j: WORD;
tempPtr: PChar;
twoDigits: string[2];
begin
tempPtr := pbyteArray;
j := 1;
for i := 1 to (Length(hHexStr) div 2) do begin
twoDigits := Copy(hHexStr, j, 2);
Inc(j, 2);
PByte(tempPtr)^ := StrToInt('$' + twoDigits);
Inc(tempPtr);
end; {for}
if ((Length(hHexStr) mod 2) = 1) then
begin
twoDigits := '0' + RightStr(hHexStr, 1);
Inc(j, 2);
PByte(tempPtr)^ := StrToInt('$' + twoDigits);
end;
end;
procedure BytesToHexStr(var hHexStr: string; pbyteArray: PByte; InputLength: WORD);
const
HexChars: array[0..15] of Char = '0123456789ABCDEF';
var
i, j: WORD;
begin
hHexStr := '';
j := 1;
for i := 1 to InputLength do begin
hHexStr := hHexStr + Char(HexChars[pbyteArray^ shr 4]);
inc(j);
hHexStr := hHexStr + Char(HexChars[pbyteArray^ and 15]);
inc(j);
inc(pbyteArray);
end;
end;
procedure Log(LogFilename: string; ErrStr: string);
var
LogFile: TextFile;
begin
if CFG.NeedWriteLog <> 1 then exit;
AssignFile(LogFile, LogFilename);
if FileExists(LogFilename) then Append(LogFile)
else Rewrite(LogFile);
Writeln(LogFile, ErrStr);
CloseFile(LogFile);
end;
procedure TCom232.WriteLog(ErrStr: string);
begin
LOG(CurPath + selflog, DateTimeToStr(now) + ': ' + ErrStr);
end;
procedure SendLog(ErrStr: string);
begin
LOG(CurPath + SendDataQueue_log, ErrStr);
end;
procedure RecLog(ErrStr: string);
begin
LOG(CurPath + ReceiveDataQueue_Log, ErrStr);
end;
function GETINIkey(IniFile: pchar; MAINKEY: pchar; SUBKEY: pchar): pchar; stdcall; //export;
var
myini: Tinifile;
s: string;
begin
// curpath:=extractfilepath(Application.exename);
myini := Tinifile.Create(IniFile);
// result := PCHAR(Myini.readString(mainkey, subkey, ''));
s := myini.readString(MAINKEY, SUBKEY, '');
getmem(result, length(s) + 1);
strcopy(result, pchar(s));
myini.Free;
end;
constructor TCom232.Create();
begin
if not LoadUDPParameter() then EXIT;
New(SendDataQueue);
SendDataQueue^ := TThreadList.Create;
New(ReceiveDataQueue);
ReceiveDataQueue^ := TThreadList.create;
TimerSend := TTimer.Create(nil); //
TimerSend.Enabled := false;
TimerSend.Interval := 1; //时间可以自己定义
TimerSend.OnTimer := TimerSendtimer;
ACOMM := TCOMM.Create(nil);
ACOMM.OnReceiveData := CommReceiveData;
Acomm.OnReceiveError := CommReceiveError;
if not SetUDPParameter() then EXIT;
end;
function TCom232.Open(): boolean;
begin
result := false;
try
AComm.StartComm();
except
writelog(AComm.CommName + ' 打开失败,请确信电缆正确...');
exit;
end;
//是否判断已经打开,重复打开
// writelog(AComm.CommName + ' 打开失败...');
result := true;
end;
destructor TCom232.DESTROY;
begin
if TimerSend <> nil then
begin
TimerSend.Enabled := FALSE;
TimerSend.Free;
end;
if ACOMM <> nil then
begin
Acomm.StopComm;
AComm.Free;
end;
WRITELOG('COM232 服务正常关闭!');
end;
function TCom232.Execute: BOOLEAN;
begin
timerSend.Enabled := true;
RESULT := TRUE;
end;
function TCom232.LoadUDPParameter(): BOOLEAN;
var inifile: pchar;
begin
RESULT := FALSE;
inifile := pchar(CurPath + CONFIG);
try
CFG.CommName := GETINIkey(inifile, 'com232', 'CommName');
CFG.BaudRate := strtoint(GETINIkey(inifile, 'com232', 'BaudRate'));
CFG.ByteSize := GETINIkey(inifile, 'com232', 'ByteSize');
CFG.StopBits := GETINIkey(inifile, 'COM232', 'StopBits');
CFG.Parity := GETINIkey(inifile, 'COM232', 'Parity');
CFG.NeedWriteLog := STRTOINT(GETINIkey(inifile, 'COM232', 'NeedWriteLog'));
RESULT := TRUE;
except
RESULT := FALSE;
EXIT;
end;
if (CFG.ByteSize <> '_5') and (CFG.ByteSize <> '_6') and (CFG.ByteSize <> '_7') and (CFG.ByteSize <> '_8') then
begin
Writelog(config + ' is error:bytesize must in [_5, _6, _7, _8] . . ');
result := false;
EXIT;
end;
if (CFG.StopBits <> '_1') and (CFG.StopBits <> '_1_5') and (CFG.StopBits <> '_2') then
begin
Writelog(config + ' is error:StopBits must in [_1, _1_5, _2] . . ');
result := false;
EXIT;
end;
//None, Odd, Even, Mark, Space
if (CFG.Parity <> 'None') and (CFG.Parity <> 'Odd') and (CFG.Parity <> 'Even') and (CFG.Parity <> 'Mark') and (CFG.Parity <> 'Space') then
begin
Writelog(config + ' is error
arity must in [None, Odd, Even, Mark, Space] . . ');
result := false;
EXIT;
end;
end;
function TCom232.SetUDPParameter(): BOOLEAN;
begin
RESULT := FALSE;
try
WriteLog('COM232 全双工通信服务正在加载...');
WriteLog('commname:' + cfg.CommName);
WriteLog('BaudRate:' + inttostr(cfg.BaudRate));
WriteLog('ByteSize:' + cfg.ByteSize);
WriteLog('StopBits:' + cfg.StopBits);
WriteLog('Parity:' + cfg.Parity);
AComm.CommName := '//./'+cfg.CommName;
AComm.BaudRate := cfg.BaudRate;
if cfg.ByteSize = '_5' then AComm.ByteSize := tbytesize(0);
if cfg.ByteSize = '_6' then AComm.ByteSize := tbytesize(1);
if cfg.ByteSize = '_7' then AComm.ByteSize := tbytesize(2);
if cfg.ByteSize = '_8' then AComm.ByteSize := tbytesize(3);
if cfg.StopBits = ' _1' then AComm.StopBits := TStopBits(0);
if cfg.StopBits = ' _1_5' then AComm.StopBits := TStopBits(1);
if cfg.StopBits = ' _2' then AComm.StopBits := TStopBits(2);
if cfg.Parity = 'None' then AComm.Parity := TParity(0);
if cfg.Parity = 'Odd' then AComm.Parity := TParity(1);
if cfg.Parity = 'Even' then AComm.Parity := TParity(2);
if cfg.Parity = 'Mark' then AComm.Parity := TParity(3);
if cfg.Parity = 'Space' then AComm.Parity := TParity(4);
writelog('Set Com232 Parameter success...');
RESULT := TRUE;
except
writelog('Set Com232 Parameter fail...');
RESULT := FALSE;
end;
end;
procedure TCom232.TimerSendTimer(Sender: tobject);
var
wmsg: PMyPobject;
TmpStr: string;
buf: array of byte;
begin
if not HaveData(SendDataQueue) then exit;
//现在如何确信com依然打开呢？否则readfrombuf 读了就被删除了
try
wmsg := nil;
if not ReadFromBuf(wmsg, SendDataQueue) then exit;
if wmsg = nil then exit; //如果成功会自动从队列删除
// buf[0]:=byte($A1);
// buf[1]:=byte($A2);
// buf[2]:=byte($A3);
// buf[3]:=byte($f1);
//AComm.WriteCommData(@buf[0],4);
//winsock.SendBuf(wmsg.msg^, wmsg.Len);
setlength(buf, wmsg.Len);
copymemory(buf, wmsg.Msg, wmsg.Len);
AComm.WriteCommData(@buf[0], wmsg.Len);
BytesToHexStr(TmpStr,wmsg.Msg, wmsg.Len);
//也可以BytesToHexStr(TmpStr, @buf[0], wmsg.Len);完全正确
SendLog(TmpStr);
finally
if wmsg <> nil then
begin
if wmsg^.Msg <> nil then
FreeMem(wmsg.Msg, wmsg.Len);
Dispose(wmsg);
end;
end;
end;
procedure TCom232.CommReceiveData(Sender: TObject; Buffer: Pointer;
BufferLength: Word);
var
TmpStr: string;
wmsg: PMyPobject;
begin
new(wmsg);
getmem(wmsg.Msg, BufferLength);
CopyMemory(wmsg.Msg, Buffer, BufferLength); // wmsg.Msg^ := MsgOfWrite^;
WriteToBuf(wmsg, ReceiveDataQueue, BufferLength);
BytesToHexStr(TmpStr, wmsg.Msg, BufferLength);
RecLog(Tmpstr);
end;
procedure TCom232.CommReceiveError(Sender: TObject; EventMask: Cardinal);
begin
writelog(ACOMM.CommName + ' ReceiveError...');
end;
function FreeBuf(Buffer: PTThreadList): Boolean;
var
tmpList: TList;
wmsg: pMyPobject;
begin
result := true;
tmpList := Buffer^.LockList;
while tmpList.Count > 0 do
begin
wmsg := PMyPobject(tmpList.Last);
tmpList.Delete(tmplist.Count - 1);
tmplist.Pack;
if wmsg <> nil then
begin
if wmsg^.Msg <> nil then
FreeMem(wmsg.Msg, wmsg.Len);
Dispose(wmsg);
end;
end
end;
function ReadFromBuf(var MyObject: PMyPobject; var
Buffer: PTThreadList): Boolean;
var
tmpList: TList;
begin
result := true;
tmpList := Buffer^.LockList;
try
if tmpList.Count > 0 then
begin
MyObject := tmpList.First;
tmpList.Delete(0);
tmpList.Pack;
end
else
begin
MyObject := nil;
result := false;
end;
finally
begin
Buffer^.UnlockList;
end;
end;
end;
function HaveData(Buffer: PTThreadList): Boolean;
var
tmpList: TList;
begin
tmpList := Buffer^.LockList;
if tmpList.Count > 0 then
result := true
else
result := false;
Buffer^.UnlockList;
end;
function WriteToBuf(var MyObject: PMyPobject; var
Buffer: PTThreadList; Capacity: Integer): Boolean;
var
tmpList: TList;
wmsg: PMyPobject;
begin
tmpList := Buffer^.LockList;
try
while tmpList.Count >= Capacity do
begin
wmsg := tmpList.First;
tmpList.Delete(0);
tmpList.Pack;
if wmsg <> nil then
begin
if wmsg^.Msg <> nil then
FreeMem(wmsg.Msg, wmsg.Len);
Dispose(wmsg);
end;
end;
tmpList.Add(MyObject);
tmpList.Pack;
finally
begin
Buffer^.UnlockList;
end;
end;
result := true;
end;
end.
