EDIFACT EAN od. Zeichensatz prüfen
15.07.2004 10:49:18
Bongartz
für alle die mit EDI Edifact zu tun haben, kommt es vor das die Daten auf konformität geprüft werden müssen.
Mit den folgenden Funktionen kan man die EAN Prüfziffer berechnen, die EAN Prüfen, den für EDIFACT zulässigen ASCII Zeichensatz für UNOA, UNOB oder UNOC überprüfen. Falsche ASCII Zeichen werden mit Ihrem Ascii-Code angezeigt.
Gruß
Bongartz
' Funktion ermittelt die korrekten EAN(8,13,14), UPC und DUN(14) Prüfziffern und
' übergibt die korrekt EAN in das Feld, von der die Funktion aufgerufen wurde.
Function GetEAN(strWert As String) As Double
Dim x As Integer, nSumme As Byte, nLang As Byte
Dim cWert As String, endWert As String
Dim lGerade As Boolean
Dim Länge As Byte
Länge = Len(strWert)
If IsNumeric(strWert) And Länge <> 0 Then
Select Case Länge
Case 8
cWert = Left(strWert, 7)
lGerade = False
GoTo Berechnen
Case 11
cWert = Left(strWert, 10)
lGerade = True
GoTo Berechnen
Case 12
cWert = Left(strWert, 11)
lGerade = False
GoTo Berechnen
Case 13
cWert = Left(strWert, 12)
lGerade = True
GoTo Berechnen
Case 14
cWert = Left(strWert, 13)
lGerade = False
GoTo Berechnen
Case Else
Exit Function
End Select
End If
Berechnen:
nLang = Len(cWert)
For x = 1 To nLang
lGerade = Not lGerade
If lGerade Then
nSumme = nSumme + Val(Mid$(cWert, x, 1)) * 3
Else
nSumme = nSumme + Val(Mid$(cWert, x, 1)) * 1
End If
Next x
endWert = Int((nSumme + 9) / 10) * 10 - nSumme
GetEAN = Int(cWert & endWert)
End Function
' Funktion ermittelt die korrekten EAN(8,13,14), UPC und DUN(14) Prüfziffern und
' übergibt in das Feld von der die Funktion aufgerufen wurde ein "***-OK" oder "Fehler".
Function CheckEAN(strWert As String) As Variant
Dim x As Integer, nSumme As Byte, nLang As Byte
Dim cWert As String, rWert As String, endWert As String, strEAN As String
Dim lGerade As Boolean
Dim Länge As Byte
Länge = Len(strWert)
If IsNumeric(strWert) And Länge <> 0 Then
Select Case Länge
Case 8
strEAN = "OK EAN-8"
rWert = Right(strWert, 1)
cWert = Left(strWert, 7)
lGerade = False
GoTo Berechnen
Case 11
strEAN = "OK UPC 11 stellig"
rWert = Right(strWert, 1)
cWert = Left(strWert, 10)
lGerade = True
GoTo Berechnen
Case 12
strEAN = "OK UPC-12"
rWert = Right(strWert, 1)
cWert = Left(strWert, 11)
lGerade = False
GoTo Berechnen
Case 13
strEAN = "OK EAN-13"
rWert = Right(strWert, 1)
cWert = Left(strWert, 12)
lGerade = True
GoTo Berechnen
Case 14
strEAN = "OK EAN-14,DUN"
rWert = Right(strWert, 1)
cWert = Left(strWert, 13)
lGerade = False
GoTo Berechnen
Case Else
CheckEAN = "Fehler Keine EAN"
Exit Function
End Select
End If
Berechnen:
nLang = Len(cWert)
For x = 1 To nLang
lGerade = Not lGerade
If lGerade Then
nSumme = nSumme + Val(Mid$(cWert, x, 1)) * 3
Else
nSumme = nSumme + Val(Mid$(cWert, x, 1)) * 1
End If
Next x
endWert = Int((nSumme + 9) / 10) * 10 - nSumme
If rWert = endWert Then
CheckEAN = strEAN
Else
CheckEAN = "Falsche Prüfziffer"
End If
End Function
Function CheckUNOA(ByRef a As Range) As Variant
'Prüft eine Zelle auf die korrekten Ascii zeichen für Edifact UNOA
Dim laenge%, zeichen$, zahl, wert
Dim i As Integer
Dim z As Boolean
zahl = ""
laenge = Len(a)
For i = 1 To laenge
zeichen = Mid(a, i, 1)
wert = Asc(zeichen)
Select Case wert
Case 32 To 34, 37, 38, 40 To 42, 44 To 57, 59 To 62, 65 To 90
Case Else
zahl = zahl & zeichen & "=" & wert & ", "
End Select
Next
CheckUNOA = zahl
End Function
Function CheckUNOB(ByRef a As Range) As Variant
'Prüft eine Zelle auf die korrekten Ascii zeichen für Edifact UNOB
Dim laenge%, zeichen$, zahl, wert
Dim i As Integer
Dim z As Boolean
zahl = ""
laenge = Len(a)
For i = 1 To laenge
zeichen = Mid(a, i, 1)
wert = Asc(zeichen)
Select Case wert
Case 32 To 34, 37, 38, 40 To 42, 44 To 57, 59 To 62, 65 To 90, 97 To 122
Case Else
zahl = zahl & zeichen & "=" & wert & ", "
End Select
Next
CheckUNOB = zahl
End Function