Hallo Christuf,
Post by Christof KluÃPost by Andreas KillerFür die Kommunikation ja, aber das Zauberwort "Event", bzw.
"WaitCommEvent" fehlt, d.h. es gibt kein Ereignis das ausgelöst wird
wenn man an der Waage auf den Knopf drückt.
Ja, scheint mit der "mscomm32.ocx" wesentlich einfacher zu gehen
http://www.pencomdesign.com/support/relay_software/vba_software_example.htm
die habe ich auf meinem System aber leider nicht :(
das Problem mit den Ereignissen ist, dass man Verweise auf "fremde"
Bibliotheken oder Steuerelemente setzen muss und auch darauf angewiesen
ist, dass die benutzten Ressourcen auf dem Rechner vorhanden und korrekt
registriert sind.
Mit Excel-Bordmitteln kann man die Schnittstelle auch abfragen, aber Events
sind nicht drin. Da muss man dann Pollen, das heißt, die Schnittstelle
kontinuierlich abfragen. Das belastet dann natürlich den Rechner und Excel
erscheint dann wie eingefroren.
Wenn man aber keine zeitkritischen Daten auslesen will, also beispielsweise
beim Eintreffen einen Zeitstempel hinzufügen möchte, klappt das recht gut,
denn die eintreffenden Daten werden ja im Eingangspuffer
zwischengespeichert.
Nachfolgend etwas Code, mangels zweitem Rechner habe ich das AVR-Net-IO von
Pollin als Datenlieferant missbraucht, dazu muss man aber erst ein Kommando
senden, deshalb sind die folgenden Zeilen mit drin.
If Senden("getstatus" & vbCrLf) = 0 Then
Debug.Print "Fehler beim Senden"
End If
Die kannst du ja rausnehmen.
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Type COMSTAT
Bits As Long
cbInQue As Long
cbOutQue As Long
End Type
Private Declare Function CreateFile _
Lib "kernel32" Alias "CreateFileA" ( _
ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, _
lpSecurityAttributes As SECURITY_ATTRIBUTES, _
ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long _
) As Long
Private Declare Function CloseHandle _
Lib "kernel32" ( _
ByVal hObject As Long _
) As Long
Private Declare Function ClearCommError _
Lib "kernel32" ( _
ByVal hFile As Long, _
lpErrors As Long, _
lpStat As COMSTAT _
) As Long
Private 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
Private 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
Private Declare Function GetLastError _
Lib "kernel32" () As Long
Private Const GENERIC_READ As Long = &H80000000
Private Const GENERIC_WRITE As Long = &H40000000
Private Const OPEN_EXISTING As Long = 3
Private mlngComHandle As Long
Private mblnStop As Boolean
Public Sub StartUeberwachung()
If mlngComHandle <> 0 Then Exit Sub
mlngComHandle = KommunikationOeffnen("Com1")
If mlngComHandle = 0 Then
MsgBox "Fehler beim Öffen der Kommunikation"
Exit Sub
End If
mblnStop = False
Call PollCom
End Sub
Public Sub StopUeberwachung()
mblnStop = True
If KommunikationSchließen(mlngComHandle) = False Then
MsgBox "Fehler beim Schließen der Kommunikation"
Else
mlngComHandle = 0
End If
End Sub
Private Sub PollCom()
Dim strInput As String
Dim lngLast As Long
If mblnStop Then Exit Sub
strInput = Empfangen(2) ' 2 Sekunden Wartezeit
If strInput <> "" Then
With Worksheets("Tabelle1")
lngLast = .Cells(.Rows.Count, 1).End(xlUp).Row
.Cells(lngLast + 1, 1) = strInput
End With
End If
Application.OnTime Now + TimeSerial(0, 0, 10), "PollCom"
If Senden("getstatus" & vbCrLf) = 0 Then
Debug.Print "Fehler beim Senden"
End If
End Sub
Private Function Senden(Text As String) As Long
Dim lngRet As Long
Dim lngWritten As Long
If mlngComHandle = 0 Then Exit Function
' Text senden
lngRet = WriteFile(mlngComHandle, Text, Len(Text), lngWritten, 0)
If lngRet = 0 Then MsgBox "Fehler beim Senden"
Senden = lngWritten
End Function
Private Function Empfangen(Optional lngTimeout As Long = 5) As String
Dim lngRet As Long
Dim strBuffer As String
Dim lngWritten As Long
Dim lngNeeded As Long
Dim lngComError As Long
Dim udtStat As COMSTAT
Dim dteTimeoutWaitForInput As Date
Dim i As Long
If mlngComHandle = 0 Then Exit Function
If lngTimeout = 0 Then lngTimeout = 5
' Timeoutzeit festlegen
dteTimeoutWaitForInput = Now + TimeSerial(0, 0, lngTimeout)
Do
i = i + 1
' Status holen
ClearCommError mlngComHandle, lngComError, udtStat
' Anzahl Zeichen im Puffer auslesen
lngNeeded = udtStat.cbInQue
If lngNeeded > 0 Then
' Puffer anlegen
strBuffer = String(lngNeeded, 0)
' Empfangspuffer in der angelegten Größe auslesen
lngRet = ReadFile( _
mlngComHandle, _
strBuffer, _
lngNeeded, _
lngWritten, 0)
Empfangen = Empfangen & strBuffer
' Ereignisse abarbeiten
DoEvents
' Status holen
ClearCommError mlngComHandle, lngComError, udtStat
' Anzahl Zeichen im Puffer auslesen
If udtStat.cbInQue = 0 Then Exit Do
Else
' Überprüfen, ob Timeout erreicht. Wenn ja,
' Schleife verlassen
If Now > dteTimeoutWaitForInput Then Exit Do
End If
If (i Mod 100) = 0 Then DoEvents
Loop
End Function
Public Function KommunikationSchließen( _
Optional CommHandle As Long _
) As Boolean
If CloseHandle(CommHandle) <> 0 Then
' Schnittstelle erfolgreich geschlossen
KommunikationSchließen = True
End If
End Function
Public Function KommunikationOeffnen( _
Optional strPort As String = "COM1" _
) As Long
Dim udtSecurity As SECURITY_ATTRIBUTES
Dim lngAccess As Long
Dim lngErr As Long
Dim lngComHandle As Long
On Error GoTo ErrHandler
' Zugriffsberechtigung setzen
lngAccess = GENERIC_READ Or GENERIC_WRITE
' Struktur SECURITY_ATTRIBUTES ausfüllen
With udtSecurity
.nLength = 12
.bInheritHandle = 0
.lpSecurityDescriptor = 0
End With
' Fehlerspeicher leeren
lngErr = GetLastError
' Filehandle holen
lngComHandle = CreateFile( _
strPort, _
lngAccess, _
0&, _
udtSecurity, _
OPEN_EXISTING, _
0&, _
0&)
' Fehlerspeicher auslesen
lngErr = GetLastError
If (lngErr <> 0) Or (lngComHandle < 1) Then
GoTo ErrHandler
End If
' Filehandle als Funktionsergebnis zurückgenben
KommunikationOeffnen = lngComHandle
Exit Function
ErrHandler:
End Function
Viele Grüße
Michael