main.~pas

com和tcpip的转发程序

unit main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, RzButton, StdCtrls, RzEdit, ExtCtrls, RzPanel, RzSplit,
  TFlatComboBoxUnit, CPortCtl, CPort, ComCtrls, RzSpnEdt, Mask, ScktComp,
  RzLabel, RzRadChk, RzCmboBx, SPComm;

type
  TFormMain = class(TForm)
    RzSizePanel1: TRzSizePanel;
    RzGroupBox1: TRzGroupBox;
    RzBtnOpenClose: TRzButton;
    RzGroupBox2: TRzGroupBox;
    RzRichEdit: TRzRichEdit;
    Label6: TLabel;
    Label7: TLabel;
    RzBtnConnect: TRzButton;
    LEDConnect: TShape;
    ClientSocket: TClientSocket;
    RzGroupBox3: TRzGroupBox;
    RzCheckBoxHex: TRzCheckBox;
    RzGroupBox4: TRzGroupBox;
    Label8: TLabel;
    Label9: TLabel;
    RzLabelSendSocket: TRzLabel;
    RzLabelSendSerial: TRzLabel;
    RzBtnClear: TRzButton;
    RzNumEdit: TRzNumericEdit;
    RzEdit: TRzEdit;
    RzCheckBoxDisplay: TRzCheckBox;
    Comm: TComm;
    Label1: TLabel;
    Label2: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label3: TLabel;
    Label10: TLabel;
    RzCbBoxPort: TRzComboBox;
    RzCbBoxBand: TRzComboBox;
    RzCbBoxData: TRzComboBox;
    RzCbBoxParity: TRzComboBox;
    FlatCbBoxStop: TRzComboBox;
    RzSEditTimeOut: TRzSpinEdit;
    LEDOpen: TShape;
    procedure RzBtnConnectClick(Sender: TObject);
    procedure ClientSocketConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ClientSocketDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure FormCreate(Sender: TObject);
    procedure RzBtnOpenCloseClick(Sender: TObject);
    procedure RzBtnClearClick(Sender: TObject);
    procedure ClientSocketRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure ClientSocketError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure ComComboBox1Change(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure RzCbBoxPortChange(Sender: TObject);
    procedure CommReceiveData(Sender: TObject; Buffer: Pointer;
      BufferLength: Word);
  private
    FConnected: boolean;
    SendSerialByte: integer;
    SendSocketByte: integer;
    procedure AddMessage(color: TColor; Msg: string);
    procedure SocketConnect(connected: boolean);
    procedure SerialConnect(connected: boolean);
    procedure ToSerial(str: string);
    procedure ToSocket(str: string);
    procedure ApplySettings();
    procedure EnumComPorts(Ports: TStrings);
    { Private declarations }
  public
    { Public declarations }
  end;

function StrToHex(Str:string):string;
function ByteToHexStr(Data: Byte): string;

var
  FormMain: TFormMain;
const
  HexChars: array[0..15] of Char =
    ('0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B',
    'C', 'D', 'E', 'F');
    
implementation

{$R *.dfm}

    
function ByteToHexStr(Data: Byte):string;
var
  ch1:char;
  ch2:char;
begin
  ch1 := HexChars[Data and $0f];
  ch2 := HexChars[Data shr 4];
  result := ch2 + ch1;
end;

function StrToHex(Str:string):string;
var
  ptr: PChar;
  i: integer;
  j: integer;
begin
  ptr := PChar(Str);
  j := Length(Str) - 1;
  for i:=0 to j do
  begin
    Result := Result + ByteToHexStr(Byte(ptr[i])) + ' ';
  end;
end;

procedure TFormMain.AddMessage(color: TColor; Msg: string);
//var
 // tempcolor: TColor;
begin
 // RzRichEdit.JumpTo(RzRichEdit.Lines.Count-1, 0);
//  RzRichEdit.SelLength := 0;
  //tempcolor := RzRichEdit.SelAttributes.Color;
  //RzRichEdit.DefAttributes.Color := color;
  RzRichEdit.SelAttributes.Color := color;
  RzRichEdit.Lines.Add(Msg);
 // RzRichEdit.DefAttributes.Color := tempcolor;
 // RzRichEdit.SelAttributes.Color := tempcolor;
end;

procedure TFormMain.RzBtnConnectClick(Sender: TObject);
begin
  try
    ClientSocket.Port := RzNumEdit.Intvalue;
    ClientSocket.Host := RzEdit.Text;
    ClientSocket.Active := not ClientSocket.Active;
  except
    AddMessage(clRed, '系统：无法连接到服务器');
  end;
end;

procedure TFormMain.SocketConnect(connected: boolean);
begin
  if connected then
  begin
    LEDConnect.Brush.Color := clGreen;
    RzBtnConnect.Caption := '断开';
    AddMessage(clRed, '系统：已连接到服务器');
  end
  else
  begin
   LEDConnect.Brush.Color := clSilver;
   RzBtnConnect.Caption := '连接';
   AddMessage(clRed, '系统：已从服务器断开');
  end;
end;

procedure TFormMain.ClientSocketConnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  SocketConnect(true);
end;

procedure TFormMain.ClientSocketDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  SocketConnect(false);
end;

procedure TFormMain.ToSerial(str: string);
var
  tempStr: string;
begin
  if RzCheckBoxDisplay.Checked then
  begin
    if FConnected then
      tempStr := '网络->串口'
    else
      tempStr := '网络收到';
    tempStr := tempStr + '('+IntToStr(Length(Str))+'):';
    if RzCheckBoxHex.Checked then
      tempStr := tempStr + StrToHex(str)
    else
      tempStr := tempStr + str;
    AddMessage(clblue, tempStr);
  end;
  if FConnected then
  begin
    SendSerialByte := SendSerialByte + Length(str);
    RzLabelSendSerial.Caption := IntToStr(SendSerialByte)+'字节';
    Comm.WriteCommData(pchar(str), length(str));
  end;
end;

procedure TFormMain.ToSocket(str: string);
var
  tempStr: string;
begin
  if RzCheckBoxDisplay.Checked then
  begin
    if ClientSocket.Active then
      tempStr := '串口->网络'
    else
      tempStr := '串口收到';
    tempStr := tempStr + '('+IntToStr(Length(Str))+'):';
    if RzCheckBoxHex.Checked then
      tempStr := tempStr + StrToHex(str)
    else
      tempStr := tempStr + str;
    AddMessage(clGreen, tempStr);
  end;
  if ClientSocket.Active then
  begin
    SendSocketByte := SendSocketByte + Length(str);
    RzLabelSendSocket.Caption := IntToStr(SendSocketByte) + '字节';
    ClientSocket.Socket.SendText(str);
  end;
end;

procedure TFormMain.FormCreate(Sender: TObject);
begin
  SendSerialByte := 0;
  SendSocketByte := 0;
  EnumComPorts(RzCbBoxPort.Items);
  if RzCbBoxPort.Items.Count > 0 then
    RzCbBoxPort.ItemIndex := 0;
  FConnected := false;
  ApplySettings;
end;

procedure TFormMain.SerialConnect(connected: boolean);
begin
  try
    FConnected := connected;
    if FConnected then
    begin
      Comm.StartComm;
      LEDOpen.Brush.Color := ClGreen;
      RzBtnOpenClose.Caption := '关闭';
      AddMessage(clRed, '系统：成功打开串口');
    end
    else
    begin
      Comm.StopComm;
      LEDOpen.Brush.Color := clSilver;
      RzBtnOpenClose.Caption := '打开';
      AddMessage(clRed, '系统：成功关闭串口');
    end;
  except
    FConnected := false;
    AddMessage(clRed, '系统：无法操作串口');
  end;
end;

procedure TFormMain.RzBtnOpenCloseClick(Sender: TObject);
begin
  SerialConnect(FConnected);
end;

procedure TFormMain.RzBtnClearClick(Sender: TObject);
begin
  RzRichEdit.Clear;
end;

procedure TFormMain.ClientSocketRead(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  ToSerial(Socket.ReceiveText);
end;

procedure TFormMain.ClientSocketError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
begin
  AddMessage(clRed, '系统：'+ SysErrorMessage(ErrorCode));
  ErrorCode := 0;
end;

procedure TFormMain.ComComboBox1Change(Sender: TObject);
begin
 (Sender as TComComboBox).ApplySettings;
end;

procedure TFormMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Comm.StopComm;
  ClientSocket.Active := false;
end;

procedure TFormMain.ApplySettings;
begin
  Comm.CommName := RzCbBoxPort.Text;
  Comm.BaudRate := StrToInt(RzCbBoxBand.Text);
  case RzCbBoxData.ItemIndex of
    0: Comm.ByteSize := _5;
    1: Comm.ByteSize := _6;
    2: Comm.ByteSize := _7;
    3: Comm.ByteSize := _8;
  end;
  case RzCbBoxParity.ItemIndex of
    0: Comm.Parity := None;
    1: Comm.Parity := Odd;
    2: Comm.Parity := Even;
    3: Comm.Parity := Mark;
    4: Comm.Parity := Space;
  end;
  case FlatCbBoxStop.ItemIndex of
    0: Comm.StopBits := _1;
    1: Comm.StopBits := _1_5;
    2: Comm.StopBits := _2;
  end;
  Comm.ReadIntervalTimeout := Trunc(RzSEditTimeOut.Value);
end;

procedure TFormMain.EnumComPorts(Ports: TStrings);
var
  KeyHandle: HKEY;
  ErrCode, Index: Integer;
  ValueName, Data: string;
  ValueLen, DataLen, ValueType: DWORD;
  TmpPorts: TStringList;
begin
  ErrCode := RegOpenKeyEx(
    HKEY_LOCAL_MACHINE,
    'HARDWARE\DEVICEMAP\SERIALCOMM',
    0,
    KEY_READ,
    KeyHandle);

  if ErrCode <> ERROR_SUCCESS then
    raise Exception.Create('读取串口参数错误');

  TmpPorts := TStringList.Create;
  try
    Index := 0;
    repeat
      ValueLen := 256;
      DataLen := 256;
      SetLength(ValueName, ValueLen);
      SetLength(Data, DataLen);
      ErrCode := RegEnumValue(
        KeyHandle,
        Index,
        PChar(ValueName),
{$IFDEF DELPHI_4_OR_HIGHER}
        Cardinal(ValueLen),
{$ELSE}
        ValueLen,
{$ENDIF}
        nil,
        @ValueType,
        PByte(PChar(Data)),
        @DataLen);

      if ErrCode = ERROR_SUCCESS then
      begin
        SetLength(Data, DataLen - 1);
        TmpPorts.Add(Data);
        Inc(Index);
      end
      else
        if ErrCode <> ERROR_NO_MORE_ITEMS then
          raise Exception.Create('读取串口参数错误');

    until (ErrCode <> ERROR_SUCCESS) ;

    TmpPorts.Sort;
    Ports.Assign(TmpPorts);
  finally
    RegCloseKey(KeyHandle);
    TmpPorts.Free;
  end;

end;

procedure TFormMain.RzCbBoxPortChange(Sender: TObject);
begin
  SerialConnect(false);
  ApplySettings;
  SerialConnect(true);
end;

procedure TFormMain.CommReceiveData(Sender: TObject; Buffer: Pointer;
  BufferLength: Word);
var
  str: string;
begin
  SetLength(str, BufferLength);
  move(Buffer^, pchar(str)^, BufferLength);
  ToSocket(str);
end;

end.