C#, WPF, vb.Net, vba, SQL Server, Access Programmierer, Excel, ASP Core MVC Webforms Telefon: 07022/9319004 freib. Software Entwickler   Kontakt
#

Download:

Datei 1: Demo_31a_Excel_Barcode_Funktion.xlsm

 

 

Dieses Beispiel enthält eine Excel Datei mit einem Makro-Code, durch welches jedes bestehende Excel-Dokument mit einem zusätzlichem Barcode vom Typ 39 ergänzt werden kann.

Der Barcode wird rein durch ein vba Code im Hintergrund erzeugt, wobei immer ein kleines Barcode Bildchen in die Zelle  mit der Formel gezeichnet wird.

 

Im Excelblatt muss man nur die Formel Barcode mit Bezug zu einer Werte-Zelle eingeben und schon wird der entsprechende Barcode in die Zelle gezeichnet.

=BarCode_Function(B4)

 

Der Code ist kostenlos und kann in jede bestehende Excel Anwendung eingebaut werden.

 

In Macros Visual Basic for Applications muss dann der beiliegende Makro-Code eingefügt werden.

Dieser enthält die Public Function BarCode_Function(..) welche als Formel im Excel Blatt ausgeführt wird

 

 

 

Video Tutorial

 

Makro Code zum Erzellen von Barcode 39 in Excel Dokumenten

Der vba Code wurde auf Basis von einem Beitrag in CBoden Software Entwicklung erstellt und als dynamische Formel erweitert

Referenz zum Original Code

http://cboden.de/softwareentwicklung/vba/tipps-tricks/59-barcode-mit-excel-bordmitteln-erstellen

 

Option Explicit On

 

Public Function BarCode_Function(Input_Cell As Range)

    '------------------< BarCode_Function() >------------------

    Dim wert As String

    wert = Input_Cell.Formula

    Dim CellID As String

    CellID = "BarCode_" & Input_Cell.Column & "_" & Input_Cell.Row

 

    Dim x As Integer, Y As Integer, Heigth As Integer

    x = Input_Cell.Left + Input_Cell.Width + 2

 

    Y = Input_Cell.Top + 2

    Heigth = Input_Cell.Height - 4

 

 

    paintCode39 wert, ActiveSheet, "Barcode_" & CellID, 1, x, Y, Heigth

    On Error Resume Next

    delete_Shape_Clones()

 

 

    '< Ausgabe >

    BarCode_Function = ""

    '</ Ausgabe >

    '------------------</ BarCode_Function() >------------------

End Function

 

 

 

' -----------------------------------------------------------------

' paintCode39

' Referenz: http://cboden.de/softwareentwicklung/vba/tipps-tricks/59-barcode-mit-excel-bordmitteln-erstellen

' 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,

                       ByVal x As Integer,

                       ByVal Y As Integer,

                       ByVal Height As Integer

                       )

    ' Variable anlegen

    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

 

    ' 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

            sh.Delete

        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

 

 

Private Sub delete_Shape_Clones()

    '-------------------< delete_Shape_Clones() >---------------

    Dim Sheet As Worksheet

    Set Sheet = ActiveSheet

   

    Dim iShape As Integer

    Dim nShapes As Integer

    nShapes = Sheet.Shapes.Count

 

    For iShape = 1 To nShapes

 

        Dim objShape As Shape

        Dim iLoop As Integer

 

        For iLoop = iShape + 1 To nShapes

            If Sheet.Shapes(iLoop).Name = Sheet.Shapes(iShape).Name Then

                Sheet.Shapes(iLoop).Delete

                nShapes = nShapes - 1

            End If

        Next

    Next

    '-------------------</ delete_Shape_Clones() >---------------

End Sub

 

 

Mobile
»
Excel : Barcode per Excel Makro Code in Zellen einfügen
»
Excel: Werte aus eigener Funktions-Formel eingeben
»
Excel: mehrere Zellen mehrzeilig zusammenfassen
»
[gelöst] Excel: eine Summe der Felder über einem Spalte zusammenzählen mit Sum oder Teilsummen
»
Gelöst: Excel überstehender Zelltext über andere Zellen anzeigen
»
Excel, Formel: Bestimmte Werte zählen
»
Bedingte Formeln mit Leeren Zellen

.

Jobs, Projekte, Angebote für Freiberufler, Selbstständig an Raimund.Popp@Microsoft-Programmierer.de