Microsoft Excel

Excel und VBA: Beitrag aus Herbers Excel-Forumsarchiv

Frage zu Comport.xls

Betrifft: Frage zu Comport.xls
von: Kai
Geschrieben am: 14.01.2006 01:41:23

Hallo zusammen,

kann mir bitte einer erklären wie ich die COMPORT.xls anwende? Ich bekomme schon beim öffnen immer eine Fehlermeldung. (Fehler beim Kompilieren: Außerhalb einer Prozedur ungültig)
Wie kann ich wenn ich mit einem Scanner einen Barcode scanne diesen dann zur Weiterverarbeitung in VBA nutzen.
so scanne u. vergleiche wert in cells(1,1)(soll ne so ne Art suchenfunktion werden)?

ich hoffe mir kann jemand helfen u. bedanke mich schon mal im Vorraus

Gruß Kai
  


Betrifft: AW: Frage zu Comport.xls
von: Reinhard
Geschrieben am: 14.01.2006 17:52:35

Hi Kai,
da fehlten ein paar Hochkammas, nachstehend sind sie eingefügt.
Zu deiner eigentlichen Frage kann ich nichts sagen, deshalb frage noch offen.
Gruß
Reinhard

Option Explicit


'-------------------------------------------------------------------
'
'Module:            ComPort
'Author:            Darren Richards
'Date        :   11th August '95
'Synopsis    :   Win32 comms API wrapper for VBA
'                   OpenComPort   -  open / configure com port.
'                   ReadComPort   -  read available data from com port.
'                   WriteComPort  -  write data to com port.
'                   CloseComPort  -  close com port.
'                   StatComPort   -  get buffer stats for com port.
'
'


'-------------------------------------------------------------------
'                 API Constants And declarations
'-------------------------------------------------------------------

'   structs used by Win32 comm api
'

Type DCB  '' patched to proper definition VB32 ill-def DR
        DCBlength As Long
        BaudRate As Long
        fdwFlags As Long ' bit field in C
        wReserved1 As Integer
        XonLim As Integer
        XoffLim As Integer
        ByteSize As String * 1
        Parity As String * 1
        StopBits As String * 1
        XonChar As String * 1
        XoffChar As String * 1
        ErrorChar As String * 1
        EofChar As String * 1
        EvtChar As String * 1
        wReserved2 As Integer
End Type

Type COMMTIMEOUTS
        ReadIntervalTimeout As Long
        ReadTotalTimeoutMultiplier As Long
        ReadTotalTimeoutConstant As Long
        WriteTotalTimeoutMultiplier As Long
        WriteTotalTimeoutConstant As Long
End Type

Type COMSTAT
        fCtsHold As Long
        fDsrHold As Long
        fRlsdHold As Long
        fXoffHold As Long
        fXoffSent As Long
        fEof As Long
        fTxim As Long
        fReserved As Long
        cbInQue As Long
        cbOutQue As Long
End Type

'   kernel defined constants
'

Public Const OPEN_EXISTING = 3
Public Const GENERIC_READ = &H80000000
Public Const GENERIC_WRITE = &H40000000
Public Const INVALID_HANDLE_VALUE = &HFFFF
Public Const MAXDWORD = &HFFFF

'   comms Constants
'

Public Const PURGE_TXCLEAR = &H4
Public Const PURGE_RXCLEAR = &H8

Public Const CE_RXOVER = &H1                '  Receive Queue overflow
Public Const CE_OVERRUN = &H2               '  Receive Overrun Error
Public Const CE_RXPARITY = &H4              '  Receive Parity Error
Public Const CE_FRAME = &H8                 '  Receive Framing error
Public Const CE_BREAK = &H10                '  Break Detected
Public Const CE_TXFULL = &H100              '  TX Queue is full

Public Const SETRTS = 3                     '  Set RTS high
Public Const SETDTR = 5                     '  Set DTR high


'   kernel API file i/o functions
'

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
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Declare Function GetLastError Lib "kernel32" () As Long
Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As _
Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, _
ByVal lpOverlapped As Long) As Long
Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As _
Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal _
lpOverlapped As Long) As Long

'   Win32 comms functions
'

Declare Function SetCommState Lib "kernel32" (ByVal hCommDev As Long, lpDCB _
As DCB) As Long
Declare Function SetCommTimeouts Lib "kernel32" (ByVal hFile As Long, _
lpCommTimeouts As COMMTIMEOUTS) As Long
Declare Function PurgeComm Lib "kernel32" (ByVal hFile As Long, ByVal _
dwFlags As Long) As Long
Declare Function BuildCommDCB Lib "kernel32" Alias "BuildCommDCBA" (ByVal _
lpDef As String, lpDCB As DCB) As Long
Declare Function SetCommMask Lib "kernel32" (ByVal hFile As Long, ByVal _
dwEvtMask As Long) As Long
Declare Function ClearCommError Lib "kernel32" (ByVal hFile As Long, _
lpErrors As Long, lpStat As COMSTAT) As Long
Declare Function SetupComm Lib "kernel32" (ByVal hFile As Long, ByVal _
dwInQueue As Long, ByVal dwOutQueue As Long) As Long
Declare Function EscapeCommFunction Lib "kernel32" (ByVal nCid As Long, _
ByVal nFunc As Long) As Long
Declare Function GetCommMask Lib "kernel32" (ByVal hFile As Long, lpEvtMask _
As Long) As Long
Declare Function GetCommModemStatus Lib "kernel32" (ByVal hFile As Long, _
lpModemStat As Long) As Long
Declare Function WaitCommEvent Lib "kernel32" (ByVal hFile As Long, _
lpEvtMask As Long, ByVal lpOverlapped As Long) As Long


'-------------------------------------------------------------------
'
'Routine:           OpenComPort
'   Parameters  :   strPortName   -  name of the port to open
'                   strSettings   -  port settings in the format
'                                    "baud=9600 parity=N data=8 stop=1"
'                   lPortHandle   -  set to port handle on success
'   Returns     :   Boolean representing success
'   Synopsis    :   opens named communications port for synchronous
'                   i/o. The handle returned should be used in
'                   subsequent calls
'
'
Public Function OpenComPort(strPortName As String, _
                            strSettings As String, _
                            lPortHandle As Long) _
                            As Boolean


    Dim tCto    As COMMTIMEOUTS
    Dim tDcb    As DCB
    Dim hPort   As Long
    Dim fRet    As Boolean

    '
    '   set the length field of the DCB
    '

    tDcb.DCBlength = Len(tDcb)

    '
    '   get kernel to build a default DCB for us
    '   based on com settings string
    '

    Call BuildCommDCB(strSettings, tDcb)
        
    '
    '   open that com port
    '

    hPort = CreateFile(strPortName, _
                       GENERIC_READ + GENERIC_WRITE, _
                       0, _
                       0, _
                       OPEN_EXISTING, _
                       0, _
                       0)

    '
    '   did we get port open ...
    '

    If hPort = INVALID_HANDLE_VALUE Then

        '
        '   ... no, get the error code from kernel
        '

        Dim lErr As Long

        lErr = GetLastError()

        Debug.Print "Failed to open comport( err = " & CStr(lErr) & ")"

        '
        '   setup returns for failure
        '

        fRet = False
        lPortHandle = INVALID_HANDLE_VALUE

    Else

        '
        '   ... yes, get port ready for action
        '
        
        '
        '   set port state using DCB we built earlier
        '

        Call SetCommState(hPort, tDcb)
        
        '
        '   set up buffer sizes and re-initialize comm driver
        '

        Call SetupComm(hPort, 64000, 64000)   ' hPort, InQue, OutQue

        '
        '   setup timeout parameters for this port
        '

        tCto.ReadIntervalTimeout = MAXDWORD       '' return with whatever is available
        tCto.ReadTotalTimeoutMultiplier = 0
        tCto.ReadTotalTimeoutConstant = 0

        tCto.WriteTotalTimeoutMultiplier = 0
        tCto.WriteTotalTimeoutConstant = 10000    '' max 10 secs to write data, just to stop locking
                                                  '' up application if we gowrong
        Call SetCommTimeouts(hPort, tCto)
        
        '
        '   turn on DTR / RTS
        '
        
        Call EscapeCommFunction(hPort, SETDTR)
        Call EscapeCommFunction(hPort, SETRTS)
        
        '
        '   setup returns for success
        '

        fRet = True
        lPortHandle = hPort

    End If

    OpenComPort = fRet

End Function


'-------------------------------------------------------------------
'Routine:           WriteComPort
'   Parameters  :   lPortHandle   -  port handle from OpenComPort
'                   strData       -  data to write
'                   cbData        -  length of data to write
'
'   Returns     :   Boolean representing success
'   Synopsis    :   writes data to com port, does not return until
'                   all data has been written to comport buffer
'
'
Public Function WriteComPort(lPortHandle As Long, _
                             strData As String, _
                             cbData As Long) _
                             As Boolean

    Dim fWrite As Boolean
    Dim cbWritten As Long
    
    '
    '   write data to comms port
    '
           
    fWrite = WriteFile(lPortHandle, _
                       ByVal strData, _
                       cbData, _
                       cbWritten, _
                       0)

    '
    '   check if that worked
    '

    If Not fWrite Then

        Dim lErr As Long

        '
        '   get error from kernel
        '

        lErr = GetLastError()

        Debug.Print "WriteFile failed ( err = " & CStr(lErr) & " )"
        
        '
        '   make sure any comms errors are cleared
        '
        
        Dim tComStat As COMSTAT
        Dim lErrFlags As Long
        
        Call ClearCommError(lPortHandle, lErrFlags, tComStat)
        Call handleCommError(lPortHandle, lErrFlags)

    End If

    '
    '   return whatever write file returned
    '

    WriteComPort = fWrite

End Function

'-------------------------------------------------------------------
'
'Routine:           ReadComPort
'   Parameters  :   lPortHandle   -  port handle from OpenComPort
'                   strData       -  buffer to receive data
'                   cbRead        -  set to length of data read
'
'   Returns     :   Boolean representing success
'   Synopsis    :   reads data from com port, returns immediately
'                   if no data is available, otherwise gets contents
'                   of buffer.
'
'
Public Function ReadComPort(lPortHandle As Long, _
                            strData As String, _
                            cbRead As Long) _
                            As Boolean

    Dim strBuf As String * 1000
    Dim cbBuf As Long
    Dim fRead As Boolean

    cbBuf = Len(strBuf)

    '
    '   read from port
    '

    fRead = ReadFile(lPortHandle, _
                     ByVal strBuf, _
                     cbBuf, _
                     cbRead, _
                     0)

    '
    '   check if that worked
    '

    If Not fRead Then

        Dim lErr As Long

        '
        '   get error from kernel
        '

        lErr = GetLastError()

        Debug.Print "ReadFile failed ( err = " & CStr(lErr) & " )"

        '
        '   make sure any comms errors are cleared
        '
        
        Dim tComStat As COMSTAT
        Dim lErrFlags As Long
        
        Call ClearCommError(lPortHandle, lErrFlags, tComStat)
        Call handleCommError(lPortHandle, lErrFlags)

    Else
    
        '
        '   make return into VB string
        '
        
        strData = Left(strBuf, cbRead)

    End If
                       
    '
    '   return whatever ReadFile returned
    '

    ReadComPort = fRead

End Function

'-------------------------------------------------------------------
'Routine:           CloseComPort
'   Parameters  :   lPortHandle   -  port handle from OpenComPort
'Returns:           none
'   Synopsis    :   closes com port.
'
'

Public Sub CloseComPort(lPortHandle As Long)
    
    Call PurgeComm(lPortHandle, PURGE_TXCLEAR Or PURGE_RXCLEAR)
    Call CloseHandle(lPortHandle)
    lPortHandle = INVALID_HANDLE_VALUE

End Sub

'-------------------------------------------------------------------
'Routine:           StatComPort
'   Parameters  :   lPortHandle   -  port handle from OpenComPort
'                   lRxBuffer     -  number of bytes in receive buffer
'                   lTxBuffer     -  number of byte in transmit buffer
'Returns:           none
'   Synopsis    :   gets buffers statistics for comport, these are
'                   returned in lRxBuffer, lTxBuffer.
'
'

Public Sub StatComPort(lPortHandle As Long, lRxBuffer As Long, lTxBuffer As Long)
    
    Dim tComStat As COMSTAT
    Dim lDummy   As Long
    
    '
    '   get those statistics
    '
    
    Call ClearCommError(lPortHandle, lDummy, tComStat)
    
    '
    '   grab the bits of comstat we are interested in
    '
    
    lRxBuffer = tComStat.cbInQue
    lTxBuffer = tComStat.cbOutQue

End Sub


'-------------------------------------------------------------------
'   Routine:           handleCommError
'   Parameters  :   lPortHandle   -  port handle from OpenComPort lErrMask      -  error mask from ClearCommError
'   Returns:           none
'   Synopsis    :   used internally to handle comms errors
'
'

Private Sub handleCommError(lPortHandle As Long, lErrMask As Long)

    If (lErrMask And CE_RXOVER) Then
        Debug.Print "Receive overrun detected on com port"
        Call PurgeComm(lPortHandle, PURGE_RXCLEAR)
    End If
    If (lErrMask And CE_OVERRUN) Then
        Debug.Print "Byte lost on com port by hardware"
    End If
    If (lErrMask And CE_RXPARITY) Then
        Debug.Print "Parity error detected on com port"
    End If
    If (lErrMask And CE_FRAME) Then
        Debug.Print "Framing error detected on com port"
    End If
    If (lErrMask And CE_BREAK) Then
        Debug.Print "Break condition detected on com port"
    End If
    If (lErrMask And CE_TXFULL) Then
        Debug.Print "Transmit buffer overflow detected"
        Call PurgeComm(lPortHandle, PURGE_TXCLEAR)
    End If

End Sub