Экспертная система Delphi.int.ru

Сообщество программистов
Общение, помощь, обмен опытом
Логин:
Пароль:
Регистрация | Забыли пароль?

Delphi.int.ru Expert

Другие разделы портала

Переход к вопросу:

#   

Статистика за сегодня:  


Лучшие эксперты

Подробнее »

Вопрос # 366

Раздел: Delphi » Работа с устройствами и "железом"
/ вопрос открыт /

Здрасте, уважаемые эксперты!!! Подскажите, возможно-ли на Delhi, а если возможно, то как, сделать обработчик прерывания от LPT и COM портов. Заранее спасибо!!!

CherepVM Вопрос ожидает решения (принимаются ответы, доступен мини-форум)

Вопрос задал: CherepVM (статус: Посетитель)
Вопрос отправлен: 2 марта 2007, 11:49
Состояние вопроса: открыт, ответов: 2.

Ответ #1. Отвечает эксперт: Вадим К

Вы же не в досе, где всё можно. Под виндовсом единственно правильный способ сделать это - драйвер. Но это не стихия делфи. А зачем вам обработчик прерывания от порта? Экономить ресурсы собрались? Опрашивайте в потоке и всё.

Ответ отправил: Вадим К (статус: Академик)
Время отправки: 2 марта 2007, 13:47

Ответ #2. Отвечает эксперт: Роман

Здравствуйте, Цопа Владимир Милузиевич!Как извесно в NT лавочка с прямым доступом к портам была прикрыта,и для работы с COM есть функции winapi,но как мне помнится обслуживание прерываний там не предусмотрено,НО есть реализация в компоненте TBComPort.Там мониторинг состояния линий порта выведен в отдельный поток с генерацией событий;для LPT есть такая штука LptWdmIo - драйвер LPTWDMIO.sys предоставляет пользовательским приложениям возможность управлять параллельными портами ПК.Он поддерживает два вида операций -- чтение из порта и записи в порт.Прерываний там нет,но при необходилости их можно реализовать опять-же отдельным потоком.

Приложение:
  1.  
  2.  
  3.  
  4.  
  5.  
  6.  
  7.  
  8.  
  9. unit BCPort;
  10.  
  11. interface
  12.  
  13. uses
  14. Windows, Messages, SysUtils, Classes;
  15.  
  16. {$B-,H+,X+}
  17.  
  18. {$IFDEF VER140}
  19. {$DEFINE D6UP}
  20. {$ENDIF}
  21.  
  22. {$IFDEF VER150}
  23. {$DEFINE D6UP}
  24. {$ENDIF}
  25.  
  26. type
  27. TBaudRate = (br110, br300, br600, br1200, br2400, br4800, br9600, br14400,
  28. br19200, br38400, br56000, br57600, br115200, br128000, br256000);
  29. TByteSize = (bs5, bs6, bs7, bs8);
  30. TComErrors = set of (ceFrame, ceRxParity, ceOverrun, ceBreak, ceIO, ceMode,
  31. ceRxOver, ceTxFull);
  32. TComEvents = set of (evRxChar, evTxEmpty, evRing, evCTS, evDSR, evRLSD,
  33. evError, evRx80Full);
  34. TComSignals = set of (csCTS, csDSR, csRing, csRLSD);
  35. TParity = (paNone, paOdd, paEven, paMark, paSpace);
  36. TStopBits = (sb1, sb1_5, sb2);
  37. TSyncMethod = (smThreadSync, smWindowSync, smNone);
  38. TComSignalEvent = procedure(Sender: TObject; State: Boolean) of object;
  39. TComErrorEvent = procedure(Sender: TObject; Errors: TComErrors) of object;
  40. TRxCharEvent = procedure(Sender: TObject; Count: Integer) of object;
  41.  
  42. TOperationKind = (okWrite, okRead);
  43. TAsync = record
  44. Overlapped: TOverlapped;
  45. Kind: TOperationKind;
  46. Data: Pointer;
  47. Size: Integer;
  48. end;
  49. PAsync = ^TAsync;
  50.  
  51. TBComPort = class;
  52.  
  53. TComThread = class(TThread)
  54. private
  55. FComPort: TBComPort;
  56. FEvents: TComEvents;
  57. FStopEvent: THandle;
  58. protected
  59. procedure DoEvents;
  60. procedure Execute; override;
  61. procedure SendEvents;
  62. procedure Stop;
  63. public
  64. constructor Create(AComPort: TBComPort);
  65. destructor Destroy; override;
  66. end;
  67.  
  68. TComTimeouts = class(TPersistent)
  69. private
  70. FComPort: TBComPort;
  71. FReadInterval: Integer;
  72. FReadTotalM: Integer;
  73. FReadTotalC: Integer;
  74. FWriteTotalM: Integer;
  75. FWriteTotalC: Integer;
  76. procedure SetComPort(const AComPort: TBComPort);
  77. procedure SetReadInterval(const Value: Integer);
  78. procedure SetReadTotalM(const Value: Integer);
  79. procedure SetReadTotalC(const Value: Integer);
  80. procedure SetWriteTotalM(const Value: Integer);
  81. procedure SetWriteTotalC(const Value: Integer);
  82. protected
  83. procedure AssignTo(Dest: TPersistent); override;
  84. public
  85. constructor Create;
  86. property ComPort: TBComPort read FComPort;
  87. published
  88. property ReadInterval: Integer read FReadInterval write SetReadInterval;
  89. property ReadTotalMultiplier: Integer read FReadTotalM write SetReadTotalM;
  90. property ReadTotalConstant: Integer read FReadTotalC write SetReadTotalC;
  91. property WriteTotalMultiplier: Integer
  92. read FWriteTotalM write SetWriteTotalM;
  93. property WriteTotalConstant: Integer
  94. read FWriteTotalC write SetWriteTotalC;
  95. end;
  96.  
  97. TBComPort = class(TComponent)
  98. private
  99. FBaudRate: TBaudRate;
  100. FByteSize: TByteSize;
  101. FConnected: Boolean;
  102. FCTPriority: TThreadPriority;
  103. FEvents: TComEvents;
  104. FEventThread: TComThread;
  105. FHandle: THandle;
  106. FInBufSize: Integer;
  107. FOutBufSize: Integer;
  108. FParity: TParity;
  109. FPort: String;
  110. FStopBits: TStopBits;
  111. FSyncMethod: TSyncMethod;
  112. FTimeouts: TComTimeouts;
  113. FUpdate: Boolean;
  114. FWindow: THandle;
  115. FOnCTSChange: TComSignalEvent;
  116. FOnDSRChange: TComSignalEvent;
  117. FOnError: TComErrorEvent;
  118. FOnRing: TNotifyEvent;
  119. FOnRLSDChange: TComSignalEvent;
  120. FOnRx80Full: TNotifyEvent;
  121. FOnRxChar: TRxCharEvent;
  122. FOnTxEmpty: TNotifyEvent;
  123. procedure CallCTSChange;
  124. procedure CallDSRChange;
  125. procedure CallError;
  126. procedure CallRing;
  127. procedure CallRLSDChange;
  128. procedure CallRx80Full;
  129. procedure CallRxChar;
  130. procedure CallTxEmpty;
  131. procedure SetBaudRate(const Value: TBaudRate);
  132. procedure SetByteSize(const Value: TByteSize);
  133. procedure SetCTPriority(const Value: TThreadPriority);
  134. procedure SetInBufSize(const Value: Integer);
  135. procedure SetOutBufSize(const Value: Integer);
  136. procedure SetParity(const Value: TParity);
  137. procedure SetPort(const Value: String);
  138. procedure SetStopBits(const Value: TStopBits);
  139. procedure SetSyncMethod(const Value: TSyncMethod);
  140. procedure SetTimeouts(const Value: TComTimeouts);
  141. procedure WindowMethod(var Message: TMessage);
  142. protected
  143. procedure ApplyBuffer;
  144. procedure ApplyDCB;
  145. procedure ApplyTimeouts;
  146. procedure CreateHandle;
  147. procedure DestroyHandle;
  148. procedure SetupComPort;
  149. public
  150. constructor Create(AOwner: TComponent); override;
  151. destructor Destroy; override;
  152. procedure AbortAllAsync;
  153. procedure BeginUpdate;
  154. procedure ClearBuffer(Input, Output: Boolean);
  155. procedure Close;
  156. procedure EndUpdate;
  157. function InBufCount: Integer;
  158. function IsAsyncCompleted(AsyncPtr: PAsync): Boolean;
  159. procedure Open;
  160. function OutBufCount: Integer;
  161. function Read(var Buffer; Count: Integer): Integer;
  162. function ReadAsync(var Buffer; Count: Integer; var AsyncPtr: PAsync): Integer;
  163. function ReadStr(var Str: string; Count: Integer): Integer;
  164. function ReadStrAsync(var Str: string; Count: Integer; var AsyncPtr: PAsync): Integer;
  165. procedure SetDTR(State: Boolean);
  166. procedure SetRTS(State: Boolean);
  167. function Signals: TComSignals;
  168. function WaitForAsync(var AsyncPtr: PAsync): Integer;
  169. function Write(const Buffer; Count: Integer): Integer;
  170. function WriteAsync(const Buffer; Count: Integer; var AsyncPtr: PAsync): Integer;
  171. function WriteStr(const Str: string): Integer;
  172. function WriteStrAsync(const Str: string; var AsyncPtr: PAsync): Integer;
  173. property Connected: Boolean read FConnected;
  174. property CTPriority: TThreadPriority read FCTPriority write SetCTPriority;
  175. published
  176. property BaudRate: TBaudRate read FBaudRate write SetBaudRate;
  177. property ByteSize: TByteSize read FByteSize write SetByteSize;
  178. property InBufSize: Integer read FInBufSize write SetInBufSize;
  179. property OutBufSize: Integer read FOutBufSize write SetOutBufSize;
  180. property Parity: TParity read FParity write SetParity;
  181. property Port: String read FPort write SetPort;
  182. property SyncMethod: TSyncMethod read FSyncMethod write SetSyncMethod;
  183. property StopBits: TStopBits read FStopBits write SetStopBits;
  184. property Timeouts: TComTimeouts read FTimeouts write SetTimeouts;
  185. property OnCTSChange: TComSignalEvent read FOnCTSChange write FOnCTSChange;
  186. property OnDSRChange: TComSignalEvent read FOnDSRChange write FOnDSRChange;
  187. property OnError: TComErrorEvent read FOnError write FOnError;
  188. property OnRing: TNotifyEvent read FOnRing write FOnRing;
  189. property OnRLSDChange: TComSignalEvent read FOnRLSDChange write FOnRLSDChange;
  190. property OnRx80Full: TNotifyEvent read FOnRx80Full write FOnRx80Full;
  191. property OnRxChar: TRxCharEvent read FOnRxChar write FOnRxChar;
  192. property OnTxEmpty: TNotifyEvent read FOnTxEmpty write FOnTxEmpty;
  193. end;
  194.  
  195. EComPort = class(Exception);
  196.  
  197. procedure InitAsync(var AsyncPtr: PAsync);
  198. procedure DoneAsync(var AsyncPtr: PAsync);
  199. procedure EnumComPorts(Ports: TStrings);
  200.  
  201. procedure Register;
  202.  
  203. implementation
  204.  
  205. uses
  206. Forms;
  207.  
  208. const
  209. CM_COMPORT = WM_USER + 1;
  210.  
  211. CEMess: array[1..15] of string =
  212.  
  213.  
  214.  
  215.  
  216.  
  217.  
  218.  
  219.  
  220.  
  221.  
  222.  
  223.  
  224.  
  225.  
  226.  
  227.  
  228. function EventsToInt(const Events: TComEvents): Integer;
  229. begin
  230. Result := 0;
  231. if evRxChar in Events then Result := Result or EV_RXCHAR;
  232. if evTxEmpty in Events then Result := Result or EV_TXEMPTY;
  233. if evRing in Events then Result := Result or EV_RING;
  234. if evCTS in Events then Result := Result or EV_CTS;
  235. if evDSR in Events then Result := Result or EV_DSR;
  236. if evRLSD in Events then Result := Result or EV_RLSD;
  237. if evError in Events then Result := Result or EV_ERR;
  238. if evRx80Full in Events then Result := Result or EV_RX80FULL;
  239. end;
  240.  
  241. function IntToEvents(Mask: Integer): TComEvents;
  242. begin
  243. Result := [];
  244. if (EV_RXCHAR and Mask) <> 0 then Result := Result + [evRxChar];
  245. if (EV_TXEMPTY and Mask) <> 0 then Result := Result + [evTxEmpty];
  246. if (EV_RING and Mask) <> 0 then Result := Result + [evRing];
  247. if (EV_CTS and Mask) <> 0 then Result := Result + [evCTS];
  248. if (EV_DSR and Mask) <> 0 then Result := Result + [evDSR];
  249. if (EV_RLSD and Mask) <> 0 then Result := Result + [evRLSD];
  250. if (EV_ERR and Mask) <> 0 then Result := Result + [evError];
  251. if (EV_RX80FULL and Mask) <> 0 then Result := Result + [evRx80Full];
  252. end;
  253.  
  254. { TComThread }
  255.  
  256. constructor TComThread.Create(AComPort: TBComPort);
  257. begin
  258. inherited Create(True);
  259. FStopEvent := CreateEvent(nil, True, False, nil);
  260. FComPort := AComPort;
  261. Priority := FComPort.CTPriority;
  262. SetCommMask(FComPort.FHandle, EventsToInt(FComPort.FEvents));
  263. Resume;
  264. end;
  265.  
  266. destructor TComThread.Destroy;
  267. begin
  268. Stop;
  269. inherited Destroy;
  270. end;
  271.  
  272. procedure TComThread.Execute;
  273. var
  274. EventHandles: array[0..1] of THandle;
  275. Overlapped: TOverlapped;
  276. Signaled, BytesTrans, Mask: DWORD;
  277. begin
  278. FillChar(Overlapped, SizeOf(Overlapped), 0);
  279. Overlapped.hEvent := CreateEvent(nil, True, True, nil);
  280. EventHandles[0] := FStopEvent;
  281. EventHandles[1] := Overlapped.hEvent;
  282. repeat
  283. WaitCommEvent(FComPort.FHandle, Mask, @Overlapped);
  284. Signaled := WaitForMultipleObjects(2, @EventHandles, False, INFINITE);
  285. if (Signaled = WAIT_OBJECT_0 + 1) and
  286. GetOverlappedResult(FComPort.FHandle, Overlapped, BytesTrans, False) then
  287. begin
  288. FEvents := IntToEvents(Mask);
  289. case FComPort.SyncMethod of
  290. smThreadSync: Synchronize(DoEvents);
  291. smWindowSync: SendEvents;
  292. smNone : DoEvents;
  293. end;
  294. end;
  295. until Signaled <> (WAIT_OBJECT_0 + 1);
  296. SetCommMask(FComPort.FHandle, 0);
  297. PurgeComm(FComPort.FHandle, PURGE_TXCLEAR or PURGE_RXCLEAR);
  298. CloseHandle(Overlapped.hEvent);
  299. CloseHandle(FStopEvent);
  300. end;
  301.  
  302. procedure TComThread.Stop;
  303. begin
  304. SetEvent(FStopEvent);
  305. Sleep(0);
  306. end;
  307.  
  308. procedure TComThread.SendEvents;
  309. begin
  310. if evError in FEvents then
  311. SendMessage(FComPort.FWindow, CM_COMPORT, EV_ERR, 0);
  312. if evRxChar in FEvents then
  313. SendMessage(FComPort.FWindow, CM_COMPORT, EV_RXCHAR, 0);
  314. if evTxEmpty in FEvents then
  315. SendMessage(FComPort.FWindow, CM_COMPORT, EV_TXEMPTY, 0);
  316. if evRing in FEvents then
  317. SendMessage(FComPort.FWindow, CM_COMPORT, EV_RING, 0);
  318. if evCTS in FEvents then
  319. SendMessage(FComPort.FWindow, CM_COMPORT, EV_CTS, 0);
  320. if evDSR in FEvents then
  321. SendMessage(FComPort.FWindow, CM_COMPORT, EV_DSR, 0);
  322. if evRing in FEvents then
  323. SendMessage(FComPort.FWindow, CM_COMPORT, EV_RLSD, 0);
  324. if evRx80Full in FEvents then
  325. SendMessage(FComPort.FWindow, CM_COMPORT, EV_RX80FULL, 0);
  326. end;
  327.  
  328. procedure TComThread.DoEvents;
  329. begin
  330. if evError in FEvents then FComPort.CallError;
  331. if evRxChar in FEvents then FComPort.CallRxChar;
  332. if evTxEmpty in FEvents then FComPort.CallTxEmpty;
  333. if evRing in FEvents then FComPort.CallRing;
  334. if evCTS in FEvents then FComPort.CallCTSChange;
  335. if evDSR in FEvents then FComPort.CallDSRChange;
  336. if evRLSD in FEvents then FComPort.CallRLSDChange;
  337. if evRx80Full in FEvents then FComPort.CallRx80Full;
  338. end;
  339.  
  340. { TComTimeouts }
  341.  
  342. constructor TComTimeouts.Create;
  343. begin
  344. inherited Create;
  345. FReadInterval := -1;
  346. FWriteTotalM := 100;
  347. FWriteTotalC := 1000;
  348. end;
  349.  
  350. procedure TComTimeouts.AssignTo(Dest: TPersistent);
  351. begin
  352. if Dest is TComTimeouts then
  353. begin
  354. with TComTimeouts(Dest) do
  355. begin
  356. FReadInterval := Self.ReadInterval;
  357. FReadTotalM := Self.ReadTotalMultiplier;
  358. FReadTotalC := Self.ReadTotalConstant;
  359. FWriteTotalM := Self.WriteTotalMultiplier;
  360. FWriteTotalC := Self.WriteTotalConstant;
  361. end;
  362. end
  363. else
  364. inherited AssignTo(Dest);
  365. end;
  366.  
  367. procedure TComTimeouts.SetComPort(const AComPort: TBComPort);
  368. begin
  369. FComPort := AComPort;
  370. end;
  371.  
  372. procedure TComTimeouts.SetReadInterval(const Value: Integer);
  373. begin
  374. if Value <> FReadInterval then
  375. begin
  376. FReadInterval := Value;
  377. FComPort.ApplyTimeouts;
  378. end;
  379. end;
  380.  
  381. procedure TComTimeouts.SetReadTotalC(const Value: Integer);
  382. begin
  383. if Value <> FReadTotalC then
  384. begin
  385. FReadTotalC := Value;
  386. FComPort.ApplyTimeouts;
  387. end;
  388. end;
  389.  
  390. procedure TComTimeouts.SetReadTotalM(const Value: Integer);
  391. begin
  392. if Value <> FReadTotalM then
  393. begin
  394. FReadTotalM := Value;
  395. FComPort.ApplyTimeouts;
  396. end;
  397. end;
  398.  
  399. procedure TComTimeouts.SetWriteTotalC(const Value: Integer);
  400. begin
  401. if Value <> FWriteTotalC then
  402. begin
  403. FWriteTotalC := Value;
  404. FComPort.ApplyTimeouts;
  405. end;
  406. end;
  407.  
  408. procedure TComTimeouts.SetWriteTotalM(const Value: Integer);
  409. begin
  410. if Value <> FWriteTotalM then
  411. begin
  412. FWriteTotalM := Value;
  413. FComPort.ApplyTimeouts;
  414. end;
  415. end;
  416.  
  417. { TBComPort }
  418.  
  419. constructor TBComPort.Create(AOwner: TComponent);
  420. begin
  421. inherited Create(AOwner);
  422. FComponentStyle := FComponentStyle - [csInheritable];
  423. FBaudRate := br9600;
  424. FByteSize := bs8;
  425. FConnected := False;
  426. FCTPriority := tpNormal;
  427. FEvents := [evRxChar, evTxEmpty, evRing, evCTS, evDSR, evRLSD, evError,
  428. evRx80Full];
  429. FHandle := INVALID_HANDLE_VALUE;
  430. FInBufSize := 2048;
  431. FOutBufSize := 2048;
  432. FParity := paNone;
  433. FPort := 'COM2';
  434. FStopBits := sb1;
  435. FSyncMethod := smThreadSync;
  436. FTimeouts := TComTimeouts.Create;
  437. FTimeouts.SetComPort(Self);
  438. FUpdate := True;
  439. end;
  440.  
  441. destructor TBComPort.Destroy;
  442. begin
  443. Close;
  444. FTimeouts.Free;
  445. inherited Destroy;
  446. end;
  447.  
  448. procedure TBComPort.CreateHandle;
  449. begin
  450. FHandle := CreateFile(PChar('\.' + FPort), GENERIC_READ or GENERIC_WRITE,
  451. 0, nil, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0);
  452. if FHandle = INVALID_HANDLE_VALUE then
  453. begin
  454. if GetLastError = ERROR_FILE_NOT_FOUND then
  455. raise EComPort.Create(CEMess[1])
  456. else if GetLastError = ERROR_ACCESS_DENIED then
  457. raise EComPort.Create(CEMess[2]);
  458. end;
  459. end;
  460.  
  461. procedure TBComPort.DestroyHandle;
  462. begin
  463. if FHandle <> INVALID_HANDLE_VALUE then CloseHandle(FHandle);
  464. end;
  465.  
  466. procedure TBComPort.WindowMethod(var Message: TMessage);
  467. begin
  468. with Message do
  469. if Msg = CM_COMPORT then
  470. try
  471. if InSendMessage then ReplyMessage(0);
  472. if FConnected then
  473. case wParam of
  474. EV_CTS: CallCTSChange;
  475. EV_DSR: CallDSRChange;
  476. EV_RING: CallRing;
  477. EV_RLSD: CallRLSDChange;
  478. EV_RX80FULL: CallRx80Full;
  479. EV_RXCHAR: CallRxChar;
  480. EV_ERR: CallError;
  481. EV_TXEMPTY: CallTxEmpty;
  482. end;
  483. except
  484. Application.HandleException(Self);
  485. end
  486. else
  487. Result := DefWindowProc(FWindow, Msg, wParam, lParam);
  488. end;
  489.  
  490. procedure TBComPort.BeginUpdate;
  491. begin
  492. FUpdate := False;
  493. end;
  494.  
  495. procedure TBComPort.EndUpdate;
  496. begin
  497. if not FUpdate then FUpdate := True;
  498. SetupComPort;
  499. end;
  500.  
  501. procedure TBComPort.Open;
  502. begin
  503. if not FConnected then
  504. begin
  505. CreateHandle;
  506. FConnected := True;
  507. try
  508. SetupComPort;
  509. except
  510. DestroyHandle;
  511. FConnected := False;
  512. raise;
  513. end;
  514. if (FSyncMethod = smWindowSync) then
  515. {$IFDEF D6UP}
  516. {$WARN SYMBOL_DEPRECATED OFF}
  517. {$ENDIF}
  518. FWindow := AllocateHWnd(WindowMethod);
  519. {$IFDEF D6UP}
  520. {$WARN SYMBOL_DEPRECATED ON}
  521. {$ENDIF}
  522. FEventThread := TComThread.Create(Self);
  523. end;
  524. end;
  525.  
  526. procedure TBComPort.Close;
  527. begin
  528. if FConnected then
  529. begin
  530. SetDTR(False);
  531. SetRTS(False);
  532. AbortAllAsync;
  533. FEventThread.Free;
  534. if FSyncMethod = smWindowSync then
  535. {$IFDEF D6UP}
  536. {$WARN SYMBOL_DEPRECATED OFF}
  537. {$ENDIF}
  538. DeallocateHWnd(FWindow);
  539. {$IFDEF D6UP}
  540. {$WARN SYMBOL_DEPRECATED ON}
  541. {$ENDIF}
  542. DestroyHandle;
  543. FConnected := False;
  544. end;
  545. end;
  546.  
  547. procedure TBComPort.ApplyDCB;
  548. const
  549. CBaudRate: array[TBaudRate] of Integer = (CBR_110, CBR_300, CBR_600,
  550. CBR_1200, CBR_2400, CBR_4800, CBR_9600, CBR_14400, CBR_19200, CBR_38400,
  551. CBR_56000, CBR_57600, CBR_115200, CBR_128000, CBR_256000);
  552. var
  553. DCB: TDCB;
  554. begin
  555. if FConnected and FUpdate then
  556. begin
  557. FillChar(DCB, SizeOf(TDCB), 0);
  558. DCB.DCBlength := SizeOf(TDCB);
  559. DCB.BaudRate := CBaudRate[FBaudRate];
  560. DCB.ByteSize := Ord(TByteSize(FByteSize)) + 5;
  561. DCB.Flags := 1 or ($30 and (DTR_CONTROL_ENABLE shl 4))
  562. or ($3000 and (RTS_CONTROL_ENABLE shl 12));
  563. if FParity <> paNone then
  564. DCB.Flags := DCB.Flags or 2;
  565. DCB.Parity := Ord(TParity(FParity));
  566. DCB.StopBits := Ord(TStopBits(FStopBits));
  567. DCB.XonChar := #17;
  568. DCB.XoffChar := #19;
  569. if not SetCommState(FHandle, DCB) then
  570. raise EComPort.Create(CEMess[8]);
  571. end;
  572. end;
  573.  
  574. procedure TBComPort.ApplyTimeouts;
  575. var
  576. Timeouts: TCommTimeouts;
  577.  
  578. function MValue(const Value: Integer): DWORD;
  579. begin
  580. if Value < 0 then Result := MAXDWORD else Result := Value;
  581. end;
  582.  
  583. begin
  584. if FConnected and FUpdate then
  585. begin
  586. Timeouts.ReadIntervalTimeout := MValue(FTimeouts.ReadInterval);
  587. Timeouts.ReadTotalTimeoutMultiplier := MValue(FTimeouts.ReadTotalMultiplier);
  588. Timeouts.ReadTotalTimeoutConstant := MValue(FTimeouts.ReadTotalConstant);
  589. Timeouts.WriteTotalTimeoutMultiplier := MValue(FTimeouts.WriteTotalMultiplier);
  590. Timeouts.WriteTotalTimeoutConstant := MValue(FTimeouts.WriteTotalConstant);
  591. if not SetCommTimeouts(FHandle, Timeouts) then
  592. raise EComPort.Create(CEMess[9]);
  593. end;
  594. end;
  595.  
  596. procedure TBComPort.ApplyBuffer;
  597. begin
  598. if FConnected and FUpdate then
  599. if not SetupComm(FHandle, FInBufSize, FOutBufSize) then
  600. raise EComPort.Create(CEMess[10]);
  601. end;
  602.  
  603. procedure TBComPort.SetupComPort;
  604. begin
  605. ApplyBuffer;
  606. ApplyDCB;
  607. ApplyTimeouts;
  608. end;
  609.  
  610. function TBComPort.InBufCount: Integer;
  611. var
  612. Errors: DWORD;
  613. ComStat: TComStat;
  614. begin
  615. if not ClearCommError(FHandle, Errors, @ComStat) then
  616. raise EComPort.Create(CEMess[11]);
  617. Result := ComStat.cbInQue;
  618. end;
  619.  
  620. function TBComPort.OutBufCount: Integer;
  621. var
  622. Errors: DWORD;
  623. ComStat: TComStat;
  624. begin
  625. if not ClearCommError(FHandle, Errors, @ComStat) then
  626. raise EComPort.Create(CEMess[11]);
  627. Result := ComStat.cbOutQue;
  628. end;
  629.  
  630. function TBComPort.Signals: TComSignals;
  631. var
  632. Status: DWORD;
  633. begin
  634. if not GetCommModemStatus(FHandle, Status) then
  635. raise EComPort.Create(CEMess[12]);
  636. Result := [];
  637. if (MS_CTS_ON and Status) <> 0 then Result := Result + [csCTS];
  638. if (MS_DSR_ON and Status) <> 0 then Result := Result + [csDSR];
  639. if (MS_RING_ON and Status) <> 0 then Result := Result + [csRing];
  640. if (MS_RLSD_ON and Status) <> 0 then Result := Result + [csRLSD];
  641. end;
  642.  
  643. procedure TBComPort.SetDTR(State: Boolean);
  644. var
  645. Act: DWORD;
  646. begin
  647. if State then Act := Windows.SETDTR else Act := Windows.CLRDTR;
  648. if not EscapeCommFunction(FHandle, Act) then
  649. raise EComPort.Create(CEMess[13]);
  650. end;
  651.  
  652. procedure TBComPort.SetRTS(State: Boolean);
  653. var
  654. Act: DWORD;
  655. begin
  656. if State then Act := Windows.SETRTS else Act := Windows.CLRRTS;
  657. if not EscapeCommFunction(FHandle, Act) then
  658. raise EComPort.Create(CEMess[13]);
  659. end;
  660.  
  661. procedure TBComPort.ClearBuffer(Input, Output: Boolean);
  662. var
  663. Flag: DWORD;
  664. begin
  665. Flag := 0;
  666. if Input then
  667. Flag := PURGE_RXCLEAR;
  668. if Output then
  669. Flag := Flag or PURGE_TXCLEAR;
  670. if not PurgeComm(FHandle, Flag) then
  671. raise EComPort.Create(CEMess[6]);
  672. end;
  673.  
  674. procedure PrepareAsync(AKind: TOperationKind; const Buffer;
  675. Count: Integer; AsyncPtr: PAsync);
  676. begin
  677. with AsyncPtr^ do
  678. begin
  679. Kind := AKind;
  680. if Data <> nil then FreeMem(Data);
  681. GetMem(Data, Count);
  682. Move(Buffer, Data^, Count);
  683. Size := Count;
  684. end;
  685. end;
  686.  
  687. function TBComPort.WriteAsync(const Buffer; Count: Integer; var AsyncPtr: PAsync): Integer;
  688. var
  689. Success: Boolean;
  690. BytesTrans: DWORD;
  691. begin
  692. if AsyncPtr = nil then
  693. raise EComPort.Create(CEMess[5]);
  694. PrepareAsync(okWrite, Buffer, Count, AsyncPtr);
  695. Success := WriteFile(FHandle, Buffer, Count, BytesTrans, @AsyncPtr^.Overlapped)
  696. or (GetLastError = ERROR_IO_PENDING);
  697. if not Success then
  698. raise EComPort.Create(CEMess[3]);
  699. Result := BytesTrans;
  700. end;
  701.  
  702. function TBComPort.Write(const Buffer; Count: Integer): Integer;
  703. var
  704. AsyncPtr: PAsync;
  705. begin
  706. InitAsync(AsyncPtr);
  707. try
  708. WriteAsync(Buffer, Count, AsyncPtr);
  709. Result := WaitForAsync(AsyncPtr);
  710. finally
  711. DoneAsync(AsyncPtr);
  712. end;
  713. end;
  714.  
  715. function TBComPort.WriteStrAsync(const Str: string; var AsyncPtr: PAsync): Integer;
  716. begin
  717. if Length(Str) > 0 then
  718. Result := WriteAsync(Str[1], Length(Str), AsyncPtr)
  719. else
  720. Result := 0;
  721. end;
  722.  
  723. function TBComPort.WriteStr(const Str: string): Integer;
  724. var
  725. AsyncPtr: PAsync;
  726. begin
  727. InitAsync(AsyncPtr);
  728. try
  729. WriteStrAsync(Str, AsyncPtr);
  730. Result := WaitForAsync(AsyncPtr);
  731. finally
  732. DoneAsync(AsyncPtr);
  733. end;
  734. end;
  735.  
  736. function TBComPort.ReadAsync(var Buffer; Count: Integer; var AsyncPtr: PAsync): Integer;
  737. var
  738. Success: Boolean;
  739. BytesTrans: DWORD;
  740. begin
  741. if AsyncPtr = nil then
  742. raise EComPort.Create(CEMess[5]);
  743. AsyncPtr^.Kind := okRead;
  744. Success := ReadFile(FHandle, Buffer, Count, BytesTrans, @AsyncPtr^.Overlapped)
  745. or (GetLastError = ERROR_IO_PENDING);
  746. if not Success then
  747. raise EComPort.Create(CEMess[4]);
  748. Result := BytesTrans;
  749. end;
  750.  
  751. function TBComPort.Read(var Buffer; Count: Integer): Integer;
  752. var
  753. AsyncPtr: PAsync;
  754. begin
  755. InitAsync(AsyncPtr);
  756. try
  757. ReadAsync(Buffer, Count, AsyncPtr);
  758. Result := WaitForAsync(AsyncPtr);
  759. finally
  760. DoneAsync(AsyncPtr);
  761. end;
  762. end;
  763.  
  764. function TBComPort.ReadStrAsync(var Str: string; Count: Integer; var AsyncPtr: PAsync): Integer;
  765. begin
  766. SetLength(Str, Count);
  767. if Count > 0 then
  768. Result := ReadAsync(Str[1], Count, AsyncPtr)
  769. else
  770. Result := 0;
  771. end;
  772.  
  773. function TBComPort.ReadStr(var Str: string; Count: Integer): Integer;
  774. var
  775. AsyncPtr: PAsync;
  776. begin
  777. InitAsync(AsyncPtr);
  778. try
  779. ReadStrAsync(Str, Count, AsyncPtr);
  780. Result := WaitForAsync(AsyncPtr);
  781. SetLength(Str, Result);
  782. finally
  783. DoneAsync(AsyncPtr);
  784. end;
  785. end;
  786.  
  787. function ErrorCode(AsyncPtr: PAsync): Integer;
  788. begin
  789. if AsyncPtr^.Kind = okRead then Result := 4 else Result := 3;
  790. end;
  791.  
  792. function TBComPort.WaitForAsync(var AsyncPtr: PAsync): Integer;
  793. var
  794. BytesTrans, Signaled: DWORD;
  795. Success: Boolean;
  796. begin
  797. if AsyncPtr = nil then
  798. raise EComPort.Create(CEMess[5]);
  799. Signaled := WaitForSingleObject(AsyncPtr^.Overlapped.hEvent, INFINITE);
  800. Success := (Signaled = WAIT_OBJECT_0) and
  801. (GetOverlappedResult(FHandle, AsyncPtr^.Overlapped, BytesTrans, False));
  802. if not Success then
  803. raise EComPort.Create(CEMess[ErrorCode(AsyncPtr)]);
  804. Result := BytesTrans;
  805. end;
  806.  
  807. procedure TBComPort.AbortAllAsync;
  808. begin
  809. if not PurgeComm(FHandle, PURGE_TXABORT or PURGE_RXABORT) then
  810. raise EComPort.Create(CEMess[6]);
  811. end;
  812.  
  813. function TBComPort.IsAsyncCompleted(AsyncPtr: PAsync): Boolean;
  814. var
  815. BytesTrans: DWORD;
  816. begin
  817. if AsyncPtr = nil then
  818. raise EComPort.Create(CEMess[5]);
  819. Result := GetOverlappedResult(FHandle, AsyncPtr^.Overlapped, BytesTrans, False);
  820. if not Result then
  821. if (GetLastError <> ERROR_IO_PENDING) and (GetLastError <> ERROR_IO_INCOMPLETE) then
  822. raise EComPort.Create(CEMess[7]);
  823. end;
  824.  
  825. procedure TBComPort.CallCTSChange;
  826. begin
  827. if Assigned(FOnCTSChange) then FOnCTSChange(Self, csCTS in Signals);
  828. end;
  829.  
  830. procedure TBComPort.CallDSRChange;
  831. begin
  832. if Assigned(FOnDSRChange) then FOnDSRChange(Self, csDSR in Signals);
  833. end;
  834.  
  835. procedure TBComPort.CallRLSDChange;
  836. begin
  837. if Assigned(FOnRLSDChange) then FOnRLSDChange(Self, csRLSD in Signals);
  838. end;
  839.  
  840. procedure TBComPort.CallError;
  841. var
  842. Errs: TComErrors;
  843. Errors: DWORD;
  844. ComStat: TComStat;
  845. begin
  846. if not ClearCommError(FHandle, Errors, @ComStat) then
  847. raise EComPort.Create(CEMess[11]);
  848. Errs := [];
  849. if (CE_FRAME and Errors) <> 0 then Errs := Errs + [ceFrame];
  850. if ((CE_RXPARITY and Errors) <> 0) and (FParity <> paNone) then
  851. Errs := Errs + [ceRxParity];
  852. if (CE_OVERRUN and Errors) <> 0 then Errs := Errs + [ceOverrun];
  853. if (CE_RXOVER and Errors) <> 0 then Errs := Errs + [ceRxOver];
  854. if (CE_TXFULL and Errors) <> 0 then Errs := Errs + [ceTxFull];
  855. if (CE_BREAK and Errors) <> 0 then Errs := Errs + [ceBreak];
  856. if (CE_IOE and Errors) <> 0 then Errs := Errs + [ceIO];
  857. if (CE_MODE and Errors) <> 0 then Errs := Errs + [ceMode];
  858. if (Errs <> []) and Assigned(FOnError) then FOnError(Self, Errs);
  859. end;
  860.  
  861. procedure TBComPort.CallRing;
  862. begin
  863. if Assigned(FOnRing) then FOnRing(Self);
  864. end;
  865.  
  866. procedure TBComPort.CallRx80Full;
  867. begin
  868. if Assigned(FOnRx80Full) then FOnRx80Full(Self);
  869. end;
  870.  
  871. procedure TBComPort.CallRxChar;
  872. var
  873. Count: Integer;
  874. begin
  875. Count := InBufCount;
  876. if (Count > 0) and Assigned(FOnRxChar) then FOnRxChar(Self, Count);
  877. end;
  878.  
  879. procedure TBComPort.CallTxEmpty;
  880. begin
  881. if Assigned(FOnTxEmpty) then FOnTxEmpty(Self);
  882. end;
  883.  
  884. procedure TBComPort.SetBaudRate(const Value: TBaudRate);
  885. begin
  886. if Value <> FBaudRate then
  887. begin
  888. FBaudRate := Value;
  889. ApplyDCB;
  890. end;
  891. end;
  892.  
  893. procedure TBComPort.SetByteSize(const Value: TByteSize);
  894. begin
  895. if Value <> FByteSize then
  896. begin
  897. FByteSize := Value;
  898. ApplyDCB;
  899. end;
  900. end;
  901.  
  902. procedure TBComPort.SetParity(const Value: TParity);
  903. begin
  904. if Value <> FParity then
  905. begin
  906. FParity := Value;
  907. ApplyDCB;
  908. end;
  909. end;
  910.  
  911. procedure TBComPort.SetPort(const Value: String);
  912. begin
  913. if FConnected then
  914. raise EComPort.Create(CEMess[14])
  915. else
  916. if Value <> FPort then FPort := Value;
  917. end;
  918.  
  919. procedure TBComPort.SetStopBits(const Value: TStopBits);
  920. begin
  921. if Value <> FStopBits then
  922. begin
  923. FStopBits := Value;
  924. ApplyDCB;
  925. end;
  926. end;
  927.  
  928. procedure TBComPort.SetSyncMethod(const Value: TSyncMethod);
  929. begin
  930. if Value <> FSyncMethod then
  931. begin
  932. if FConnected then
  933. raise EComPort.Create(CEMess[14])
  934. else
  935. FSyncMethod := Value;
  936. end;
  937. end;
  938.  
  939. procedure TBComPort.SetCTPriority(const Value: TThreadPriority);
  940. begin
  941. if Value <> FCTPriority then
  942. begin
  943. if FConnected then
  944. raise EComPort.Create(CEMess[14])
  945. else
  946. FCTPriority := Value;
  947. end;
  948. end;
  949.  
  950. procedure TBComPort.SetInBufSize(const Value: Integer);
  951. begin
  952. if Value <> FInBufSize then
  953. begin
  954. FInBufSize := Value;
  955. if (FInBufSize mod 2) = 1 then Dec(FInBufSize);
  956. ApplyBuffer;
  957. end;
  958. end;
  959.  
  960. procedure TBComPort.SetOutBufSize(const Value: Integer);
  961. begin
  962. if Value <> FOutBufSize then
  963. begin
  964. FOutBufSize := Value;
  965. if (FOutBufSize mod 2) = 1 then Dec(FOutBufSize);
  966. ApplyBuffer;
  967. end;
  968. end;
  969.  
  970. procedure TBComPort.SetTimeouts(const Value: TComTimeouts);
  971. begin
  972. FTimeouts.Assign(Value);
  973. ApplyTimeouts;
  974. end;
  975.  
  976. procedure InitAsync(var AsyncPtr: PAsync);
  977. begin
  978. New(AsyncPtr);
  979. with AsyncPtr^ do
  980. begin
  981. FillChar(Overlapped, SizeOf(TOverlapped), 0);
  982. Overlapped.hEvent := CreateEvent(nil, True, True, nil);
  983. Data := nil;
  984. Size := 0;
  985. end;
  986. end;
  987.  
  988. procedure DoneAsync(var AsyncPtr: PAsync);
  989. begin
  990. with AsyncPtr^ do
  991. begin
  992. CloseHandle(Overlapped.hEvent);
  993. if Data <> nil then FreeMem(Data);
  994. end;
  995. Dispose(AsyncPtr);
  996. AsyncPtr := nil;
  997. end;
  998.  
  999. procedure EnumComPorts(Ports: TStrings);
  1000. var
  1001. KeyHandle: HKEY;
  1002. ErrCode, Index: Integer;
  1003. ValueName, Data: String;
  1004. ValueLen, DataLen, ValueType: DWORD;
  1005. TmpPorts: TStringList;
  1006. begin
  1007. ErrCode := RegOpenKeyEx(HKEY_LOCAL_MACHINE, 'HARDWAREDEVICEMAPSERIALCOMM',
  1008. 0, KEY_READ, KeyHandle);
  1009. if ErrCode <> ERROR_SUCCESS then
  1010. raise EComPort.Create(CEMess[15]);
  1011. TmpPorts := TStringList.Create;
  1012. try
  1013. Index := 0;
  1014. repeat
  1015. ValueLen := 256;
  1016. DataLen := 256;
  1017. SetLength(ValueName, ValueLen);
  1018. SetLength(Data, DataLen);
  1019. ErrCode := RegEnumValue(KeyHandle, Index, PChar(ValueName),
  1020. {$IFDEF VER120}
  1021. Cardinal(ValueLen),
  1022. {$ELSE}
  1023. ValueLen,
  1024. {$ENDIF}
  1025. nil, @ValueType, PByte(PChar(Data)), @DataLen);
  1026. if ErrCode = ERROR_SUCCESS then
  1027. begin
  1028. SetLength(Data, DataLen - 1);
  1029. TmpPorts.Add(Data);
  1030. Inc(Index);
  1031. end
  1032. else
  1033. if ErrCode <> ERROR_NO_MORE_ITEMS then
  1034. raise EComPort.Create(CEMess[15]);
  1035. until (ErrCode <> ERROR_SUCCESS) ;
  1036. TmpPorts.Sort;
  1037. Ports.Assign(TmpPorts);
  1038. finally
  1039. RegCloseKey(KeyHandle);
  1040. TmpPorts.Free;
  1041. end;
  1042. end;
  1043.  
  1044. procedure Register;
  1045. begin
  1046. RegisterComponents('Samples', [TBComPort]);
  1047. end;
  1048.  
  1049. end.
  1050.  


Ответ отправил: Роман (статус: 5-ый класс)
Время отправки: 2 марта 2007, 14:02
Оценка за ответ: 5

Комментарий к оценке: Огромное спасибо за подсказку! В глубине души я подозревал, что проблему нужно решать через потоки. Но так-как "варюсь в собственном соку" (нескем общаться) решил поспрошать у Вас - Экспертов.

Мини-форум вопроса

Мини-форум пуст.

Чтобы оставлять сообщения в мини-форумах, Вы должны авторизироваться на сайте.
Версия движка: 2.6+ (26.01.2011)
© 2005-2025
Текущее время: 22 февраля 2025, 11:46
Выполнено за 0.03 сек.