Moin allerseits,
und hier nun der etwas verallgemeinerte und verschlankte Code, mit dem sich fantastisch BarCodes39 erzeugen lassen, ohne dazu externe TTFs zu bemühen.
www.guenter-muehldorfer.de sei herzlichen Dank!
Den folgenden Code in ein allg. Modul, nicht unbedingt die Zelle A1 ausgewählen (ab C3 geht's besser), den Aufruf über Alt-F8
MakeCode39 starten und schon erfreut einen eine hübsche Schwarz/Weiß-Landschaft, die auf Klick auch dann ihren Wert verrät, wenn man gerade mal keinen Scanner zur Hand hat.
Code: Alles auswählen
Option Explicit
Public sValue As String
Sub MakeCode39()
Dim sName As String, sCode As String
Dim iL As Integer, iT As Integer, iX As Integer, iH As Integer
Dim i As Integer, j As Integer, c As Integer
Dim shp As Shape, aLines()
sValue = InputBox("Ziffern und Text, auch mit Esc-Zeichen, keine Leerzeichen", "BarCode39")
If Left(sValue, 1) <> "*" Then sValue = "*" & sValue
If Right(sValue, 1) <> "*" Then sValue = sValue & "*"
iL = ActiveCell.Left - 2: iT = ActiveCell.Top - 2: iX = 2: iH = 25: sName = "BarCode39"
With ActiveSheet
For Each shp In .Shapes
If shp.Name = sName Then
shp.Delete
End If
Next
For i = 1 To Len(sValue)
sCode = GetCode(Mid(sValue, i, 1))
For j = 1 To Len(sCode)
Set shp = .Shapes.AddShape(msoShapeRectangle, iL, iT, iX, iH)
iL = iL + iX
If Mid(sCode, j, 1) = 1 Then
shp.Fill.ForeColor.RGB = RGB(0, 0, 0)
shp.Line.ForeColor.RGB = RGB(0, 0, 0)
Else
shp.Fill.ForeColor.RGB = RGB(255, 255, 255)
shp.Line.ForeColor.RGB = RGB(255, 255, 255)
End If
c = c + 1
ReDim Preserve aLines(1 To c)
aLines(c) = shp.Name
Next
Next
sValue = Replace(sValue, "*", "")
Set shp = .Shapes.Range(aLines).group
shp.Name = sName
shp.OnAction = "Action"
End With
End Sub
Private Sub Action()
MsgBox "Wert " & sValue, , "Developed by https://guenter-muehldorfer.de/"
End Sub
Private Function GetCode(ByVal Character As String) As String
Dim sCode As String
Select Case UCase(Character)
Case "*"
sCode = "1001011011010"
Case "0"
sCode = "1010011011010"
Case "1"
sCode = "1101001010110"
Case "2"
sCode = "1011001010110"
Case "3"
sCode = "1101100101010"
Case "4"
sCode = "1010011010110"
Case "5"
sCode = "1101001101010"
Case "6"
sCode = "1011001101010"
Case "7"
sCode = "1010010110110"
Case "8"
sCode = "1101001011010"
Case "9"
sCode = "1011001011010"
Case "A"
sCode = "1101010010110"
Case "B"
sCode = "1011010010110"
Case "C"
sCode = "1101101001010"
Case "D"
sCode = "1010110010110"
Case "E"
sCode = "1101011001010"
Case "F"
sCode = "1011011001010"
Case "G"
sCode = "1010100110110"
Case "H"
sCode = "1101010011010"
Case "I"
sCode = "1011010011010"
Case "J"
sCode = "1010110011010"
Case "K"
sCode = "1101010100110"
Case "L"
sCode = "1011010100110"
Case "M"
sCode = "1101101010010"
Case "N"
sCode = "1010110100110"
Case "O"
sCode = "1101011010010"
Case "P"
sCode = "1011011010010"
Case "Q"
sCode = "1010101100110"
Case "R"
sCode = "1101010110010"
Case "S"
sCode = "1011010110010"
Case "T"
sCode = "1010110110010"
Case "U"
sCode = "1100101010110"
Case "V"
sCode = "1001101010110"
Case "W"
sCode = "1100110101010"
Case "iL"
sCode = "1001011010110"
Case "iT"
sCode = "1100101101010"
Case "Z"
sCode = "1001101101010"
Case "-"
sCode = "1001010110110"
Case "."
sCode = "1100101011010"
Case " "
sCode = "1001101011010"
Case "$"
sCode = "1001001001010"
Case "/"
sCode = "1001001010010"
Case "+"
sCode = "1001010010010"
Case "%"
sCode = "1010010010010"
Case Else
sCode = ""
End Select
GetCode = sCode
End Function
Viel Spaß damit!