Public Function ean13$(barcode$)
  'Heiko Hommes
  '27.08.2008
  'Barcode EAN13
  'Parameter: 13er EAN
  'Rückgabe:  Code, auf den man die Schriftart EAN13 legen kann
  
  Dim i%, checksum%, first%, CodeBarre$, tableA As Boolean
  ean13$ = ""
  
  'Prüfziffer abschneiden
  If Len(barcode$) = 13 Then
    barcode$ = Mid(barcode$, 1, 12)
  End If
  
  '12 Zeichen prüfen
  If Len(barcode$) = 12 Then
    'Et que ce sont bien des chiffres
    'And they are really digits
    For i% = 1 To 12
      If Asc(Mid$(barcode$, i%, 1)) < 48 Or Asc(Mid$(barcode$, i%, 1)) > 57 Then
        i% = 0
        Exit For
      End If
    Next
    If i% = 13 Then
      'Berechnung der Chekcsumme
      For i% = 12 To 1 Step -2
        checksum% = checksum% + Val(Mid$(barcode$, i%, 1))
      Next
      checksum% = checksum% * 3
      For i% = 11 To 1 Step -2
        checksum% = checksum% + Val(Mid$(barcode$, i%, 1))
      Next
      barcode$ = barcode$ & (10 - checksum% Mod 10) Mod 10
      'Das erste Zeichen wird so genommen das zweite aus TableA'
      CodeBarre$ = Left$(barcode$, 1) & Chr$(65 + Val(Mid$(barcode$, 2, 1)))
      first% = Val(Left$(barcode$, 1))
      For i% = 3 To 7
        tableA = False
         Select Case i%
         Case 3
           Select Case first%
           Case 0 To 3
             tableA = True
           End Select
         Case 4
           Select Case first%
           Case 0, 4, 7, 8
             tableA = True
           End Select
         Case 5
           Select Case first%
           Case 0, 1, 4, 5, 9
             tableA = True
           End Select
         Case 6
           Select Case first%
           Case 0, 2, 5, 6, 7
             tableA = True
           End Select
         Case 7
           Select Case first%
           Case 0, 3, 6, 8, 9
             tableA = True
           End Select
         End Select
       If tableA Then
         CodeBarre$ = CodeBarre$ & Chr$(65 + Val(Mid$(barcode$, i%, 1)))
       Else
         CodeBarre$ = CodeBarre$ & Chr$(75 + Val(Mid$(barcode$, i%, 1)))
       End If
     Next
      CodeBarre$ = CodeBarre$ & "*"   'ein trenner
      For i% = 8 To 13
        CodeBarre$ = CodeBarre$ & Chr$(97 + Val(Mid$(barcode$, i%, 1)))
      Next
      CodeBarre$ = CodeBarre$ & "+"   'endemarkierung
      ean13$ = CodeBarre$
    End If
  End If
End Function


Function hh_()
Dim co As String

co = ean13("4006381333641")
Sheets("Tabelle1").Cells(1, 1).Value = co

End Function