盒子论坛 v2.1

这是我自己写的用线程监视串口数据的完整例子，作用是读取IC卡刷卡时往com口发送的数据，并转为键盘按键。你自己看吧，可能有点多，但思路很简单：先初始化COM口，然后创建线程临监视COM口，并以API函数ReadFile来读取数据：

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Buttons, Trayico, Menus;

type
  TOnGetStrEvent = procedure(AChar :Char) of object;

  TCommThread = Class(TThread)
  private
  protected
      FOnGetStr :TOnGetStrEvent;
      FComStat : PComStat;
  procedure Execute;override;
  public
      constructor Create(AONGetStr :TONGetStrEvent);
      destructor Destroy; override;
  end;

  Tfrmmain = class(TForm)
    StartCmd: TBitBtn;
    Memo1: TMemo;
    StopCmd: TButton;
    BitBtn2: TBitBtn;
    BitBtn3: TBitBtn;
    BitBtn4: TBitBtn;
    TrayIco: TRxTrayIcon;
    PopupMenu1: TPopupMenu;
    N1: TMenuItem;
    N2: TMenuItem;
    N3: TMenuItem;
    N4: TMenuItem;
    procedure StartCmdClick(Sender: TObject);
    procedure StopCmdClick(Sender: TObject);
    procedure BitBtn3Click(Sender: TObject);
    procedure BitBtn4Click(Sender: TObject);
    procedure BitBtn2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure N4Click(Sender: TObject);
    procedure N1Click(Sender: TObject);
    procedure N2Click(Sender: TObject);
    procedure TrayIcoMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure TrayIcoDblClick(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  private
    { Private declarations }
    FOnGetStr :TOnGetStrEvent;
    FOnGetStr1 :TOnGetStrEvent;
    procedure DoOnGetStr(AChar: Char);
  public
    { Public declarations }
    procedure StartComm;
    procedure EndComm;
    property OnGetStr :TONGetStrEvent read FOnGetStr write FOnGetStr;
  end;

var
  frmmain: Tfrmmain;

  CommHandle : THandle;
  CommHandle1 : THandle;
  CommHandle2 : THandle;
  CommHandle3 : THandle;
  Connected : Boolean;
  Connected1 : Boolean;
  Connected2 : Boolean;
  CommThread : TCommThread;
  ok,ok1,pd,ppd:boolean;
  sca:string;

procedure SendStr(S :string);

implementation
uses c_setup, selffunc;

{$R *.dfm}
procedure SendStr(S :string);
var I :integer;
    vk :integer;
    bShift :boolean;
    function _ShiftKey(C: Char): boolean;
    begin
      result := C in ['~', '@', '#', '$', '%', '^', '&', '*', '(', ')',
                      '_', '+', '|', '{', '}', ':', '"', '<', '>', '?'];
    end;
begin
  for I :=1 to length(S) do
  begin
     bShift := false;
      if UpperCase(S)[I] in ['A'..'Z'] then
       begin
         vk := 65 + (ORD(UpperCase(S)[I]) - ORD('A'));
         bShift := true;
       end
      else
      if UpperCase(S)[I] in ['0'..'9'] then
        vk := 48 + (ORD(UpperCase(S)[I]) - ORD('0'))
      else
        case S[I] of
          '/',
          '?': vk := 191;
          '\',
          '|': vk := 220;
          ';',
          ':': vk := 186;
          '-',
          '_': vk := 189;
          '=',
          '+': vk := 187;
          #39,  // '
          '"': vk := 222;
          '.',
          '>' :vk := 190;
          ',',
          '<' :vk := 188;

          '~': vk := 192;
          '!': vk := 49;
          '@': vk := 50;
          '#': vk := 51;
          '$': vk := 52;
          '%': vk := 53;
          '^': vk := 54;
          '&': vk := 55;
          '*': vk := 56;
          '(': vk := 57;
          ')': vk := 48;

          else vk := 0;
       end;
    bShift := _ShiftKey(S[I]);
    if bShift then
     keybd_event(16, 0, 0, 0);

    keybd_event(vk, 0, 0, 0);
    keybd_event(vk, 0, KEYEVENTF_KEYUP, 0);

    if bShift then
     keybd_event(16, 0, KEYEVENTF_KEYUP, 0);

  end;
end;

procedure TCommThread.Execute;
var
dwErrorFlags,dwLength : DWORD;
fReadStat : Boolean;
InChar : Char;
AbIn : String;
XX,YY : double;
VID : string;
ASleep: integer;
begin
while Connected do
begin
      ASleep := 200;
      ClearCommError(CommHandle, dwErrorFlags, FComStat);
      if (dwErrorFlags >  0) then
      begin
        PurgeComm(CommHandle,(PURGE_RXABORT and PURGE_RXCLEAR));
      end;
     dwLength := FComStat.cbInQue;
     if (dwLength> 0) then
     begin
        fReadStat := ReadFile(CommHandle, InChar, 1, dwLength, nil);

        if (fReadStat) then
        begin
         if Assigned(FOnGetStr)then
              FOnGetStr(InChar);
        end;
        ASleep := 18;
     end;
     sleep(ASleep);
  end;
end;

constructor TCommThread.Create(AONGetStr :TONGetStrEvent);
begin
    FreeOnTerminate := TRUE;
    FOnGetStr:= AONGetStr;
    GetMem(FComStat,SizeOf(TComStat));
    inherited Create(FALSE);
end;
destructor TCommThread.Destroy;
begin
  FreeMem(FComStat);
  inherited Destroy;
end;

procedure Tfrmmain.StartCmdClick(Sender: TObject);
begin
  StartComm;
end;

procedure tfrmmain.DoOnGetStr(AChar: Char);
var
  S: string;
begin
  Memo1.Lines.Text := Memo1.Lines.Text + AChar;
  S := AChar;
  SendStr(S);
end;

procedure tfrmmain.StartComm;
var
  CommTimeOut : TCOMMTIMEOUTS;
  DCB : TDCB;
  fRetVal : Boolean;
  sPort: string;
begin
sPort := CSetupRec^.FPort;
OnGetStr := DoOnGetStr;
CommHandle := CreateFile(PChar(sPort),GENERIC_READ,0,nil,OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL
               , 0);
if CommHandle = 0 then
begin
   MsgBox('打开端口失败!('+ sPort+')');
   Exit;
end;
CommTimeOut.ReadIntervalTimeout := MAXDWORD;
CommTimeOut.ReadTotalTimeoutMultiplier := 0;
CommTimeOut.ReadTotalTimeoutConstant := 0;
SetCommTimeouts(CommHandle, CommTimeOut);
GetCommState(CommHandle,DCB);
DCB.BaudRate := CSetupRec^.FBaud; //9600;
DCB.ByteSize := CSetupRec^.FData;
DCB.Parity := C_Parity[CSetupRec^.FParity]; //ODDPARITY; //NOPARITY;
DCB.StopBits :=  C_Stopbits[CSetupRec^.FStopBit];  //ONESTOPBIT;
fRetVal := SetCommState(CommHandle, DCB);
if (fRetVal) then
  begin
    Connected := true;
    TCommThread.Create(FOnGetStr);
  end
  else
  begin
    MsgBox('端口初始化失败!('+ sPort+')');
    CloseHandle(CommHandle);
    Exit;
  end;

  StopCmd.Enabled := true;
  StartCmd.Enabled := false;
  TrayIco.Hint := Caption +'-'+ '通信监听中';
end;

procedure tfrmmain.EndComm;
begin
if Connected then
begin
   Connected := false;
   CloseHandle(CommHandle);
   StopCmd.Enabled := false;
   StartCmd.Enabled := true;
   TrayIco.Hint := Caption +'-'+ '已经停止监听';
end;
end;

procedure Tfrmmain.StopCmdClick(Sender: TObject);
begin
  EndComm;
end;

procedure Tfrmmain.BitBtn3Click(Sender: TObject);
begin
  ShowMessage('Copyright: 同享科技有限公司');
end;

procedure Tfrmmain.BitBtn4Click(Sender: TObject);
begin
  Close;
end;

procedure Tfrmmain.BitBtn2Click(Sender: TObject);
begin
  frmSetup := TfrmSetup.Create(nil);
  if frmSetup.ShowModal = mrOk then
  begin
    EndComm;
    StartComm;
  end;
  frmSetup.Release;
end;

procedure Tfrmmain.FormCreate(Sender: TObject);
begin
  Application.ShowMainForm := false;
  AutoLaunch_Add('COM口数据监听程序', ParamStr(0), 1);
  StartComm;
end;

procedure Tfrmmain.N4Click(Sender: TObject);
begin
if MsgBoxSel('确定要停退出监听程序吗?') then
begin
  Tag := 1;
  Close;
  AutoLaunch_Add('COM口数据监听程序', ParamStr(0), 0);
end;
end;

procedure Tfrmmain.N1Click(Sender: TObject);
begin
  Show;
end;

procedure Tfrmmain.N2Click(Sender: TObject);
begin
  Hide;
end;

procedure Tfrmmain.TrayIcoMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  SetForegroundWindow(Handle);
end;

procedure Tfrmmain.TrayIcoDblClick(Sender: TObject);
begin
  show;
end;

procedure Tfrmmain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  if tag = 0 then
  begin
    CanClose := false;
    Hide;
    Exit;
  end;
end;

end.

----------------------------------------------
www.acreport.com

作者：

shaoyy (远洋)	★☆☆☆☆	-
	盒子活跃会员

2004/4/18 16:00:53

2楼：

呵呵，干脆把源文件给你，里面有一个Rxtray的托盘控件，可以忽略的。

此帖子包含附件:shaoyy_200441816053.rar 大小:25.2K

----------------------------------------------
www.acreport.com

作者：

shaoyy (远洋)	★☆☆☆☆	-
	盒子活跃会员

2004/4/19 8:58:10

3楼：

有没搞定?
----------------------------------------------
www.acreport.com

作者：

skertone (奇奇怪)	★☆☆☆☆	-
	盒子活跃会员

2004/4/19 9:47:20

4楼：

这哥们是同享科技的，难怪拿出来同享了，呵呵，好

建议还是用组件还读写串口毕竟成熟又免费的组件很多啊

----------------------------------------------

作者：

wsk_hdp (wsk_hdp)	★☆☆☆☆	-
	盒子活跃会员

2004/4/19 10:19:33

5楼：

shaoyy同仁：
没有Trayico.dcu文件不能编译啊，有没有发个过来啊，急！@
----------------------------------------------
I love delphi

作者：

shaoyy (远洋)	★☆☆☆☆	-
	盒子活跃会员

2004/4/19 10:49:55

6楼：

to:skertone 小声点，偶一时太懒，没把公司名称删除，可不要让我的同事知道了啊!

to: wsk_hdp 删除所有与Trayico有关的代码就行，包括uses列表里的,不会有影响。
----------------------------------------------
www.acreport.com

作者：

wsk_hdp (wsk_hdp)	★☆☆☆☆	-
	盒子活跃会员

2004/4/19 11:00:48

7楼：

我删了，但是还是不行，运行不了，对了，能把你的QQ告诉我吗？
----------------------------------------------
I love delphi

作者：

shaoyy (远洋)	★☆☆☆☆	-
	盒子活跃会员

2004/4/19 11:06:35

8楼：

不会吧，自己看看哪些可以去掉的都去掉吧：

去掉SelfFunc,
procedure Tfrmmain.FormCreate(Sender: TObject);
begin
//  Application.ShowMainForm := false;                    //去掉两行
//  AutoLaunch_Add('COM口数据监听程序', ParamStr(0), 1);
  StartComm;
end;

我的QQ: 229481711

----------------------------------------------
www.acreport.com

作者：

fox7899 (fox7899)	★☆☆☆☆	-
	盒子活跃会员

2004/4/19 11:33:43

9楼：

好啊,可以学习学习,我现在有部分东西,有机会发到论坛上来
----------------------------------------------
-

信息

登陆以后才能回复