ich habe folgenden Code gefunden, welcher mir einen einfachen Barcode als Bild erzeugt.
Diesen würde ich gern an ein UF (z.B. Userform1.Image1) übergeben, bekomme es aber nicht hin.
Vielleicht kann mir ja jemand sagen wie ich die erzeugte Grafik übertragen kann.
Gruß,
Thomas
Code im Arbeitsblatt
Private Sub Worksheet_Change(ByVal Target As Range)
paintCode39 Me.Cells(6, 1), Me, "test", 2
End Sub
Code im Modul
Option Explicit
' -----------------------------------------------------------------
' paintCode39
' Prozedur zum erstellen von Code39 Barcodes mit Excel Bord-Mitteln
' -----------------------------------------------------------------
' Autor: Günter Mühldorfer
' Copyright: cboden softwareentwicklung
' Fabriciusstr. 14
' 65933 Frankfurt am Main
' ------------------------------------------------------------------
' Parameter
' - Value: Wert, der als Barcode angezeigt werden soll
' - Sheet: Arbeitsblatt, auf dem der Barcode gezeichnet werden soll
' - Name: Name der zu erstellenden Barcode-Grafik. Der Name muss
' innerhalb des Arbeitsblattes eindeutig sein
' - ScaleFactor: Faktor für Größenanpassung.
' -------------------------------------------------------------------
Public Sub paintCode39(ByVal Value As String, _
ByRef Sheet As Worksheet, _
ByVal Name As String, _
ByVal ScaleFactor As Integer)
' Variable anlegen
Dim X As Integer
Dim Y As Integer
Dim Height As Integer
Dim i As Integer
Dim j As Integer
Dim sh As Shape
Dim code As String
Dim varArray() As Variant
Dim iCount As Integer
' Positionsvariable initialisieren
X = 100
Y = 100
Height = 50
' ggf. Start- und Stopzeichen zum anzuzeigenden Wert hinzufügen
If Left(Value, 1) "*" Then Value = "*" & Value
If Right(Value, 1) "*" Then Value = Value & "*"
' Ermitteln, ob sich bereits einen alte Version des Barcodes
' auf dem Arbeitsblatt befindet.
For Each sh In Sheet.Shapes
If sh.Name = Name Then
' alte Barcode-Grafik gefunden. Default-Werte für
' Positionsvariable überschreiben
X = sh.Left
Y = sh.Top
Height = sh.Height
' alte Grafik löschen
sh.Delete
' Schleife beenden
Exit For
End If
Next
' Mit Schleife den anzuzeigenden Wert zeichenweise durchgehen
For i = 1 To Len(Value)
' aktuelles Zeichen gemäß Mapping-Tabelle kodieren
' Beispiel: A wird zu 1101010010110
code = getCode(Mid(Value, i, 1))
' Prüfen, ob gültige Kodierung gefunden wurde.
If code = "" Then
MsgBox "Barcode-Erstellung abgebrochen.", _
vbCritical, _
"Undefiniertes Zeichen."
Exit For
End If
' den Kode Balken für Balken durchgehen
For j = 1 To Len(code)
' neues Shape-Objekt anlegen mit ScalFactor-Breite anlegen
Set sh = Sheet.Shapes.AddShape(msoShapeRectangle, X, Y, ScaleFactor, Height)
' X-Position um Breite des ScalFactor weiterschieben
X = X + ScaleFactor
' abhängig vom aktuellen Kode Shape schwarz oder weiß färben
If Mid(code, j, 1) = 1 Then
' Kode = 1 --> schwarzer Balken
sh.Fill.ForeColor.RGB = RGB(0, 0, 0)
sh.Line.ForeColor.RGB = RGB(0, 0, 0)
Else
' Kode = 0 --> weißer Balken
sh.Fill.ForeColor.RGB = RGB(255, 255, 255)
sh.Line.ForeColor.RGB = RGB(255, 255, 255)
End If
' Balken in Array für spätere Gruppierung hinzufügen
iCount = iCount + 1
ReDim Preserve varArray(1 To iCount)
varArray(iCount) = sh.Name
Next
Next
group:
' Alle bisher angelegten Balken zu einer einzelnen Grafik gruppieren
Set sh = Sheet.Shapes.Range(varArray).group
' gruppierte Grafik benennen
sh.Name = Name
End Sub
' -----------------------------------------------------------------
' getCode
' Mapping-Funktion zum Umwandeln eines gegebenen Zeichens in eine
' Kodieren zur Generierung eines Code39 Barcode-Elements
' -----------------------------------------------------------------
' Autor: Günter Mühldorfer
' Copyright: cboden softwareentwicklung
' Fabriciusstr. 14
' 65933 Frankfurt am Main
' ------------------------------------------------------------------
' Parameter
' - Character: das zu kodierende Zeichen
' -------------------------------------------------------------------
' Rückgabewert: Kodierung gemäß Code39
' 1 = schwarzer Balken
' 0 = weißer Balken
' Für einen breiten Balken werden zwei gleichfarbige Balken
' hintereinander kodiert.
' Bei einem nicht im Code39 definierten Zeichen gibt die Funktion
' eine leere Zeichenfolge zurück.
' -------------------------------------------------------------------
Private Function getCode(ByVal Character As String) As String
Dim code As String
Select Case UCase(Character)
Case "*"
code = "1001011011010"
Case "0"
code = "1010011011010"
Case "1"
code = "1101001010110"
Case "2"
code = "1011001010110"
Case "3"
code = "1101100101010"
Case "4"
code = "1010011010110"
Case "5"
code = "1101001101010"
Case "6"
code = "1011001101010"
Case "7"
code = "1010010110110"
Case "8"
code = "1101001011010"
Case "9"
code = "1011001011010"
Case "A"
code = "1101010010110"
Case "B"
code = "1011010010110"
Case "C"
code = "1101101001010"
Case "D"
code = "1010110010110"
Case "E"
code = "1101011001010"
Case "F"
code = "1011011001010"
Case "G"
code = "1010100110110"
Case "H"
code = "1101010011010"
Case "I"
code = "1011010011010"
Case "J"
code = "1010110011010"
Case "K"
code = "1101010100110"
Case "L"
code = "1011010100110"
Case "M"
code = "1101101010010"
Case "N"
code = "1010110100110"
Case "O"
code = "1101011010010"
Case "P"
code = "1011011010010"
Case "Q"
code = "1010101100110"
Case "R"
code = "1101010110010"
Case "S"
code = "1011010110010"
Case "T"
code = "1010110110010"
Case "U"
code = "1100101010110"
Case "V"
code = "1001101010110"
Case "W"
code = "1100110101010"
Case "X"
code = "1001011010110"
Case "Y"
code = "1100101101010"
Case "Z"
code = "1001101101010"
Case "-"
code = "1001010110110"
Case "."
code = "1100101011010"
Case " "
code = "1001101011010"
Case "$"
code = "1001001001010"
Case "/"
code = "1001001010010"
Case "+"
code = "1001010010010"
Case "%"
code = "1010010010010"
Case Else
code = ""
End Select
getCode = code
End Function