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: 32: 33: 34: 35: 36: 37: 38: 39: 40: 41: 42: 43: 44: 45: 46: 47: 48: 49: 50: 51: 52: 53: 54: 55: 56: 57: 58: 59: 60: 61: 62: 63: 64: 65: 66: 67: 68: 69: 70: 71: 72: 73: 74: 75: 76: 77: 78: 79: 80: 81: 82: 83: 84: 85: 86: 87: 88: 89: 90: 91: 92: 93: 94: 95: 96: 97: 98: 99: 100: 101: 102: 103: 104: 105: 106: 107: 108: 109: 110: 111: 112: 113: 114: 115: 116: 117: 118: 119: 120: 121: 122: 123: 124: 125: 126: 127: 128: 129: 130: 131: 132: 133: 134: 135: 136: 137: 138: 139: 140: 141: 142: 143: 144: 145: 146: 147: 148: 149: 150: 151: 152: 153: 154: 155: 156: 157: 158: 159: 160: 161: 162: 163: 164: 165: 166: 167: 168: 169: 170: 171: 172: 173: 174: 175: 176: 177: 178: 179: 180: 181: 182: 183: 184: 185: 186: 187: 188: 189: 190: 191: 192: 193: 194: 195: 196: 197: 198: 199: 200: 201: 202: 203: 204: 205: 206: 207: 208: 209: 210: 211: 212: 213: 214: 215: 216: 217: 218: 219: 220: 221: 222: 223: 224: 225: 226: 227: 228: 229: 230: 231: 232: 233: 234: 235: 236: 237: 238: 239: 240: 241: 242: 243: 244: 245: 246: 247: 248: 249: 250: 251: 252: 253: 254: 255: 256: 257: 258: 259: 260: 261: 262: 263: 264: 265: 266: 267: 268: 269: 270: 271: 272: 273: 274: 275: 276: 277: 278: 279: 280: 281: 282: 283: 284: 285: 286: 287: 288: 289: 290: 291: 292: 293: 294: 295: 296: 297: 298: 299: 300: 301: 302: 303: 304: 305: 306: 307: 308: 309: 310: 311: 312: 313: 314: 315: 316: 317: 318: 319: 320: 321: 322: 323: 324: 325: 326: 327: 328: 329: 330: 331: 332: 333: 334: 335: 336: 337: 338: 339: 340: 341: 342: 343: 344: 345: 346: 347: 348: 349: 350: 351: 352: 353: 354: 355: 356: 357: 358: 359: 360: 361: 362: 363: 364: 365: 366: 367: 368: 369: 370: 371: 372: 373: 374: 375: 376: 377: 378: 379: 380: 381: 382: 383: 384: 385: 386: 387: 388: 389: 390: 391: 392: 393: 394: 395: 396: 397: 398: 399: 400: 401: 402: 403: 404: 405: 406: 407: 408: 409: 410: 411: 412: 413: 414: 415: 416: 417: 418: 419: 420: 421: 422: 423: 424: 425: 426: 427: 428: 429: 430: 431: 432: 433: 434: 435: 436: 437: 438: 439: 440: 441: 442: 443: 444: 445: 446: 447: 448: 449: 450: 451: 452: 453: 454: 455: 456: 457: 458: 459: 460: 461: 462: 463: 464: 465: 466: 467: 468: 469: 470: 471: 472: 473: 474: 475: 476: 477: 478: 479: 480: 481: 482: 483: 484: 485: 486: 487: 488: 489: 490: 491: 492: 493: 494: 495: 496: 497: 498: 499: 500: 501: 502: 503: 504: 505: 506: 507: 508: 509: 510: 511: 512: 513: 514: 515: 516: 517: 518: 519: 520: 521: 522: 523: 524: 525: 526: 527: 528: 529: 530: 531: 532: 533: 534: 535: 536: 537: 538: 539: 540: 541: 542: 543: 544: 545: 546: 547: 548: 549: 550: 551: 552: 553: 554: 555: 556: 557: 558: 559: 560: 561: 562: 563: 564: 565: 566: 567: 568: 569: 570: 571: 572: 573: 574: 575: 576: 577: 578: 579: 580: 581: 582: 583: 584: 585: 586: 587: 588: 589: 590: 591: 592: 593: 594: 595: 596: 597: 598: 599: 600: 601: 602: 603: 604: 605: 606: 607: 608: 609: 610: 611: 612: 613: 614: 615: 616: 617: 618: 619: 620: 621: 622: 623: 624: 625: 626: 627: 628: 629: 630: 631: 632: 633: 634: 635: 636: 637: 638: 639: 640: 641: 642: 643: 644: 645: 646: 647: 648: 649: 650: 651: 652: 653: 654: 655: 656: 657:
| unit comm_async;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
const MAXPORTS = 10; WM_CommEvent = WM_USER + $1000; WM_CommChar = WM_USER + $1001; WM_CommErr = WM_USER + $1002; dcb_Binary = $0001; dcb_Parity = $0002; dcb_OutxCtsFlow = $0004; dcb_OutxDsrFlow = $0008; dcb_DtrControl = $0010; dcb_DsrSensitvity = $0040; dcb_TXContinueOnXOff = $0080; dcb_OutX = $0100; dcb_InX = $0200; dcb_ErrorChar = $0400; dcb_Null = $0800; dcb_RtsControl = $1000; dcb_AbortOnError = $4000; type PVars = ^TVars; TVars = record Connected: Boolean; InBuffer, OutBuffer, CommEventMask: DWord; PortNr: Byte; hWindow: hWnd; hComm, hWatchTh, hPostEv, hWatchEv: THandle; WatchThID: DWord; OvWrite, OvRead: TOverlapped; end;
TBaudRate = (cbr110, cbr300, cbr600, cbr1200, cbr2400, cbr4800, cbr9600, cbr14400, cbr19200, cbr38400, cbr56000, cbr57600, cbr115200, cbr128000, cbr256000); TParity = (cpNONE, cpODD, cpEVEN, cpMARK, cpSPACE); TStopBits = (csbONE, csbONE5, csbTWO); TFlowControl = (cfcNone, cfcHardware, cfcXonXoff); TEventMask = set of (cevBREAK, cevCTS, cevDSR, cevERR, cevRING, cevRLSD, cevRXCHAR, cevRXFLAG, cevTXEMPTY); TOnCommEvent = procedure(Sender: TObject; Events, State: DWord) of object; TOnCharReceived = procedure(Sender: TObject; cbInQue: DWord) of object; TOnCommError = procedure(Sender: TObject; ErrorCode: DWord) of object;
type TComm = class(TComponent) private D: TVars; fOSVersion: TOSVersionInfo; fCommTimeouts: TCommTimeouts; fDCB: TDCB; fFlowControl: TFlowControl; fOnCommEvent: TOnCommEvent; fOnCharReceived: TOnCharReceived; fOnCommError: TOnCommError; protected procedure WndProc(var Msg: TMessage); procedure SetupParams; procedure DoCommEvent(Events, State: DWord); dynamic; procedure DoCharReceived(Len: DWord); dynamic; procedure DoCommError(ErrorCode: DWord); dynamic; procedure SetPortNr(Val: Byte); function GetBaudRate: TBaudRate; procedure SetBaudRate(Val: TBaudRate); procedure SetByteSize(Val: Byte); function GetParity: TParity; procedure SetParity(Val: TParity); function GetStopBits: TStopBits; procedure SetStopBits(Val: TStopBits); procedure SetInBufSize(Val: DWord); procedure SetOutBufSize(Val: DWord); function GetFlowControl: TFlowControl; procedure SetFlowControl(Value: TFlowControl); function GetEventMask: TEventMask; procedure SetEventMask(Val: TEventMask); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function Open: boolean; procedure Close; function Read(P: Pointer; Len: DWord): DWord; function Write(P: Pointer; Len: DWord): DWord; procedure SetupDlg; published property Port: Byte read D.PortNr write SetPortNr; property BaudRate: TBaudRate read GetBaudRate write SetBaudRate; property ByteSize: Byte read fDCB.ByteSize write SetByteSize; property Parity: TParity read GetParity write SetParity; property StopBits: TStopBits read GetStopBits write SetStopBits; property FlowControl: TFlowControl read GetFlowControl write SetFlowControl; property XonChar: Char read fDCB.XonChar write fDCB.XonChar; property XoffChar: Char read fDCB.XoffChar write fDCB.XoffChar; property ErrorChar: Char read fDCB.ErrorChar write fDCB.ErrorChar; property EofChar: Char read fDCB.EofChar write fDCB.EofChar; property EvtChar: Char read fDCB.EvtChar write fDCB.EvtChar; property XOnLimit: Word read fDCB.XOnLim write fDCB.XOnLim; property XOffLimit: Word read fDCB.XOffLim write fDCB.XOffLim; property Connected: Boolean read D.Connected; property InBufSize: DWord read D.InBuffer write SetInBufSize; property OutBufSize: DWord read D.OutBuffer write SetOutBufSize; property EventMask: TEventMask read GetEventMask write SetEventMask; property OnCommEvent: TOnCommEvent read fOnCommEvent write fOnCommEvent; property OnCharReceived: TOnCharReceived read fOnCharReceived write fOnCharReceived; property OnCommError: TOnCommError read fOnCommError write fOnCommError; end;
function CommWatch(PData: Pointer): LongInt; stdcall;
procedure Register;
implementation
constructor TComm.Create(AOwner: TComponent); const SetDCB : PChar = 'baud=9600 parity=n data=8 stop=1'; var CC: TCommConfig; begin inherited Create(AOwner); FillMemory(@D, SizeOf(D), 0); D.hWindow:= AllocateHWnd(WndProc); D.OvWrite.hEvent:= CreateEvent(nil, True, False, nil); D.OvRead.hEvent:= CreateEvent(nil, True, False, nil); D.hPostEv:= CreateEvent(nil, True, True, nil); fDCB.dcbLength:= SizeOf(fDCB); FillMemory(@CC, SizeOf(CC), 0); CC.dwSize:= SizeOf(CC); fOSVersion.dwOSVersionInfoSize:= SizeOf(fOSVersion); GetVersionEx(fOSVersion); if (fOSVersion.dwPlatformID = VER_PLATFORM_WIN32_NT) and (fOSVersion.dwMajorVersion < 4) then BuildCommDCB('baud=9600 parity=N data=8 stop=1', fDCB) else begin GetDefaultCommConfig('COM1', CC, CC.dwSize); fDCB:= CC.DCB; end; D.PortNr:= 1; D.InBuffer:= 2048; D.OutBuffer:= 2048; D.CommEventMask:= ev_RXCHAR; end; destructor TComm.Destroy; begin with D do begin if Connected then Close; CloseHandle(OvWrite.hEvent); CloseHandle(OvRead.hEvent); CloseHandle(hPostEv); end; DeallocateHWnd(D.hWindow); inherited Destroy; end; function TComm.Open: boolean; var ModemStat: DWord; begin if not D.Connected then begin D.hComm:= CreateFile(PChar('\\.\COM' + IntToStr(D.PortNr) + #0), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0); if D.hComm <> INVALID_HANDLE_VALUE then begin with D do begin Connected:= True; SetupParams; hWatchTh:= CreateThread(nil, 0, @CommWatch, @D, 0, WatchThID); SetThreadPriority(hWatchTh, THREAD_PRIORITY_BELOW_NORMAL); ResumeThread(hWatchTh); EscapeCommFunction(hComm, SETDTR); GetCommModemStatus(hComm, ModemStat); DoCommEvent($FFFFFFFF, ModemStat); end; end; Result:= D.Connected; end else Result:= False; end; procedure TComm.Close; begin if D.Connected then begin D.Connected:= False;
SetCommMask(D.hComm, 0); SetThreadPriority(D.hWatchTh, THREAD_PRIORITY_NORMAL); ResumeThread(D.hWatchTh);
while D.WatchThID <> 0 do begin end;
EscapeCommFunction(D.hComm, CLRDTR); PurgeComm(D.hComm, PURGE_TXABORT or PURGE_RXABORT or PURGE_TXCLEAR or PURGE_RXCLEAR); CloseHandle(D.hComm); end; end; function TComm.Read(P: Pointer; Len: DWord): DWord; var State: Boolean; ErrorFlags, ReadBytes, MaxLen: DWord; ComStat: TComStat; begin if D.Connected then begin ClearCommError(D.hComm, ErrorFlags, @ComStat); if ComStat.cbInQue > Len then MaxLen:= Len else MaxLen:= ComStat.cbInQue; State:= ReadFile(D.hComm, P^, MaxLen, ReadBytes, @(D.OvRead)); if not State and (GetLastError = ERROR_IO_PENDING) then if WaitForSingleObject(D.OvRead.hEvent, 1000) <> 0 then ReadBytes:= 0 else Begin GetOverlappedResult(D.hComm, D.OvRead, ReadBytes, False); end; Result:= ReadBytes; end else Result:= 0; end; function TComm.Write(P: Pointer; Len: DWord): DWord; var State: Boolean; WrittenBytes: DWord; begin if D.Connected then begin State:= WriteFile(D.hComm, P^, Len, WrittenBytes, @(D.OvWrite)); if not State and (GetLastError = ERROR_IO_PENDING) then if WaitForSingleObject(D.OvWrite.hEvent, 1000) <> 0 then WrittenBytes:=0 else begin GetOverlappedResult(D.hComm, D.OvWrite, WrittenBytes, False); end; Result:= WrittenBytes; end Else Result:= 0; end; procedure TComm.SetupDlg; var CommConfig: TCommConfig; begin if (fOSVersion.dwPlatformID = VER_PLATFORM_WIN32_NT) or (fOSVersion.dwMajorVersion >= 4) then begin FillMemory(@CommConfig, SizeOf(CommConfig), 0); CommConfig.dwSize:= SizeOf(CommConfig); if D.Connected then GetCommConfig(D.hComm, CommConfig, CommConfig.dwSize) else GetDefaultCommConfig(PChar('COM' + IntToStr(D.PortNr) + #0), CommConfig, CommConfig.dwSize); if CommConfigDialog(PChar('COM' + IntToStr(D.PortNr) + #0), 0, CommConfig) then begin fDCB:= CommConfig.DCB; SetupParams; end; end; end; procedure TComm.SetupParams; begin with D do if Connected then begin SetCommState(hComm, fDCB); SetupComm(hComm, InBuffer, OutBuffer); end; end;
procedure TComm.WndProc(var Msg: TMessage); begin with Msg do case Msg of WM_CommEvent: DoCommEvent(wParam, lParam); WM_CommChar: if lParam = $FF then DoCharReceived(wParam); WM_CommErr: if lParam = $FF then DoCommError(wParam); else Result:= DefWindowProc(D.hWindow, Msg, wParam, lParam); end; end; procedure TComm.DoCommEvent(Events, State: DWord); begin if Assigned(FOnCommEvent) then FOnCommEvent(Self, Events, State); SetEvent(D.hPostEv); end; procedure TComm.DoCharReceived(Len: DWord); begin if Assigned(FOnCharReceived) then FOnCharReceived(Self, Len); SetEvent(D.hPostEv); end;
procedure TComm.DoCommError(ErrorCode: DWord); begin if Assigned(FOnCommError) then FOnCommError(Self, ErrorCode); SetEvent(D.hPostEv); end;
function CommWatch(PData: Pointer): LongInt; stdcall; var D: PVars; OS: TOverlapped; EventMask, Transfer: DWord; ComStat: TComStat; ModemStat, ErrorCode: DWord; begin D:= PData; FillMemory(@OS, SizeOf(OS), 0); OS.hEvent:= CreateEvent(nil, True, False, nil); SetCommMask(D^.hComm, D^.CommEventMask); while D^.Connected do begin EventMask:= 0; if not WaitCommEvent(D^.hComm, EventMask, @OS) then if ERROR_IO_PENDING = GetLastError then begin GetOverlappedResult(D^.hComm, OS, Transfer, True); OS.Offset:= OS.Offset + Transfer; end; if EventMask <> 0 then begin ClearCommError(D^.hComm, ErrorCode, @ComStat); if EventMask and EV_ERR = EV_ERR then begin WaitForSingleObject(D^.hPostEv, $FFFFFFFF); ResetEvent(D^.hPostEv); PostMessage(D^.hWindow, WM_CommErr, ErrorCode, $FF); end; if EventMask and EV_RXCHAR = EV_RXCHAR then begin WaitForSingleObject(D^.hPostEv, $FFFFFFFF); ResetEvent(D^.hPostEv); PostMessage(D^.hWindow, WM_CommChar, ComStat.cbInQue, $FF); end; if EventMask and (EV_RXCHAR or EV_ERR) = 0 then begin GetCommModemStatus(D^.hComm, ModemStat); WaitForSingleObject(D^.hPostEv, $FFFFFFFF); ResetEvent(D^.hPostEv); PostMessage(D^.hWindow, WM_CommEvent, EventMask, ModemStat); end; end; end; CloseHandle(OS.hEvent); D^.hWatchTh:= 0; D^.WatchThID:= 0; Result:= LongInt(True); end;
procedure TComm.SetPortNr(Val: Byte); begin if not D.Connected then if (Val <> D.PortNr) and (Val > 0) and (Val <= MAXPORTS) then begin D.PortNr:= Val; end; end;
function TComm.GetBaudRate: TBaudRate; begin case fDCB.BaudRate of cbr_110: Result:= cbr110; cbr_300: Result:= cbr300; cbr_600: Result:= cbr600; cbr_1200: Result:= cbr1200; cbr_2400: Result:= cbr2400; cbr_4800: Result:= cbr4800; cbr_9600: Result:= cbr9600; cbr_14400: Result:= cbr14400; cbr_19200: Result:= cbr19200; cbr_38400: Result:= cbr38400; cbr_56000: Result:= cbr56000; cbr_57600: Result:= cbr57600; cbr_115200: Result:= cbr115200; cbr_128000: Result:= cbr128000; else Result:= cbr256000; end; end;
procedure TComm.SetBaudRate(Val: TBaudRate); begin with fDCB do case Val of cbr110: BaudRate:= cbr_110; cbr300: BaudRate:= cbr_300; cbr600: BaudRate:= cbr_600; cbr1200: BaudRate:= cbr_1200; cbr2400: BaudRate:= cbr_2400; cbr4800: BaudRate:= cbr_4800; cbr9600: BaudRate:= cbr_9600; cbr14400: BaudRate:= cbr_14400; cbr19200: BaudRate:= cbr_19200; cbr38400: BaudRate:= cbr_38400; cbr56000: BaudRate:= cbr_56000; cbr57600: BaudRate:= cbr_57600; cbr115200: BaudRate:= cbr_115200; cbr128000: BaudRate:= cbr_128000; cbr256000: BaudRate:= cbr_256000; end; SetupParams; end;
procedure TComm.SetByteSize(Val: Byte); begin if Val <> fDCB.ByteSize then if (Val >= 3) and (Val <= 8) then begin fDCB.ByteSize:= Val; SetupParams; end; end;
function TComm.GetParity: TParity; begin case fDCB.Parity of ODDPARITY : Result:= cpODD; EVENPARITY : Result:= cpEVEN; MARKPARITY : Result:= cpMARK; SPACEPARITY : Result:= cpSPACE; else Result:= cpNONE; end; end;
procedure TComm.SetParity(Val: TParity); begin with fDCB do begin Flags:= Flags or dcb_Parity; case Val of cpODD : Parity:= ODDPARITY; cpEVEN : Parity:= EVENPARITY; cpMARK : Parity:= MARKPARITY; cpSpace : Parity:= SPACEPARITY; else begin Parity:= NOPARITY; Flags:= Flags and (not(Word(dcb_Parity))); end; end; end; SetupParams; end;
function TComm.GetStopBits: TStopBits; begin case fDCB.StopBits of ONESTOPBIT : Result:= csbONE; ONE5STOPBITS : Result:= csbONE5; else Result:= csbTWO; end; end;
procedure TComm.SetStopBits(Val: TStopBits); begin with fDCB do case Val of csbONE : StopBits:= ONESTOPBIT; csbONE5 : StopBits:= ONE5STOPBITS; else StopBits:= TWOSTOPBITS; end; SetupParams; end;
procedure TComm.SetInBufSize(Val: DWord); begin if Val > 0 then begin D.InBuffer:= Val; SetupParams; end; end;
procedure TComm.SetOutBufSize(Val: DWord); begin if Val > 0 then begin D.OutBuffer:= Val; SetupParams; end; end;
function TComm.GetFlowControl: TFlowControl; begin with fDCB do begin if (Flags and $2000 = $2000) then Result:= cfcHardware else if (Flags and $300 = $300) then Result:= cfcXonXoff else Result:= cfcNone; end; end;
procedure TComm.SetFlowControl(Value: TFlowControl); begin FFlowControl:= Value; with fDCB do begin Flags:= Flags and $4C83; case FFlowControl of cfcNone : Flags:= Flags or $11; cfcHardware : Flags:= FLags or $2015; cfcXonXoff : Flags:= Flags or $311; end; end; SetupParams; end;
function TComm.GetEventMask: TEventMask; begin Result:= []; if (EV_BREAK and D.CommEventMask) =EV_BREAK then include(Result, cevBREAK); if (EV_CTS and D.CommEventMask) = EV_CTS then include(Result, cevCTS); if (EV_DSR and D.CommEventMask) = EV_DSR then include(Result, cevDSR); if (EV_ERR and D.CommEventMask) = EV_ERR then include(Result, cevERR); if (EV_RING and D.CommEventMask) = EV_RING then include(Result, cevRING); if (EV_RLSD and D.CommEventMask) = EV_RLSD then include(Result, cevRLSD); if (EV_RXCHAR and D.CommEventMask) = EV_RXCHAR then include(Result, cevRXCHAR); if (EV_RXFLAG and D.CommEventMask) = EV_RXFLAG then include(Result, cevRXFLAG); if (EV_TXEMPTY and D.CommEventMask) = EV_TXEMPTY then include(Result, cevTXEMPTY); end;
procedure TComm.SetEventMask(Val: TEventMask); begin D.CommEventMask:= 0; if cevBREAK in Val then D.CommEventMask:= D.CommEventMask or EV_BREAK; if cevCTS in Val then D.CommEventMask:= D.CommEventMask or EV_CTS; if cevDSR in Val then D.CommEventMask:= D.CommEventMask or EV_DSR; if cevERR in Val then D.CommEventMask:= D.CommEventMask or EV_ERR; if cevRING in Val then D.CommEventMask:= D.CommEventMask or EV_RING; if cevRLSD in Val then D.CommEventMask:= D.CommEventMask or EV_RLSD; if cevRXCHAR in Val then D.CommEventMask:= D.CommEventMask or EV_RXCHAR; if cevRXFLAG in Val then D.CommEventMask:= D.CommEventMask or EV_RXFLAG; if cevTXEMPTY in Val then D.CommEventMask:= D.CommEventMask or EV_TXEMPTY; if D.Connected then SetCommMask(D.hComm, D.CommEventMask); end;
procedure Register; begin RegisterComponents('COMM Seriell', [TComm]); end;
end. |