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_OVERLAPPED = &H40000000
Private Const INVALID_HANDLE_VALUE = -1
Private Const RTS_CONTROL_DISABLE = &H0
Private Const RTS_CONTROL_ENABLE = &H1
Private Const RTS_CONTROL_HANDSHAKE = &H2
Private Const DTR_CONTROL_DISABLE = &H0
Private Const DTR_CONTROL_ENABLE = &H1
Private Const DTR_CONTROL_HANDSHAKE = &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_PENDING = 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
fTXContinueOnXoff 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
ReadIntervalTimeout As Long
ReadTotalTimeoutMultiplier As Long
ReadTotalTimeoutConstant As Long
WriteTotalTimeoutMultiplier As Long
WriteTotalTimeoutConstant 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 "BuildCommDCBA" (ByVal _
lpDef As String, lpDCB _
As DCB) As Long
Private Declare Function CreateFile _
Lib "kernel32" _
Alias "CreateFileA" _
(ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, _
ByVal lpSecurityAttributes As Long, _
ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes 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
"CreateEventA" ( _
ByVal lpEventAttributes 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 nNumberOfBytesToWrite As Long, _
lpNumberOfBytesWritten As Long, _
lpOverlapped As Any) As Long
Private Declare Function ReadFile Lib "kernel32" ( _
ByVal hFile As Long, _
ByVal lpBuffer As String, _
ByVal nNumberOfBytesToRead As Long, _
lpNumberOfBytesRead As Long, _
lpOverlapped As Any) As Long
Private Declare Function ReadFileEx Lib "kernel32" ( _
ByVal hFile As Long, _
lpBuffer As Any, _
ByVal nNumberOfBytesToRead As Long, _
lpOverlapped As OVERLAPPED, _
ByVal lpCompletionRoutine As Long) As Long
Private Declare Sub Sleep Lib "kernel32" ( _
ByVal dwMilliseconds As Long)
Private Declare Function EscapeCommFunction Lib "kernel32" ( _
ByVal nCid As Long, _
ByVal nFunc As Long) As Long
Private Declare Function GetCommModemStatus 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(PortNo%, Erm$) As Boolean
OpenCommErr = True
Erm$ = ""
cmn.Port$ = "COM" + Trim$(Str$(PortNo))
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_FailSetupComm(Erm$) Then
Erm$ = "OpenComm: " + Erm$
Exit Function
End If
OpenCommErr = False
End Function
'
'
'
Private Function LF_FailSetupComm(Erm$) As Boolean
Dim D As DCB, cto As COMMTIMEOUTS
Dim lRet&, Status&
LF_FailSetupComm = True
Erm$ = ""
D.DCBlength = Len(D)
If GetCommState(cmn.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_ENABLE
D.fDtrControl = DTR_CONTROL_DISABLE
D.fDsrSensitivity = 0 ' - 5/10/02
D.fTXContinueOnXoff = 0
D.fOutX = 0 ' XOn - Off
D.fInX = 0
D.fErrorChar = 0
D.fNull = 0
D.fRtsControl = RTS_CONTROL_DISABLE ' RTS On
'D.fRtsControl = RTS_CONTROL_ENABLE
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("baud=19200 parity=N data=8 stop=1", D)
If lRet = 0 Then
Erm$ = "Error Setting Com State"
Exit Function
End If
If SetCommState(cmn.hFile, D) = 0 Then
Erm$ = "Error setting " + cmn.Port$ + " parameters"
Exit Function
End If
' --- In Out Buffer sizes
If SetupComm(cmn.hFile, 256, 256) = 0 Then
Erm$ = "Error on API SetupComm()"
Exit Function
End If
' Setup Timeouts in Milliseconds
cto.ReadIntervalTimeout = 100
cto.ReadTotalTimeoutConstant = 100 ' TIMEOUT_CONSTANT
cto.ReadTotalTimeoutMultiplier = 10 ' TIMEOUT_MULTIPLIER
cto.WriteTotalTimeoutMultiplier = 10
cto.WriteTotalTimeoutConstant = 100
If SetCommTimeouts(cmn.hFile, cto) = 0 Then
Erm$ = "Error setting " + cmn.Port$ + " timeouts"
Exit Function
End If
Call PurgeComm(cmn.hFile, PURGE_RXCLEAR)
Call PurgeComm(cmn.hFile, PURGE_TXCLEAR)
Call PurgeComm(cmn.hFile, PURGE_RXABORT)
Call PurgeComm(cmn.hFile, PURGE_TXABORT)
If GetCommModemStatus(cmn.hFile, Status) = 0 Then
Erm$ = "Failed GetCommModemStatus()"
Exit Function
End If
' --- Good Exit
LF_FailSetupComm = 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_WakePrinterErr(Erm$) As Boolean
Dim Status&, Count%
LF_WakePrinterErr = True
' ---
If cmn.hFile = 0 Then
Erm$ = "Printer is NOT Open"
Exit Function
End If
Erm$ = "Failed To Wake Printer"
RETRY:
If GetCommModemStatus(cmn.hFile, Status) = 0 Then
Erm$ = "Failed GetCommModemStatus()"
Exit Function
End If
' --- DSR On means printer is online
If (Status And MS_DSR_ON) = MS_DSR_ON Then
LF_WakePrinterErr = 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 EscapeCommFunction(cmn.hFile, SETDTR) = 0 Then
Erm$ = "Failed EscapeCommFunction() SETDTR"
End If
End Sub
Public Sub DtrOff(Erm$)
Erm$ = ""
If EscapeCommFunction(cmn.hFile, CLRDTR) = 0 Then
Erm$ = "Failed EscapeCommFunction() CLRDTR"
End If
End Sub
' ================================================== ==========
'
' Write String to Com Port
'
Public Function WriteCommErr(Data$, Erm$) As Boolean
Dim Res&, BytesWritten&
Dim L9&, Nix$, S As String * 1
Erm$ = ""
WriteCommErr = True
If LF_WakePrinterErr(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.hFile, 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 GetCommModemStatus(cmn.hFile, Status) = 0 Then
Erm$ = "Failed GetCommModemStatus"
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$(Erm$)
Dim Char As String * 1
Dim Count&
Erm$ = ""
If LF_WakePrinterErr(Erm$) Then
Erm$ = "Read Comm: " + Erm$
Exit Function
End If
Call Sleep(10)
DoEvents
Call ReadFile(cmn.hFile, Char$, 1, Count&, 0)
If Count Then
ReadCommChar$ = Char$
End If
End Function
' ================================================== ==========
'
'
'
Public Function CloseCommErr(Erm$) 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_Initialize()
cmn.ID = TSDebug.RegObj("cZPrint")
End Sub
Private Sub Class_Terminate()
Call Me.CloseCommErr("")
TSDebug.UnRegObj cmn.ID
End Sub
