Public Function Code128$(barcode$)
  'Heiko Hommes
  '27.08.2008
  'Parameter Zeichenkette, welche als Barcode dargestellt werden soll
  'Rückgabe Code, auf den die Schriftart Code128 gelegt werden kann
  
  Dim i%, checksum&, mini%, dummy%, tableB As Boolean
  Code128$ = ""
  If Len(barcode$) > 0 Then
  'Barcode prüfen
    For i% = 1 To Len(barcode$)
      Select Case Asc(Mid$(barcode$, i%, 1))
      Case 32 To 126, 203
      Case Else
        i% = 0
        Exit For
      End Select
    Next
    'Code berechnen nach Table B und C
    Code128$ = ""
    tableB = True
    If i% > 0 Then
      i% = 1 
      Do While i% <= Len(barcode$)
        If tableB Then
          'schaune, ob es sinnvoll ist auf Table C zu schauen
          'Ja für 4 Zeichen am Start or Ende else 6 Zeichen
          mini% = IIf(i% = 1 Or i% + 3 = Len(barcode$), 4, 6)
          GoSub testnum
          If mini% < 0 Then 'C Table auswählen'
            If i% = 1 Then 'Starten mit C Tabelle'
              Code128$ = Chr$(210)
            Else 'Auf C Tabelle switschen'
              Code128$ = Code128$ & Chr$(204)
            End If
            tableB = False
          Else
            If i% = 1 Then Code128$ = Chr$(209) 'Starten mit Tabelle B
          End If
        End If
        If Not tableB Then
          'auf Tabelle C mit 2 Zeichen
          mini% = 2
          GoSub testnum
          If mini% < 0 Then 'OK für 2 zeichen
            dummy% = Val(Mid$(barcode$, i%, 2))
            dummy% = IIf(dummy% < 95, dummy% + 32, dummy% + 105)
            Code128$ = Code128$ & Chr$(dummy%)
            i% = i% + 2
          Else 'keine 2 zeichen umschalten auf Tabelle B
            Code128$ = Code128$ & Chr$(205)
            tableB = True
          End If
        End If
        If tableB Then
          'Ausführen mit 1 Zeichen auf TableB
          Code128$ = Code128$ & Mid$(barcode$, i%, 1)
          i% = i% + 1
        End If
      Loop
      'Checksummenberechnung
      For i% = 1 To Len(Code128$)
        dummy% = Asc(Mid$(Code128$, i%, 1))
        dummy% = IIf(dummy% < 127, dummy% - 32, dummy% - 105)
        If i% = 1 Then checksum& = dummy%
        checksum& = (checksum& + (i% - 1) * dummy%) Mod 103
      Next
      'Berechnung Checksumme ASCII Code
      checksum& = IIf(checksum& < 95, checksum& + 32, checksum& + 105)
      'checksum und Stop anhängen
      Code128$ = Code128$ & Chr$(checksum&) & Chr$(211)
    End If
  End If
  Exit Function
testnum:
  
  mini% = mini% - 1
  If i% + mini% <= Len(barcode$) Then
    Do While mini% >= 0
      If Asc(Mid$(barcode$, i% + mini%, 1)) < 48 Or Asc(Mid$(barcode$, i% + mini%, 1)) > 57 Then Exit Do
      mini% = mini% - 1
    Loop
  End If
Return
End Function

Function hho_()

Dim co As String

co = Code128$("1002919916090593/1061")
Sheets("Tabelle1").Cells(1, 1).Value = co
End Function