async32.~pas

delphi6.0电子寻更源程序,用来计算保安有无查抄

  Inherited Create(AOwner);
  FHandle := INVALID_HANDLE_VALUE;
  FDeviceName := DefaultDeviceName;
  FMonitorEvents := [evBreak, evCTS, evDSR, evError, evRing,
    evRlsd, evRxChar, evRxFlag, evTxEmpty];
  FOptions := [];
  FBaudRate := cbr9600;
  FParity := paNone;
  FStopbits := sb10;
  FDatabits := da8;
  FReadBufSize := 4096;
  FWriteBufSize := 2048;
  FCharsTimeout := 250;
  FFlowControl := fcDefault;
  FEventChars := TCommEventChars.Create(self);
end;

destructor TCustomComm.Destroy;
begin
  Close;
  FEventChars.Free;
  Inherited Destroy;
end;

function TCustomComm.Enabled: Boolean;
begin
  Result := FHandle <> INVALID_HANDLE_VALUE;
end;

procedure TCustomComm.CreateHandle;
begin
  FHandle := CreateFile(PCHAR(FDeviceName), GENERIC_READ or GENERIC_WRITE,
    0, nil, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0);

  if FHandle = INVALID_HANDLE_VALUE then
    RaiseCommError(SOpenError, GetLastError);

  if GetFileType(FHandle) <> FILE_TYPE_CHAR then
  begin
    DestroyHandle;
    RaiseCommError(SInvalidHandle, -1);
  end;
end;

procedure TCustomComm.DestroyHandle;
begin
  CloseHandle(FHandle);
  FHandle := INVALID_HANDLE_VALUE;
end;

procedure TCustomComm.Open;
var
  Size: Integer;
begin
  Close;

  SetLastError(0);

  CreateHandle;

  if Enabled then
  begin
    FCommEventThread := TCommEventThread.Create(FHandle, FMonitorEvents);
    FCommEventThread.OnSignal := HandleCommEvent;

    Size := Sizeof(TCommConfig);
    GetCommConfig(FHandle, FCommConfig,DWORD(Size));

    UpdateDataControlBlock;

    if not SetupComm(FHandle, FReadBufSize, FWriteBufSize) then
      RaiseCommError(SSetupCommErr, GetLastError);

    SetCharsTimeout(FCharsTimeout);
  end;
end;

procedure TCustomComm.Close;
begin
  if Enabled then
  begin
    if FCommEventThread <> nil then
    begin
      FCommEventThread.ReleaseThread;
      FCommEventThread.WaitFor;
      FCommEventThread.Free;
      FCommEventThread := nil;
    end;
    FCommConfig.dwProviderSubtype := -1;
    DestroyHandle;
  end;
end;

function TCustomComm.Write(const Buf; Count: Integer): Integer;
begin
  FillChar(FWriteOS, Sizeof(FWriteOS), 0);
  if not WriteFile(FHandle, Buf, Count, Result, @FWriteOS) then Result := -1;
end;

function TCustomComm.Read(var Buf; Count: Integer): Integer;
begin
  FillChar(FReadOS, Sizeof(FReadOS), 0);
  if not ReadFile(FHandle, Buf, Count, Result, @FReadOS) then Result := -1;
end;

procedure TCustomComm.EventStateChange(Event: Integer);
begin
  case Event of
    EV_BREAK:
      if assigned(FOnBreak) then FOnBreak(self);
    EV_CTS:
      if assigned(FOnCTS) then FOnCTS(self);
    EV_DSR:
      if assigned(FOnDSR) then FOnDSR(self);
    EV_ERR:
      if assigned(FOnError) then FOnError(self, FErrors);
    EV_RING:
      if assigned(FOnRing) then FOnRing(self);
    EV_RLSD:
      if assigned(FOnRLSD) then FOnRLSD(self);
    EV_RXCHAR:
      if assigned(FOnRxChar) then FOnRxChar(self, FComStat.cbInQue);
    EV_RXFLAG:
      if assigned(FOnRxFlag) then FOnRxFlag(self);
    EV_TXEMPTY:
      if assigned(FOnTxEmpty) then FOnTxEmpty(self);
  end;
end;

procedure TCustomComm.HandleCommEvent(Sender: TObject; Status: dword);
var
  EvIndex: TCommEventState;
begin
  ClearCommError(FHandle, FErrors, @FComStat);
  for EvIndex := evBREAK to evTXEMPTY do
    if Status and CommEventList[EvIndex] > 0 then
      EventStateChange(CommEventList[EvIndex]);
end;

procedure TCustomComm.UpdateDataControlBlock;
var
  OptIndex: TCommOption;
begin
  if Enabled then
  begin
    GetCommState(FHandle, FDCB);
    FDCB.BaudRate := CommBaudRates[FBaudRate];
    FDCB.Parity := CommParity[FParity];
    FDCB.Stopbits := CommStopbits[FStopbits];
    FDCB.Bytesize := CommDatabits[FDatabits];
    FDCB.XonChar := FEventChars.XonChar;
    FDCB.XoffChar := FEventChars.XOffChar;
    FDCB.XonLim := FReadBufSize div 4;
    FDCB.XoffLim := FReadBufSize div 4;

    ConfigureHandshaking(FDCB);

    for OptIndex := coParityCheck to coNullStrip do
      if OptIndex in FOptions then FDCB.Flags := FDCB.Flags or CommOptions[OptIndex]
        else FDCB.Flags := FDCB.Flags and not CommOptions[OptIndex];
    if not SetCommState(FHandle, FDCB) then
      RaiseCommError(SUpdateDCBErr, GetLastError);
  end;
end;

procedure TCustomComm.SetDeviceName(Value: string);
begin
  if Enabled then
    RaiseCommError(SPortAssigned, -1);
  FDeviceName := Value;
end;

procedure TCustomComm.SetMonitorEvents(Value: TCommEventType);
begin
  if Enabled then
    RaiseCommError(SPortAssigned, -1);
  FMonitorEvents := Value;
end;

procedure TCustomComm.SetBaudRate(Value: TBaudRate);
begin
  if FBaudRate <> Value then
  begin
    FBaudRate := Value;
    UpdateDataControlBlock;
  end;
end;

procedure TCustomComm.SetParity(Value: TParity);
begin
  if FParity <> Value then
  begin
    FParity := Value;
    UpdateDataControlBlock;
  end;
end;

procedure TCustomComm.SetStopbits(Value: TStopbits);
begin
  if FStopBits <> Value then
  begin
    FStopbits := Value;
    UpdateDataControlBlock;
  end;
end;

procedure TCustomComm.SetDataBits(Value: TDatabits);
begin
  if FDataBits <> Value then
  begin
    FDataBits:=Value;
    UpdateDataControlBlock;
  end;
end;

procedure TCustomComm.SetReadBufSize(Value: Integer);
begin
  if Enabled then
    RaiseCommError(SPortAssigned, -1);
  FReadBufSize := Value;
end;

procedure TCustomComm.SetWriteBufSize(Value: Integer);
begin
  if Enabled then
    RaiseCommError(SPortAssigned, -1);
  FWriteBufSize := Value;
end;

procedure TCustomComm.SetCharsTimeout(Value: Integer);
var
  CommTimeouts: TCommTimeouts;
begin
  FCharsTimeOut := Value;
  if Enabled then
  begin
    FillChar(CommTimeOuts, Sizeof(CommTimeOuts), 0);
    if (FCharsTimeOut = 0) then
      CommTimeouts.ReadIntervalTimeout := MAXDWORD
    else CommTimeouts.ReadIntervalTimeout := FCharsTimeOut;

   //If you notice some strange behaviour after writing to the
   //port, try different values below for WriteTimeOut values.
//   CommTimeouts.WriteTotalTimeoutConstant := 7000;
   CommTimeouts.WriteTotalTimeoutConstant := 0;
   CommTimeouts.WriteTotalTimeoutMultiplier:=0;
    if not SetCommTimeOuts(FHandle, CommTimeOuts) then
      RaiseCommError(SCommTimeoutsErr, GetLastError);
  end;
end;

procedure TCustomComm.SetOptions(Value: TCommOptions);
begin
  if FOptions <> Value then
  begin
    FOptions := Value;
    UpdateDataControlBlock;
  end;
end;

procedure TCustomComm.SetFlowControl(Value: TFlowControl);
begin
  if FFlowControl <> Value then
  begin
    FFlowControl := Value;
    UpdateDataControlBlock;
  end;
end;

function TCustomComm.InQueCount: Integer;
var
  ComStat: TComStat;
  Errors: dword;
begin
  if Enabled then
  begin
    ClearCommError(FHandle, Errors, @ComStat);
    Result := ComStat.cbInQue;
  end else Result := -1;
end;

function TCustomComm.OutQueCount: Integer;
var
  ComStat: TComStat;
  Errors: dword;
begin
  if Enabled then
  begin
    ClearCommError(FHandle, Errors, @ComStat);
    Result := ComStat.cbOutQue;
  end else Result := -1;
end;

procedure TCustomComm.PurgeIn;
begin
  if Enabled then
    PurgeComm(FHandle, PURGE_RXABORT or PURGE_RXCLEAR);
end;

procedure TCustomComm.PurgeOut;
begin
  if Enabled then
    PurgeComm(FHandle, PURGE_TXABORT or PURGE_TXCLEAR);
end;

function TCustomComm.GetModemState(Index: Integer): boolean;
var
  Flag, State: dword;
begin
  case Index of
    1: State := MS_CTS_ON;
    2: State := MS_DSR_ON;
    3: State := MS_RING_ON;
    4: State := MS_RLSD_ON;
    else
      State := 0;
  end;
  Result := false;
  if Enabled then
    if GetCommModemStatus(FHandle, Flag) then
      Result := (Flag and State > 0);
end;

procedure TCustomComm.EscapeComm(Flag: Integer);
var
  Escaped: Boolean;
begin
  if Enabled then
  begin
    Escaped := EscapeCommFunction(FHandle, Flag);
    if not Escaped then
      RaiseCommError(SEscFuncError, GetLastError);
  end else RaiseCommError(SPortNotOpen, -1);
end;

procedure TCustomComm.SetDTRState(State: boolean);
const
  DTR: array[boolean] of Integer = (CLRDTR, SETDTR);
begin
  EscapeComm(DTR[State]);
end;

procedure TCustomComm.SetRTSState(State: boolean);
const
  RTS: array[boolean] of Integer = (CLRRTS, SETRTS);
begin
  EscapeComm(RTS[State]);
end;

procedure TCustomComm.SetBREAKState(State: Boolean);
const
  BREAK: array[boolean] of Integer = (CLRBREAK, SETBREAK);
begin
  EscapeComm(BREAK[State]);
  if Enabled then
    PurgeComm(FHandle, PURGE_RXABORT + PURGE_RXCLEAR +
      PURGE_TXABORT + PURGE_TXCLEAR);
end;

procedure TCustomComm.SetXONState(State: Boolean);
const
  XON: array[boolean] of Integer = (SETXOFF, SETXON);
begin
  EscapeComm(XON[State]);
end;

procedure TCustomComm.ConfigureHandshaking(var DCB: TDCB);
begin
  if FFlowControl <> fcDefault then
  begin
    DCB.Flags := DCB.Flags and (not fOutxCtsFlow);
    DCB.Flags := DCB.Flags and (not fRtsControl) or (RTS_CONTROL_TOGGLE shl 12);
    DCB.Flags := DCB.Flags and (not fOutxDsrFlow);
    DCB.Flags := DCB.Flags and (not fDtrControl) or (DTR_CONTROL_ENABLE shl 4);
    DCB.Flags := DCB.Flags and (not fOutX) and (not fInX);
  end;

  case FFlowControl of
    fcCTS:
      DCB.Flags := DCB.Flags or fOutxCtsFlow;
    fcDTR:
      DCB.Flags := DCB.Flags or fOutxDsrFlow;
    fcSoftware:
      DCB.Flags := DCB.Flags or fOutX or fInX;
  end;
end;

function TCustomComm.GetProviderSubtype: Integer;
begin
  Result := FCommConfig.dwProviderSubType;
end;


procedure Register;
begin
  RegisterComponents('Varian Freeware', [TComm]);
end;

end.