Option Compare Database
Option Explicit

Dim tcpConnectionKeepAlive As Boolean
Dim tcpConnectionOpen As Boolean

Sub WiegenInitialisieren()

tcpConnectionOpen = False
tcpConnectionKeepAlive = True

End Sub

Sub WiegenBeenden()

If tcpConnectionOpen = True Then
 EndWinSocket
 tcpConnectionOpen = False
End If


End Sub
  
Function Wiegen(Optional Datum As Date, Optional zeit As Date, Optional Gewicht As Long, Optional Waagentext As String, Optional KeineIdentNummernErhöhung As Boolean) As Long

Dim waagentyp1

waagentyp1 = GetParameter("WAAGENTYP")

Wiegen = -1

If waagentyp1 = "TOLEDO" Then
 Wiegen = WiegenToledo
End If

If waagentyp1 = "GASSNER" Then
 Wiegen = WiegenGassner(Datum, zeit, Gewicht, Waagentext)
End If

If waagentyp1 = "SCHEMBER" Then
 Wiegen = WiegenSchember
End If

If waagentyp1 = "SYSTEC" Then
 Wiegen = WiegenSystec
End If

If waagentyp1 = "IT3000" Then
 Wiegen = WiegenIt3000(Datum, zeit, Gewicht)
End If

If waagentyp1 = "IT3000A" Then
 Wiegen = WiegenIt3000a(Datum, zeit, Gewicht, Waagentext, KeineIdentNummernErhöhung)
End If

If waagentyp1 = "L320" Then
 Wiegen = L320(Datum, zeit, Gewicht, Waagentext)
End If

If waagentyp1 = "L246" Then
 Wiegen = L246(Datum, zeit, Gewicht, Waagentext, KeineIdentNummernErhöhung)
End If



End Function


Function WiegenToledo() As Long
' Wolkersdorf, Haugsdorf

Dim buff(0 To 11) As Integer
Dim i, c As Integer
Dim str1 As String

' Send command "netto weight": "CP"
Forms!FÜbernahme.send (Asc("C"))
Forms!FÜbernahme.TheEvent = 0
While Forms!FÜbernahme.TheEvent < 1
 DoEvents
Wend
Forms!FÜbernahme!XComm.InBufferCount = 0
Forms!FÜbernahme.send (Asc("P"))

' Read whole response word: 12 Bytes
While i < 12 And c <> -1
 c = Forms!FÜbernahme.Receive()
 buff(i) = c
 i = i + 1
Wend

If c = -1 Then
 WiegenToledo = -1
 Exit Function
Else
'Number of read bytes OK
 
 'Check if format is OK
 
 'First byte: 02
 If buff(0) <> 2 Then
  WiegenToledo = -2
  Exit Function
 End If
 'Bytes 9 and 10: 'kg'
 If buff(8) <> Asc("k") Then
  WiegenToledo = -3
  Exit Function
 End If
 If buff(9) <> Asc("g") Then
  WiegenToledo = -3
  Exit Function
 End If
 'Bytes 11 and 12: 0D 0A (CRLF)
 If buff(10) <> &HD Then
  WiegenToledo = -4
  Exit Function
 End If
 If buff(11) <> &HA Then
  WiegenToledo = -5
  Exit Function
 End If
 
 'Convert weight to long value
 str1 = ""
 For i = 1 To 7
  str1 = str1 + Chr(buff(i))
 Next i
 c = CLng(str1)
 
 WiegenToledo = c
 
End If


End Function



Function WiegenGassner(Datum As Variant, zeit As Variant, Gewicht As Long, Waagentext As Variant) As Long
'im Moment nirgends

Dim buff(0 To 99) As Integer
Dim i, c As Integer
Dim str1 As String
Dim str2 As String
Dim waagennummer As Long
Dim speichernummer As Long

' Send command "ENQ": 05h
Forms!FÜbernahme!XComm.InBufferCount = 0
Forms!FÜbernahme.send (&H5)
Forms!FÜbernahme.TheEvent = 0

' Read whole response word: 25 Bytes
While i < 47 And c <> -1
 c = Forms!FÜbernahme.Receive()
 buff(i) = c
 i = i + 1
Wend

'str1 = ""
'For i = 0 To 46
' str1 = str1 + Hex(buff(i)) + " "
' str2 = str2 + Chr(buff(i))
'Next i
'MsgBox (str1 + Chr(10) + Chr(13) + str2)

If c = -1 Then
 WiegenGassner = -1
 Exit Function
Else
'Number of read bytes OK
 
 'Check if format is OK
 
 'First byte: 02
 If buff(0) <> 2 Then
  WiegenGassner = -2
  Exit Function
 End If
 
 'Second byte: "E"/"S"  (" "..OK, "E" for Error)
 If buff(1) <> Asc(" ") Then
  WiegenGassner = -3
  Exit Function
 End If
 
 'Third byte: "S"/"M"
 If buff(2) <> Asc("S") Then
  WiegenGassner = -4
  Exit Function
 End If
 
 'Convert weight to long value
 str1 = ""
 For i = 0 To 6
  str1 = str1 + Chr(buff(i + 17))
 Next i
 c = CLng(str1)
 Gewicht = c
 WiegenGassner = c
 
 'Convert weight to long value
 str1 = ""
 For i = 0 To 6
  str1 = str1 + Chr(buff(i + 17))
 Next i
 c = CLng(str1)
 Gewicht = c
 WiegenGassner = c
 
 'Convert Waagennummer
 str1 = ""
 For i = 0 To 1
  str1 = str1 + Chr(buff(i + 24))
 Next i
 c = CLng(str1)
 waagennummer = c
 
 'Convert Speichernummer
 str1 = ""
 For i = 0 To 5
  str1 = str1 + Chr(buff(i + 26))
 Next i
 c = CLng(str1)
 speichernummer = c
 
 'Convert Datum
 str1 = ""
 For i = 0 To 7
  str1 = str1 + Chr(buff(i + 32))
 Next i
 If IsDate(Mid(str1, 7, 2) + "." + Mid(str1, 5, 2) + "." + Mid(str1, 1, 4)) Then
  Datum = DateValue(Mid(str1, 7, 2) + "." + Mid(str1, 5, 2) + "." + Mid(str1, 1, 4))
 End If
 
 'Convert Zeit
 str1 = ""
 For i = 0 To 5
  str1 = str1 + Chr(buff(i + 40))
 Next i
 If IsDate(Mid(str1, 1, 2) + ":" + Mid(str1, 3, 2) + ":" + Mid(str1, 5, 2)) Then
  zeit = TimeValue(Mid(str1, 1, 2) + ":" + Mid(str1, 3, 2) + ":" + Mid(str1, 5, 2))
 End If
 Waagentext = "Waagennummer: " + Format(waagennummer) + "  Speichernummer: " + Format(speichernummer)
 
End If


End Function

Function WiegenGassnerAlt() As Long
'im Moment nirgends

Dim buff(0 To 24) As Integer
Dim i, c As Integer
Dim str1 As String

' Send command "ENQ": 05h
Forms!FÜbernahme!XComm.InBufferCount = 0
Forms!FÜbernahme.send (&H5)
Forms!FÜbernahme.TheEvent = 0

' Read whole response word: 25 Bytes
While i < 25 And c <> -1
 c = Forms!FÜbernahme.Receive()
 buff(i) = c
 i = i + 1
Wend

If c = -1 Then
 WiegenGassnerAlt = -1
 Exit Function
Else
'Number of read bytes OK
 
 'Check if format is OK
 
 'First byte: 02
 If buff(0) <> 2 Then
  WiegenGassnerAlt = -2
  Exit Function
 End If
 
 'Second byte: "E"/"S"  (" "..OK, "E" for Error)
 If buff(1) <> " " Then
  WiegenGassnerAlt = -3
  Exit Function
 End If
 
 'Third byte: "S"/"M"
 If buff(2) <> "S" Then
  WiegenGassnerAlt = -4
  Exit Function
 End If
  
 'Byte 25
 'If buff(24) <> &H3 Then
 ' WiegenGassner = -5
 ' Exit Function
 'End If
 
 'Convert weight to long value
 str1 = ""
 For i = 0 To 6
  str1 = str1 + Chr(buff(i + 17))
 Next i
 c = CLng(str1)
 
 WiegenGassnerAlt = c
 
End If


End Function



Function WiegenSchember() As Long

' Matzen

Dim buff(0 To 24) As Integer
Dim i, c As Integer
Dim str1 As String

' Send command "27,62"
Forms!FÜbernahme.send (27)
Forms!FÜbernahme.TheEvent = 0
While Forms!FÜbernahme.TheEvent < 1
 DoEvents
Wend
Forms!FÜbernahme.XComm.InBufferCount = 0
Forms!FÜbernahme.send (62)

' Read whole response word: 12 Bytes
While i < 25 And c <> -1
 c = Forms!FÜbernahme.Receive()
 buff(i) = c
 i = i + 1
Wend

If c = -1 Then
 WiegenSchember = -1
 Exit Function
Else
'Number of read bytes OK
 
 'Check if format is OK
 
 'First byte: 02
 If buff(0) <> 2 Then
  WiegenSchember = -2
  Exit Function
 End If

 'Bytes 11 and 12: 0D 0A (CRLF)
 If buff(24) <> 3 Then
  WiegenSchember = -4
  Exit Function
 End If

 'Convert weight to long value
 str1 = ""
 For i = 16 To 19
  str1 = str1 + Chr(buff(i))
 Next i
 str1 = str1 + ","
 str1 = str1 + Chr(buff(20))
 c = CDbl(str1)
 
 
 WiegenSchember = c
 
End If


End Function


Function WiegenSystec() As Long

' Matzen

Dim buff(0 To 50) As Integer
Dim i, c As Integer
Dim str1 As String


Forms!FÜbernahme.XComm.InBufferCount = 0

'Wait for STX
Do
 c = Forms!FÜbernahme.Receive()
Loop Until c = 2
buff(0) = c

i = 1
While i < 17 And c <> -1
 c = Forms!FÜbernahme.Receive()
 buff(i) = c
 i = i + 1
Wend

If c = -1 Then
 WiegenSystec = -1
 Exit Function
Else

'Number of read bytes OK
 
'Check if format is OK
 
 'First byte: 02
 If buff(0) <> 2 Then
  WiegenSystec = -2
  Exit Function
 End If

 'Convert weight to long value
 str1 = ""
 For i = 4 To 9
  str1 = str1 + Chr(buff(i))
 Next i
 c = CDbl(str1)
 
 WiegenSystec = c
 
End If


End Function


Function WiegenIt3000(Datum As Date, zeit As Date, Gewicht As Long) As Long
' Röschitz

Dim c As Integer
Dim recordcount As Integer
Dim record(0 To 20) As String

'Receive STX
While c <> 2 And c <> -1
 c = Forms!FÜbernahme.Receive()
Wend
If c = -1 Then
 WiegenIt3000 = -1
 Forms!FÜbernahme.send (&H15) 'NAK
 Exit Function
End If
'Receive Buffer and terminating ETX
recordcount = 0
record(recordcount) = ""
While c <> -1 And c <> 3 'ETX
 c = Forms!FÜbernahme.Receive()
 If c = Asc(";") Or c = 3 Then
  recordcount = recordcount + 1
  record(recordcount) = ""
 Else
  If c <> -1 Then
   record(recordcount) = record(recordcount) + Chr(c)
  End If
 End If
Wend
If c = -1 Then
 WiegenIt3000 = -2
 Forms!FÜbernahme.send (&H15) 'NAK
 Exit Function
End If

'interpret records
If recordcount < 4 Then
 'too less records
 WiegenIt3000 = -3
 Forms!FÜbernahme.send (&H15) 'NAK
 Exit Function
End If
'record(0) is waagennummer
Datum = DateValue(record(1))
zeit = TimeValue(record(2))
Gewicht = Val(record(3))

'send acknowledge
Forms!FÜbernahme.send (6) 'ACK

Forms!FÜbernahme!XComm.InBufferCount = 0


End Function

Function WiegenIt3000a(Datum As Date, zeit As Date, Gewicht As Long, Waagentext As String, KeineIdentNummernErhöhung As Boolean) As Long
' Matzen, Wolkersdorf

Dim c As Integer
Dim i As Integer
Dim Data As String
Dim record As String
Dim waagennummer As Long
Dim speichernummer As Long

Forms!FÜbernahme.XComm.InBufferCount = 0
Forms!FÜbernahme.TheEvent = 0

If KeineIdentNummernErhöhung = True Then
'Send command
 Forms!FÜbernahme.send (Asc("<"))
 Forms!FÜbernahme.send (Asc("R"))
 Forms!FÜbernahme.send (Asc("M"))
 Forms!FÜbernahme.send (Asc(">"))
Else
'Send command
 Forms!FÜbernahme.send (Asc("<"))
 Forms!FÜbernahme.send (Asc("R"))
 Forms!FÜbernahme.send (Asc("N"))
 Forms!FÜbernahme.send (Asc(">"))
End If

'Receive record
i = 0
Data = ""
While i < 64 And c <> -1
 c = Forms!FÜbernahme.Receive()
 If c <> -1 Then
  Data = Data + Chr(c)
 End If
 i = i + 1
Wend

'MsgBox (data)

'skip < and >
Data = Mid(Data, 2, 62)


If c = -1 Then
 WiegenIt3000a = -1
 Exit Function
End If

'interpret data
'1. Fehlercode, Waagenstatus
record = Left(Data, 4)
Data = Mid(Data, 5)
If record <> "0000" Then
 WiegenIt3000a = -2
 Exit Function
End If
'2. Date
record = Left(Data, 8)
Data = Mid(Data, 9)
If IsDate(record) Then
 Datum = DateValue(record)
Else
 WiegenIt3000a = -3
 Exit Function
End If
'2. Time
record = Left(Data, 5)
record = record + ":00"
Data = Mid(Data, 6)
If IsDate(record) Then
 zeit = TimeValue(record)
Else
 WiegenIt3000a = -4
 Exit Function
End If
'4. Identnr
record = Left(Data, 4)
Data = Mid(Data, 5)
speichernummer = Val(record)
'5. Waagennr
record = Left(Data, 1)
Data = Mid(Data, 2)
waagennummer = Val(record)
'6. Brutto
record = Left(Data, 8)
Data = Mid(Data, 9)
'7. Tara
record = Left(Data, 8)
Data = Mid(Data, 9)
'8. Netto
record = Left(Data, 8)
Data = Mid(Data, 9)
If IsNumeric(record) Then
 Gewicht = Val(record)
Else
 WiegenIt3000a = -5
 Exit Function
End If
'9. kg
record = Left(Data, 2)
Data = Mid(Data, 3)
If record <> "kg" Then
 WiegenIt3000a = -6
 Exit Function
End If

'rest wird nicht ausgewertet
 
Waagentext = "Waagenr: " + Format(waagennummer) + "  ID: " + Format(speichernummer)

WiegenIt3000a = Gewicht

End Function

Sub testl320()

Dim Datum As Date
Dim zeit As Date
Dim Gewicht As Long
Dim Waagentext As String
Dim chk As String
Dim Data As String

Data = " 17.04.14 12:58    2        72kg" + Chr(10)

Data = Mid(Data, 2)
Datum = CDate(Left(Data, 8))
Data = Mid(Data, 10)
zeit = CDate(Left(Data, 5))
Data = Mid(Data, 7)
Waagentext = Left(Data, 4)
Data = Mid(Data, 6)
Gewicht = CLng(Left(Data, 9))
Data = Mid(Data, 11)
chk = Left(Data, 2)

MsgBox (Datum)
MsgBox (zeit)
MsgBox (Gewicht)
MsgBox (Waagentext)

End Sub


Function L320(Datum As Date, zeit As Date, Gewicht As Long, Waagentext As String) As Long

Dim c As Long
Dim Data As String
Dim chk As String
Dim i As Integer
Dim str1 As String
'Receive record
str1 = ""

Data = ""

c = Forms!FÜbernahme.Receive()
str1 = Format(c)
'Forms!FÜbernahme!XComm.InBufferCount
If c = 32 Then
 i = 1
 Data = Data + Chr(c)
Else
 c = Forms!FÜbernahme.Receive()
 str1 = str1 + "," + Format(c)
 c = Forms!FÜbernahme.Receive()
 str1 = str1 + "," + Format(c)
 'MsgBox (str1)
 L320 = -9
 Exit Function
End If

While i < 33 And c <> -1
 c = Forms!FÜbernahme.Receive()
 If c <> -1 Then
  Data = Data + Chr(c)
 End If
 str1 = str1 + "," + Format(c)
 i = i + 1
Wend

'1: 0x20
'2-9: Date 17.04.14
'10 0x20
'11-15: Time 12:58
'16: 0x20
'17-20: wiegenr
'21: 0x20
'22-30: gewicht
'31-32: kg
'33: 0x0A
'MsgBox (str1 + ":" + Format(Len(data)) + ":" & data)
If Len(Data) >= 33 Then
    Data = Mid(Data, 2)
    Datum = CDate(Left(Data, 8))
    Data = Mid(Data, 10)
    zeit = CDate(Left(Data, 5))
    Data = Mid(Data, 7)
    Waagentext = Left(Data, 4)
    Data = Mid(Data, 6)
    Gewicht = CLng(Left(Data, 9))
    Data = Mid(Data, 10)
    chk = Left(Data, 2)
    If chk <> "kg" Then
     'MsgBox ("Fehler! Waagenrecord nicht korrekt")
     L320 = -1
    Else
     L320 = Gewicht
    End If
Else
 L320 = -9
End If


End Function


Function L246(Datum As Date, zeit As Date, Gewicht As Long, Waagentext As String, KeineIdentNummernErhöhung As Boolean) As Long

' 1. open tcp port
Dim host As String
Dim tcpport As Long
Dim result As Long

If tcpConnectionOpen = False Then
    host = GetParameter("WAAGEHOST")
    tcpport = GetParameter("WAAGETCPPORT")
    StartWinSocket
    result = ConnectToServer(host, tcpport)
    If result > 0 Then
     tcpConnectionOpen = True
    End If
End If

If tcpConnectionOpen = True Then
     ' 2. send command
     If (KeineIdentNummernErhöhung) Then
      SendData "<RM1>"
     Else
      SendData "<RN1>"
     End If
    
    ' 3. receive data
    Dim response As String
    
    response = ReceiveString(65)
    
    ' 4. parse message
    'MsgBox (response)
    'Dim fehlerS As String
    Dim datumS As String
    Dim zeitS As String
    Dim identNrS As String
    Dim nettoS As String
    Dim waagennummerS As String
    Dim fehlerS As String
    
    fehlerS = Mid(response, 2, 2)
    datumS = Mid(response, 6, 8)
    zeitS = Mid(response, 14, 5)
    identNrS = Mid(response, 19, 4)
    waagennummerS = Mid(response, 23, 1)
    nettoS = Mid(response, 40, 8)
    
    
    If fehlerS <> "00" Then
     MsgBox "Fehlermeldung Waage", vbCritical
    End If
    
    Datum = CDate(datumS)
    zeit = CDate(zeitS)
    Waagentext = "Waagenr: " + Format(waagennummerS) + "  ID: " + Format(identNrS)
    Gewicht = CLng(nettoS)
    
    'MsgBox (datum)
    'MsgBox (zeit)
    'MsgBox (waagentext)
    'MsgBox (Gewicht)
    
    
    ' 5. close port
    If tcpConnectionKeepAlive = False Then
     EndWinSocket
     tcpConnectionOpen = False
    End If
End If


End Function

Function KippenL246(onoff As Boolean)

Dim host As String
Dim tcpport As Long
Dim result As Long
If tcpConnectionOpen = False Then
    host = GetParameter("WAAGEHOST")
    tcpport = GetParameter("WAAGETCPPORT")
    StartWinSocket
    result = ConnectToServer(host, tcpport)
    If result > 0 Then
     tcpConnectionOpen = True
    End If
End If

If tcpConnectionOpen = True Then
    ' 2. send command
    If onoff Then
     SendData "<OS02>"
    Else
     SendData "<OC02>"
    End If
    
    ' 3. receive data
    Dim response As String
    
    response = ReceiveString(5)
    
    ' 4. parse message
    If Left(response, 4) <> "<00>" Then
     MsgBox "Fehler beim Ansteuern des digitalen Ausganges", vbCritical
    End If

    ' 5. close port
    If tcpConnectionKeepAlive = False Then
     EndWinSocket
     tcpConnectionOpen = False
    End If
    
End If


End Function


Function FreigabeL246(onoff As Boolean)

Dim host As String
Dim tcpport As Long
Dim result As Long

If tcpConnectionOpen = False Then
    host = GetParameter("WAAGEHOST")
    tcpport = GetParameter("WAAGETCPPORT")
    StartWinSocket
    result = ConnectToServer(host, tcpport)
    If result > 0 Then
     tcpConnectionOpen = True
    End If
End If

If tcpConnectionOpen = True Then
    ' 2. send command
    If onoff Then
     SendData "<OS01>"
    Else
     SendData "<OC01>"
    End If
    
    ' 3. receive data
    Dim response As String
    
    response = ReceiveString(5)
    
    ' 4. parse message
    If Left(response, 4) <> "<00>" Then
     MsgBox "Fehler beim Ansteuern des digitalen Ausganges", vbCritical
    End If
    
    ' 5. close port
    If tcpConnectionKeepAlive = False Then
     EndWinSocket
     tcpConnectionOpen = False
    End If
End If

End Function


Sub TestL246()

Dim Datum As Date
Dim zeit As Date
Dim Gewicht As Long
Dim Waagentext As String

WiegenInitialisieren
L246 Datum, zeit, Gewicht, Waagentext, True
L246 Datum, zeit, Gewicht, Waagentext, True
L246 Datum, zeit, Gewicht, Waagentext, True
KippenL246 (True)
KippenL246 (False)
WiegenBeenden


End Sub



Function Kippen(onoff As Boolean)

Dim steuerungtyp1
Dim extbefehl

steuerungtyp1 = GetParameter("STEUERUNGTYP")

If steuerungtyp1 = "SERIELL" Then
 KippenSeriell (onoff)
End If

If steuerungtyp1 = "PARALLEL" Then
 KippenParallel (onoff)
End If


If steuerungtyp1 = "L246" Then
 KippenL246 (onoff)
End If

If steuerungtyp1 = "EXTERN" Then
 extbefehl = GetParameter("STEUERUNGEXTERN")
 If Not IsNull(extbefehl) And onoff = True Then
  Shell extbefehl, vbMinimizedFocus
 Else
  MsgBox "Externes Programm nicht gefunden!", vbCritical
 End If
End If


End Function



Function KippenSeriell(onoff As Boolean)

' Kippen: RTS Signal von COMx der Steuerung (i.a. COM2)
' SubD 25: Pin 4, SubD 9: 7

 Forms!FÜbernahme.XCommSteuerung.RTSEnable = onoff

End Function


Function KippenParallel(onoff As Boolean)

' Kippen: Über Datenleitungen des Ports


Dim port1
Dim tport1
Dim databyte As Byte

port1 = GetParameter("STEUERUNGPORT")

If Not IsNull(port1) Then

 Select Case port1
 
 Case "1": tport1 = "LPT1"

 Case "2": tport1 = "LPT2"
 
 Case "3": tport1 = "LPT3"

 End Select
 
End If

If onoff = True Then
  databyte = 255
Else
  databyte = 0
End If

Open tport1 For Binary Access Write As #1
Put #1, , databyte

Close #1

End Function


Function Freigabe(onoff As Boolean)

Dim steuerungtyp1
Dim extbefehl

steuerungtyp1 = GetParameter("STEUERUNGTYP")

If steuerungtyp1 = "L246" Then
 FreigabeL246 (onoff)
End If


End Function


Sub testkippen()

KippenParallel (True)
KippenParallel (False)

End Sub