Daten seriell einlesen

Antwort von nach 23 Minuten 0 hilfreich

Re: Daten seriell einlesen

Hallo Herbert,

ich habe gerade bei http://www.ActiveVB.de eine Lösung für Dich gefunden, die allerdings in einem Zip-File verpackt ist und VB6-Code beinhaltet, den Du dann nicht mit Excel öffnen kannst.

Der Code bei AVB ist aber Freeware, darf frei verwendet und weitergegeben werden, deshalb kann ich Dir den Code hier posten.
Allerdings ist der Code für VB6 gedacht, den Code der Form musst Du an VBA anpassen, die Form heiß eben nicht Form1, sondern Userform.

Code für die Form:

Option Explicit

Private Sub Empfangen_Click()
Dim x As Long
Dim Text As String

    x = Comm_lesen_32(Me![ID], Text)
    
    Me![EmpfangenText] = Me![EmpfangenText] & Text
    
End Sub


Private Sub Löschen_Click()
    
    Me![EmpfangenText] = ""
    
End Sub

Private Sub Senden_Click()
On Error GoTo Err_Senden_Click

Dim x As Long
    
    x = Comm_schreiben_32(Me![ID], Me![SendText] & Chr(13) & Chr(10))
    
Exit_Senden_Click:
    Exit Sub

Err_Senden_Click:
    MsgBox Err.Description
    Resume Exit_Senden_Click
    
End Sub

Private Sub Umschaltfl_Comm_Click()
If Me![Umschaltfl_Comm].Default = False Then

    Me![Umschaltfl_Comm].Default = True
    Me![ID] = Comm_open_32(Me![Def])
    ComPort![Umschaltfl_Comm].Caption = "Schließen"
    ComPort.BackColor = &HC0E0FF
    
Else
    
    Me![Umschaltfl_Comm].Default = False
    Me![ID] = Comm_close_32(Me![ID])
    Me![Umschaltfl_Comm].Caption = "Öffnen"
    ComPort.BackColor = &H8000000F

End If
End Sub

Und nun noch ein Modul, das heißt hier: 'ComPort.bas'

Option Explicit

'******************************************************************

'Beschreibung:
'Funktionen zum schreiben und lesen über die Serielle Schnittstelle
'Comm_open_32 öffnet die Schnittstelle
'Comm_lesen_32 liest von der Schnittstelle
'Comm_schreiben_32 schreibt auf die Schnittstelle
'Comm_close_32 schließt die Schnittstelle
'
'Quellangaben:
'   Dittrich: Visual Basic5, Programmiertechniken und Lösungen; Franzis'
'******************************************************************

'API-Funktionen zum Verwalten des Dateisystems
'(ab Win95 werden die Schnittstellen (Seriel und Paralel wie Dateien behandelt!)

Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal NOlpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Const GENERIC_READ = &H80000000
Const GENERIC_WRITE = &H40000000
Const OPEN_EXISTING = 3
Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As String, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal NOlpOverlapped As Long) As Long
Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As String, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long


'** Ein-/Ausgabepuffer setzen
Declare Function SetupComm Lib "kernel32" (ByVal hFile As Long, ByVal dwInQueue As Long, ByVal dwOutQueue As Long) As Long

'** Device Control Block
Type DCBType
    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
End Type
Declare Function BuildCommDCB Lib "kernel32" Alias "BuildCommDCBA" (ByVal lpDef As String, lpDCB As DCBType) As Long
Declare Function SetCommState Lib "kernel32" (ByVal hCommDev As Long, lpDCB As DCBType) As Long
Declare Function GetCommState Lib "kernel32" (ByVal nCid As Long, lpDCB As DCBType) As Long

'** Status Abfrage
Declare Function ClearCommError Lib "kernel32" (ByVal hFile As Long, lpErrors As Long, lpStat As COMSTAT) As Long
Type COMSTAT
    Bits As Long
    cbInQue As Long
    cbOutQue As Long
End Type
' Fehler-Flags
Const CE_RXOVER = &H1    '  Überlauf der Empfangswarteschlange
Const CE_OVERRUN = &H2   '  Überlauffehler beim Empfangen
Const CE_RXPARITY = &H4  '  Paritätsfehler beim Empfangen
Const CE_FRAME = &H8     '  Framing-Fehler beim Empfangen
Const CE_BREAK = &H10    '  Unterbrechung entdeckt
Const CE_CTSTO = &H20    '  CTS-Timeout
Const CE_DSRTO = &H40    '  DSR-Timeout
Const CE_RLSDTO = &H80   '  RLSD-Timeout
Const CE_TXFULL = &H100  '  TX-Warteschlange ist voll
Const CE_PTO = &H200     '  LPTx-Timeout
Const CE_IOE = &H400     '  LPTx-E/A-Fehler
Const CE_DNS = &H800     '  LPTx-Gerät nicht ausgewählt
Const CE_OOP = &H1000    '  LPTx hat kein Papier mehr
Const CE_MODE = &H8000   '  Angegebener Modus wird nicht unterstützt

'** Einstellungs-Dialog einblenden
Declare Function CommConfigDialog Lib "kernel32" Alias "CommConfigDialogA" (ByVal lpszName As String, ByVal Hwnd As Long, lpCC As COMMCONFIG) As Long
Type COMMCONFIG
    dwSize As Long
    wVersion As Integer
    wReserved As Integer
    dcbx As DCBType
    dwProviderSubType As Long
    dwProviderOffset As Long
    dwProviderSize As Long
    wcProviderData As Byte
End Type


Function Comm_close_32(nCid As Integer)

'Schließt die Angegebene Schnittstelle
'Übergabewert: nCid = Identifizierungsnummer des Prots
'Gibt True zurück, wenn kein Fehler aufgetreten ist

On Error GoTo Err_Comm_close_32
Dim x As Integer
Dim Erg As Integer

    x = CloseHandle(nCid)
    If x < 0 Then Error 1

    Erg = True
Exit_Comm_close_32:
    Comm_close_32 = Erg
    Exit Function

Err_Comm_close_32:
    MsgBox "Fehler in Function Comm_close_32: " & Error$
    Erg = False
    Resume Exit_Comm_close_32

End Function


Public Function Comm_Dialog_32(nCid As Long, Port_Def As String)
'Öffnet den Dialog zum einstellen der parameter der Schnittatelle
'Übergabeparameter:
'nCid = Identifikation der (geöffneten) Schnittstelle
'Port_Def = Min. die ersten 4 zeichen des Definitionsstrings (z.B.: "COM2:48,N,8,1" oder "COM2")
'Gibt True zurück, wenn kein Fehler aufgetreten ist
On Error GoTo Err_Comm_Dialog_32

Dim Erg As Integer
Dim x As Long, y As Long
Dim lpCC As COMMCONFIG
Dim lpDCB As DCBType

    lpCC.dwSize = Len(lpCC)
'    lpCC.wVersion =
'    lpCC.wReserved =
    lpCC.dcbx = lpDCB
'    lpCC.dwProviderSubType =
'    lpCC.dwProviderOffset =
'    lpCC.dwProviderSize =
'    lpCC.wcProviderData =

    x = CommConfigDialog(Left(Port_Def, 4), 0, lpCC)
    
    If x = 1 Then
        y = SetCommState(nCid, lpDCB)
    End If
    Erg = True
Exit_Comm_Dialog_32:
    Comm_Dialog_32 = Erg
    Exit Function

Err_Comm_Dialog_32:
    MsgBox "Fehler in Function Comm_Dialog_32: " & Error$
    Erg = False
    Resume Exit_Comm_Dialog_32

End Function


Function Comm_lesen_32(nCid As Integer, Text As String) As Integer

'Liest alle Zeichen aus dem Einganspuffer der angegebenen Schnittstelle (nCid).
'Rückgabe: Anzahl der gelesenen Zeichen. Die Zeichen selbst werden in der variablen Text übergeben.
'Bei Fehler: Rückgabe von -1. Text wird lehr zurückgegeben.

'On Error GoTo Err_Comm_lesen_32

Dim x As Long
Dim Com_Error As Long
Dim lpErrors As Long
Dim nStat As COMSTAT
Dim lpBuf As String
Dim Anzahl As Long

    Com_Error = ClearCommError(nCid, lpErrors, nStat)
        
    'If Com_Error <> 0 Then
    '    Error 1
    'End If
    
    If nStat.cbInQue > 0 Then
        lpBuf = String$(nStat.cbInQue, 0)
        x = ReadFile(nCid, lpBuf, Len(lpBuf), Anzahl, 0)
    End If

Exit_Comm_lesen_32:
    Text = lpBuf
    Comm_lesen_32 = x
    Exit Function

Err_Comm_lesen_32:
    MsgBox "Fehler in Function Comm_lesen_32: " & Error$
    lpBuf = ""
    x = -1
    Resume Exit_Comm_lesen_32

End Function

Function Comm_open_32(ByVal Port_Def As String) As Integer

'Öffnet die Serielle Schnittstelle und initialisiert sie gem. Port_Def (z.B.: "COM2:48,N,8,1")
'Rückgabewert:
'Identifizierungsnummer des Prots
'ACHTUNG: Auch 0 ist eine gültige Nummer
'Bei FEHLER wird ein Wert < 0 zurückgegeben

On Error GoTo Err_Comm_open_32

Dim nCid As Long
Dim x As Long
Dim dwInQueue As Long, dwOutQueue As Long
Dim lpDCB As DCBType

'*** Öffnen der Schnittstelle
    'MsgBox Port_Def & GENERIC_READ & GENERIC_WRITE
    nCid = CreateFile(Left(Port_Def, 4), GENERIC_READ Or GENERIC_WRITE, 0, 0, OPEN_EXISTING, 0, 0)

    If nCid < 0 Then
        'Schnittstelle konte nicht geöffnet werden
        Error 1
    End If

'*** Einstellen Ein- und Ausgabepuffer
    dwInQueue = 2048
    dwOutQueue = 2048
    x = SetupComm(nCid, dwInQueue, dwOutQueue)
   
'*** Einstellen von Baudrate, Stopbits und Parität
    'Aktueller Status in Strukturvariable lpDCB übernehmen
    x = GetCommState(nCid, lpDCB)

    'Anpassen der Strukturvariablen
    x = BuildCommDCB(Port_Def, lpDCB)
    If x = 0 Then Error 1
    
    'Status des CommPort auf die neuen Eigenschaften setzten
    x = SetCommState(nCid, lpDCB)

'*** Timeout einstellen
    '...

    
Exit_Comm_open_32:
    Comm_open_32 = nCid
    Exit Function

Err_Comm_open_32:

    MsgBox "Fehler in Function Comm_open_32: " & Error$
    nCid = -1
    Resume Exit_Comm_open_32

End Function
Function Comm_schreiben_32(nCid As Integer, ByVal Text As String) As Integer
'Schreibt den Text auf den mit nCid identifizierten (geöffneten)Port
'Rückgabewert: True
'Bei Fehler:   False

On Error GoTo Err_Comm_schreiben_32

Dim x As Long
Dim Erg As Integer
Dim Anzahl As Long
    
    'MsgBox Text
    x = WriteFile(nCid, Text, Len(Text), Anzahl, 0)
    If Anzahl < Len(Text) Then
         'On Error Resume Next
         Error 1
    End If
    
    Erg = True
Exit_Comm_schreiben_32:
    Comm_schreiben_32 = Erg
    Exit Function

Err_Comm_schreiben_32:
    If Err = 1 Then
        MsgBox "Fehler in Function Comm_schreiben_32: U.U. konnten nicht alle Zeichen übertragen werden!", 16
    Else
        MsgBox "Fehler in Function Comm_schreiben_32: " & Error$
    End If
    Erg = False
    Resume Exit_Comm_schreiben_32

End Function

Ich hoffe, damit kannst Du etwas anfangen.

Gruß, Rainer

Daten Excel Code Makro box VB msgbox

2 Antworten zu dieser Frage

Antwort von nach 23 Minuten 0 hilfreich

Re: Daten seriell einlesen

Antwort von nach einem Tag 0 hilfreich

Re: Daten seriell einlesen