On Mon, 30 Jun 2003 16:24:22 +0200, "Kasper" <re****@hotmail .com>
wrote:
Hey
do you have some api code there can use the comport with any baudrate ?
Don't know about _any_ Baud Rate
For what it is worth this stuff is working Ok
It is highly targeted at one device :-
===== Start of Class ====
Option Explicit: DefObj A-Z
Private Type TCMN
ID As Integer
hFile As Long
Port As String
End Type
' Note: Raise DTR to power on printer
' See POWER OFF COMMAND in manual
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const FILE_FLAG_OVERL APPED = &H40000000
Private Const INVALID_HANDLE_ VALUE = -1
Private Const RTS_CONTROL_DIS ABLE = &H0
Private Const RTS_CONTROL_ENA BLE = &H1
Private Const RTS_CONTROL_HAN DSHAKE = &H2
Private Const DTR_CONTROL_DIS ABLE = &H0
Private Const DTR_CONTROL_ENA BLE = &H1
Private Const DTR_CONTROL_HAN DSHAKE = &H2
Private Const NOPARITY = 0
Private Const ONESTOPBIT = 0
Private Const EV_BREAK = &H40
Private Const EV_CTS = &H8
Private Const EV_DSR = &H10
Private Const EV_ERR = &H80
Private Const EV_EVENT1 = &H800
Private Const EV_EVENT2 = &H1000
Private Const EV_PERR = &H200
Private Const EV_RING = &H100
Private Const EV_RLSD = &H20
Private Const EV_RX80FULL = &H400
Private Const EV_RXCHAR = &H1
Private Const EV_RXFLAG = &H2
Private Const EV_TXEMPTY = &H4
Private Const COMM_MASK = EV_CTS Or EV_DSR _
Or EV_ERR Or EV_RXCHAR _
Or EV_RING
Private Const PURGE_RXCLEAR = &H8
Private Const PURGE_TXCLEAR = &H4
Private Const PURGE_TXABORT = &H1
Private Const PURGE_RXABORT = &H2
Private Const ERROR_IO_PENDIN G = 997
Private Type DCB
DCBlength As Long
BaudRate As Long
fBinary As Long
fParity As Long
fOutxCtsFlow As Long
fOutxDsrFlow As Long
fDtrControl As Long
fDsrSensitivity As Long
fTXContinueOnXo ff As Long
fOutX As Long
fInX As Long
fErrorChar As Long
fNull As Long
fRtsControl As Long
fAbortOnError As Long
fDummy2 As Long
wReserved As Integer
XonLim As Integer
XoffLim As Integer
ByteSize As Byte
Parity As Byte
StopBits As Byte
XonChar As Byte
XoffChar As Byte
ErrorChar As Byte
EofChar As Byte
EvtChar As Byte
wReserved1 As Integer ' reserved; do not use
End Type
Private Type COMMTIMEOUTS
ReadIntervalTim eout As Long
ReadTotalTimeou tMultiplier As Long
ReadTotalTimeou tConstant As Long
WriteTotalTimeo utMultiplier As Long
WriteTotalTimeo utConstant As Long
End Type
Private Type OVERLAPPED
Internal As Long
InternalHigh As Long
Offset As Long
OffsetHigh As Long
hEvent As Long
End Type
Private Declare Function BuildCommDCB _
Lib "kernel32" _
Alias "BuildCommD CBA" (ByVal _
lpDef As String, lpDCB _
As DCB) As Long
Private Declare Function CreateFile _
Lib "kernel32" _
Alias "CreateFile A" _
(ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, _
ByVal lpSecurityAttri butes As Long, _
ByVal dwCreationDispo sition As Long, _
ByVal dwFlagsAndAttri butes As Long, _
ByVal hTemplateFile As Long) As Long
Private Declare Function GetCommState Lib "kernel32" ( _
ByVal hFile As Long, _
lpDCB As DCB) As Long
Private Declare Function SetCommState Lib "kernel32" ( _
ByVal hFile As Long, _
lpDCB As DCB) As Long
Private Declare Function SetupComm Lib "kernel32" ( _
ByVal hFile As Long, _
ByVal dwInQueue As Long, _
ByVal dwOutQueue As Long) As Long
Private Declare Function SetCommTimeouts _
Lib "kernel32" _
(ByVal hFile As Long, _
lpCommTimeouts As COMMTIMEOUTS) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
ByVal hObject As Long) As Long
Private Declare Function PurgeComm Lib "kernel32" ( _
ByVal hFile As Long, _
ByVal dwFlags As Long) As Long
Private Declare Function SetCommMask Lib "kernel32" ( _
ByVal hFile As Long, _
ByVal dwEvtMask As Long) As Long
Private Declare Function WaitCommEvent Lib "kernel32" ( _
ByVal hFile As Long, _
lpEvtMask As Long, _
lpOverlapped As Any) As Long
Private Declare Function CreateEvent Lib "kernel32" Alias
"CreateEven tA" ( _
ByVal lpEventAttribut es As Long, _
ByVal bManualReset As Long, _
ByVal bInitialState As Long, _
ByVal lpName As String) As Long
Private Declare Function WriteFile Lib "kernel32" ( _
ByVal hFile As Long, _
lpBuffer As Any, _
ByVal nNumberOfBytesT oWrite As Long, _
lpNumberOfBytes Written As Long, _
lpOverlapped As Any) As Long
Private Declare Function ReadFile Lib "kernel32" ( _
ByVal hFile As Long, _
ByVal lpBuffer As String, _
ByVal nNumberOfBytesT oRead As Long, _
lpNumberOfBytes Read As Long, _
lpOverlapped As Any) As Long
Private Declare Function ReadFileEx Lib "kernel32" ( _
ByVal hFile As Long, _
lpBuffer As Any, _
ByVal nNumberOfBytesT oRead As Long, _
lpOverlapped As OVERLAPPED, _
ByVal lpCompletionRou tine As Long) As Long
Private Declare Sub Sleep Lib "kernel32" ( _
ByVal dwMilliseconds As Long)
Private Declare Function EscapeCommFunct ion Lib "kernel32" ( _
ByVal nCid As Long, _
ByVal nFunc As Long) As Long
Private Declare Function GetCommModemSta tus Lib "kernel32" ( _
ByVal hFile As Long, _
lpModemStat As Long) As Long
Private Const MS_CTS_ON = &H10&
Private Const MS_DSR_ON = &H20&
Private Const MS_RING_ON = &H40&
Private Const MS_RLSD_ON = &H80&
Private Const CLRDTR = 6 ' Clears the DTR (data-terminal-ready)
signal.
Private Const CLRRTS = 4 ' Clears the RTS (request-to-send) signal.
Private Const SETDTR = 5 ' Sends the DTR (data-terminal-ready) signal.
Private Const SETRTS = 3 ' Sends the RTS (request-to-send) signal.
Private cmn As TCMN
' =============== =============== =============== ===============
'
'
'
Public Function OpenCommErr(Por tNo%, Erm$) As Boolean
OpenCommErr = True
Erm$ = ""
cmn.Port$ = "COM" + Trim$(Str$(Port No))
If cmn.hFile <> 0 Then
Erm$ = cmn.Port$ + " is Already Open - Closing it"
Call CloseCommErr("" )
Exit Function
End If
cmn.hFile = CreateFile(cmn. Port$, _
GENERIC_WRITE Or GENERIC_READ, _
0, _
0, _
OPEN_EXISTING, _
0, 0)
If cmn.hFile = INVALID_HANDLE_ VALUE Then
Erm$ = "Error opening " + cmn.Port$
cmn.hFile = 0
Exit Function
End If
If LF_FailSetupCom m(Erm$) Then
Erm$ = "OpenComm: " + Erm$
Exit Function
End If
OpenCommErr = False
End Function
'
'
'
Private Function LF_FailSetupCom m(Erm$) As Boolean
Dim D As DCB, cto As COMMTIMEOUTS
Dim lRet&, Status&
LF_FailSetupCom m = True
Erm$ = ""
D.DCBlength = Len(D)
If GetCommState(cm n.hFile, D) = 0 Then
Erm$ = "Error Getting " + cmn.Port$ + " parameters"
Exit Function
End If
' ---
'd.DCBlength = Len(d)
D.BaudRate = 19200
D.fBinary = 1
D.fParity = 0
D.ByteSize = 8
D.Parity = NOPARITY
D.StopBits = ONESTOPBIT
D.fOutxCtsFlow = 0 ' CTS On
D.fOutxDsrFlow = 0 ' DSR Off ??
'D.fDtrControl = DTR_CONTROL_ENA BLE
D.fDtrControl = DTR_CONTROL_DIS ABLE
D.fDsrSensitivi ty = 0 ' - 5/10/02
D.fTXContinueOn Xoff = 0
D.fOutX = 0 ' XOn - Off
D.fInX = 0
D.fErrorChar = 0
D.fNull = 0
D.fRtsControl = RTS_CONTROL_DIS ABLE ' RTS On
'D.fRtsControl = RTS_CONTROL_ENA BLE
D.fAbortOnError = 0
'd.fDummy2 = 0
'd.wReserved = 0
'd.XonLim = 0
'd.XoffLim = 0
'd.XonChar = 255
'd.XoffChar = 254
'd.ErrorChar = 0
'd.EofChar = 0
'd.EvtChar = 0
lRet = BuildCommDCB("b aud=19200 parity=N data=8 stop=1", D)
If lRet = 0 Then
Erm$ = "Error Setting Com State"
Exit Function
End If
If SetCommState(cm n.hFile, D) = 0 Then
Erm$ = "Error setting " + cmn.Port$ + " parameters"
Exit Function
End If
' --- In Out Buffer sizes
If SetupComm(cmn.h File, 256, 256) = 0 Then
Erm$ = "Error on API SetupComm()"
Exit Function
End If
' Setup Timeouts in Milliseconds
cto.ReadInterva lTimeout = 100
cto.ReadTotalTi meoutConstant = 100 ' TIMEOUT_CONSTAN T
cto.ReadTotalTi meoutMultiplier = 10 ' TIMEOUT_MULTIPL IER
cto.WriteTotalT imeoutMultiplie r = 10
cto.WriteTotalT imeoutConstant = 100
If SetCommTimeouts (cmn.hFile, cto) = 0 Then
Erm$ = "Error setting " + cmn.Port$ + " timeouts"
Exit Function
End If
Call PurgeComm(cmn.h File, PURGE_RXCLEAR)
Call PurgeComm(cmn.h File, PURGE_TXCLEAR)
Call PurgeComm(cmn.h File, PURGE_RXABORT)
Call PurgeComm(cmn.h File, PURGE_TXABORT)
If GetCommModemSta tus(cmn.hFile, Status) = 0 Then
Erm$ = "Failed GetCommModemSta tus()"
Exit Function
End If
' --- Good Exit
LF_FailSetupCom m = False
End Function
' =============== =============== =============== ===============
'
' CLRDTR Clears the DTR (data-terminal-ready) signal.
' CLRRTS Clears the RTS (request-to-send) signal.
' SETDTR Sends the DTR (data-terminal-ready) signal.
' SETRTS Sends the RTS (request-to-send) signal.
Private Function LF_WakePrinterE rr(Erm$) As Boolean
Dim Status&, Count%
LF_WakePrinterE rr = True
' ---
If cmn.hFile = 0 Then
Erm$ = "Printer is NOT Open"
Exit Function
End If
Erm$ = "Failed To Wake Printer"
RETRY:
If GetCommModemSta tus(cmn.hFile, Status) = 0 Then
Erm$ = "Failed GetCommModemSta tus()"
Exit Function
End If
' --- DSR On means printer is online
If (Status And MS_DSR_ON) = MS_DSR_ON Then
LF_WakePrinterE rr = False
Erm$ = ""
Exit Function
End If
Count = Count + 1
If Count > 3 Then Exit Function
Call DtrOff("")
Sleep 100
Call DtrOn("") ' Raise DTR should raise DSR
Sleep 1000 ' this seems to be needed 22/11/02
GoTo RETRY
End Function
' =============== =============== =============== ===============
'
'
Public Sub DtrOn(Erm$)
Erm$ = ""
If EscapeCommFunct ion(cmn.hFile, SETDTR) = 0 Then
Erm$ = "Failed EscapeCommFunct ion() SETDTR"
End If
End Sub
Public Sub DtrOff(Erm$)
Erm$ = ""
If EscapeCommFunct ion(cmn.hFile, CLRDTR) = 0 Then
Erm$ = "Failed EscapeCommFunct ion() CLRDTR"
End If
End Sub
' =============== =============== =============== ===============
'
' Write String to Com Port
'
Public Function WriteCommErr(Da ta$, Erm$) As Boolean
Dim Res&, BytesWritten&
Dim L9&, Nix$, S As String * 1
Erm$ = ""
WriteCommErr = True
If LF_WakePrinterE rr(Erm$) Then
Erm$ = "WriteComm: " + Erm$
Exit Function
End If
For L9 = 1 To Len(Data$)
LSet S$ = Mid$(Data$, L9, 1)
If LF_CTS_On(Erm$) = False Then
Exit Function
End If
Res = WriteFile(cmn.h File, ByVal S$, Len(S$), BytesWritten, 0)
' ---
If BytesWritten <> 1 Then Exit For
If Res = 0 Then Exit For
Next
If Res = 0 Then
Erm$ = "WriteComm: Error Writing to Comm"
Exit Function
End If
If BytesWritten <> 1 Then
Erm$ = "WriteComm: Error Bytes written incorrect"
Exit Function
End If
WriteCommErr = False
End Function
'
' --- Return when CTS is On - or return Failure
'
Private Function LF_CTS_On(Erm$) As Boolean
Dim Status&, Count%
AGAIN:
If GetCommModemSta tus(cmn.hFile, Status) = 0 Then
Erm$ = "Failed GetCommModemSta tus"
Exit Function
End If
' ---
If Status And MS_CTS_ON Then
LF_CTS_On = True
Exit Function
End If
' ---
Count = Count + 1
Sleep 100 ' Was Sleep 10 21/3/03
DoEvents
If Count < 500 Then ' Was Count < 20
GoTo AGAIN
End If
Erm$ = "Write Comm: CTS Failure"
End Function
' =============== =============== =============== ===============
'
' Read one Char - or ""
'
Public Function ReadCommChar$(E rm$)
Dim Char As String * 1
Dim Count&
Erm$ = ""
If LF_WakePrinterE rr(Erm$) Then
Erm$ = "Read Comm: " + Erm$
Exit Function
End If
Call Sleep(10)
DoEvents
Call ReadFile(cmn.hF ile, Char$, 1, Count&, 0)
If Count Then
ReadCommChar$ = Char$
End If
End Function
' =============== =============== =============== ===============
'
'
'
Public Function CloseCommErr(Er m$) As Boolean
If cmn.hFile = 0 Then Exit Function
If CloseHandle(cmn .hFile) = 0 Then
Erm$ = "Error Closing Comm"
CloseCommErr = True
End If
cmn.hFile = 0
End Function
Private Sub Class_Initializ e()
cmn.ID = TSDebug.RegObj( "cZPrint")
End Sub
Private Sub Class_Terminate ()
Call Me.CloseCommErr ("")
TSDebug.UnRegOb j cmn.ID
End Sub
