Hallo
Ich hab mal eine Function gebastelt.
- Eine bestehende Prüfziffer wird überprüft
- Ist Keine vorhanden, wird Sie ermittelt und ergänzt.
Aufruf aus einem Tabellenblatt durch
A2: =CodeEAN13(A1)
Es bleibt aber:
- du benötigst die richtige Barcodeschriftart
- Zelle in Excel "kopieren", in Word "Inhalte einfügen", Grafik...
in ein Modul kopieren.
Public Function CodeEAN13$(Text$)
Dim ZIFF As Byte, z As Byte, PZ As Byte
Dim Z13%, ZS$, AB$, Wert$, j%
If Len(Text) 13 Then
MsgBox "12 bzw. " & vbLf & "13 Zeichen (inkl. Prüfziffer)" & vbLf & " erforderlich"
Exit Function
End If
PZ = Modulo10(Left(Text, 12)) 'Prüfziffer ermitteln
If Len(Text) = 12 Then Text = Text & PZ 'Prüfziffer anhängen, wenn fehlt
If Right(Text, 1) PZ Then 'bestehende Prüfziffer checken
MsgBox "Prüfziffer falsch !" & vbLf & "Soll = " & PZ
Exit Function
End If
Z13 = Left(Text, 1)
CodeEAN13$ = Z13 & " *"
ZS = Choose(Z13 + 1, "AAAAAA", "AABABB", "AABBAB", "AABBBA", "ABAABB", _
"ABBAAB", "ABBBAA", "ABABAB", "ABABBA", "ABBABA") ' Zeichensatz A oder B
z = 1
For j = 2 To 7
AB = Mid(ZS, z, 1)
ZIFF = Mid(Text, j, 1)
Wert = IIf(AB = "A", Choose(ZIFF + 1, "p", "q", "w", "e", "r", "t", "z", "u", "i", "o") _
_
_
, Choose(ZIFF + 1, "ö", "a", "s", "d", "f", "g", "h", "j", "k", "l")) _
_
CodeEAN13$ = CodeEAN13$ & Wert
z = z + 1
Next j
CodeEAN13$ = CodeEAN13$ & "#"
For j = 8 To 13
ZIFF = Mid(Text, j, 1)
Wert = Choose(ZIFF + 1, "-", "y", "x", "c", "v", "b", "n", "m", ",", ".") ' Zeichensatz _
_
C
CodeEAN13$ = CodeEAN13$ & Wert
Next j
CodeEAN13$ = CodeEAN13$ & "* "
End Function
Public Function Modulo10(Zelle) As Byte
'Prüfziffer nach Modulo 10, Gewichtung 3-1, rechts nach links
Dim bln As Boolean
Dim intI As Integer
Dim dblSumme As Double
For intI = Len(Zelle) To 1 Step -1
bln = Not bln
If bln = True Then
dblSumme = dblSumme + Mid(Zelle, intI, 1) * 3
Else
dblSumme = dblSumme + Mid(Zelle, intI, 1) * 1
End If
Next
Modulo10 = IIf(dblSumme Mod 10 = 0, 0, 10 - (dblSumme Mod 10))
End Function
Gruß UweD
