Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1768to1772
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Generierung eines Barcodes pro Druck

Generierung eines Barcodes pro Druck
08.07.2020 15:31:24
Pascal
Hallo liebe Excel Profis,
Ich habe mir ein Makro aus dem Netz zusammengestückelt das eine UserForm öffnet, diese soll dann mit Informationen gefüllt werden und dann werden Daten an ein Separates Druckvorlagen Sheet weitergeleitet und anhand von Zahlen in einer Textbox wird die Druck anzahl gesteuert. Also an sich ein kleines Retouren Programm. Dies lauft auch einwandfrei.
Hier die Userform dazu:

  • Dim bmarker As Boolean
    Private Sub CheckBox1_Change()
    calcKarton
    End Sub
    

    Private Sub CheckBox2_Change()
    calcKarton
    End Sub
    

    Private Sub CheckBox3_Change()
    calcKarton
    End Sub
    

    Private Sub ComboBox1_Change()
    Worksheets("Retouren_Template").Range("B9") = ComboBox1
    End Sub
    

    Private Sub ComboBox3_Change()
    Worksheets("Retouren_Template").Range("J9") = ComboBox3
    End Sub
    

    Private Sub TextBox1_Change()
    Range("B12").Value = TextBox1.Value
    End Sub
    

    Private Sub TextBox2_Change()
    Worksheets("Retouren_Template").Range("J12") = TextBox2
    End Sub
    

    Private Sub TextBox3_Change()
    Worksheets("Retouren_Template").Range("B15") = TextBox3
    End Sub
    

    Private Sub TextBox4_Change()
    Worksheets("Retouren_Template").Range("B6") = TextBox4
    End Sub
    

    Private Sub TextBox5_Change()
    calcKarton
    If Me.TextBox5  "" Then
    If IsNumeric(Me.TextBox5) Then
    If CLng(Me.TextBox5) > 999 Or CLng(Me.TextBox5) 

    Private Sub TextBox6_Change()
    calcKarton
    If Me.TextBox6  "" Then
    If IsNumeric(Me.TextBox6) Then
    If CLng(Me.TextBox6) > 999 Or CLng(Me.TextBox6) 

    Private Sub TextBox7_Change()
    calcKarton
    If Me.TextBox7  "" Then
    If IsNumeric(Me.TextBox7) Then
    If CLng(Me.TextBox7) > 999 Or CLng(Me.TextBox7) 

    Private Sub CommandButton1_Click()
    'Prüft ob in allen Feldern etwas steht und färbt den Hintergrund Gelb
    If TextBox4 = "" Then
    MsgBox "Bitte die Retouren Nr. eintragen (Per Mail von SCC erhalten)!"
    TextBox4.SetFocus
    TextBox4.BackColor = vbYellow
    Exit Sub
    Else
    TextBox4.BackColor = vbWhite
    End If
    If TextBox8 = "" Then
    MsgBox "Bitte Versanddatum angeben!"
    TextBox8.SetFocus
    TextBox8.BackColor = vbYellow
    Exit Sub
    Else
    TextBox8.BackColor = vbWhite
    End If
    If TextBox1 = "" Then
    MsgBox "Bitte Kartonanzahl angeben!"
    TextBox1.SetFocus
    TextBox1.BackColor = vbYellow
    Exit Sub
    Else
    TextBox1.BackColor = vbWhite
    End If
    If TextBox2 = "" Then
    MsgBox "Bitte einen Ansprechpartner angeben!"
    TextBox2.SetFocus
    TextBox2.BackColor = vbYellow
    Exit Sub
    Else
    TextBox2.BackColor = vbWhite
    End If
    If TextBox3 = "" Then
    MsgBox "Bitte die Kollektion der zu verschickende Ware angeben!"
    TextBox3.SetFocus
    TextBox3.BackColor = vbYellow
    Exit Sub
    Else
    TextBox3.BackColor = vbWhite
    End If
    '  'Übertragung Werte in Printvorlage
    ' .Range("B6") = Me.TextBox4.Value
    ' .Range("J6") = Me.TextBox8.Value
    ' .Range("B9") = Me.ComboBox1.Value
    ' .Range("J9") = Me.ComboBox3.Value
    ' .Range("B12") = Me.TextBox1.Value
    ' .Range("J12") = Me.TextBox2.Value
    ' .Range("B15") = Me.TextBox3.Value
    ' Prüft die Checkbox und trägt die jeweilige Warengruppe ein und Druckt
    If CheckBox1.Value = True Then
    Worksheets("Retouren_Template").Range("J15") = "APP"
    Else
    Worksheets("Retouren_Template").Range("J15") = ""
    End If
    If (TextBox5.Text  "" And CheckBox1.Value = True) Then GoTo weit
    On Error GoTo la
    la:  If (TextBox5.Text = "" And CheckBox1.Value = True) Then
    TextBox5.Text = InputBox("Das Häkchen zum Versenden von Textil Kartons wurde gesetzt.  _
    Allerdings wurde keine Kartonanzahl angegeben. Bitte geben Sie im unteren Feld eine Anzahl zwischen 1 und 999 Kartons an oder klicken sie auf Abbrechen.")
    If TextBox5.Text = vbchancel Then GoTo weiter
    If TextBox5.Text = vbOK Then GoTo weit
    If CheckBox1.Value = False Then GoTo weiter
    weit:        ActiveSheet.PrintOut Copies:=Me.TextBox5.Value
    End If
    weiter:    If CheckBox3.Value = True Then
    Worksheets("Retouren_Template").Range("J15") = "FTW"
    Else
    Worksheets("Retouren_Template").Range("J15") = ""
    End If
    If (TextBox7.Text  "" And CheckBox3.Value = True) Then GoTo wei
    On Error GoTo lal
    lal: If (TextBox7.Text = "" And CheckBox3.Value = True) Then
    TextBox7.Text = InputBox("Das Häkchen zum Versenden von Schuh Kartons wurde gesetzt.  _
    Allerdings wurde keine Kartonanzahl angegeben. Bitte geben Sie im unteren Feld eine Anzahl zwischen 1 und 999 Kartons an oder klicken sie auf Abbrechen.")
    If TextBox7.Text = vbchancel Then GoTo weiterl
    If TextBox7.Text = vbOK Then GoTo wei
    If CheckBox3.Value = False Then GoTo weiterl
    wei:         ActiveSheet.PrintOut Copies:=Me.TextBox7.Value
    End If
    weiterl:       If CheckBox2.Value = True Then
    Worksheets("Retouren_Template").Range("J15") = "HDW"
    Else
    Worksheets("Retouren_Template").Range("J15") = ""
    End If
    If (TextBox6.Text  "" And CheckBox2.Value = True) Then GoTo weite
    On Error GoTo lala
    lala: If (TextBox6.Text = "" And CheckBox2.Value = True) Then
    TextBox6.Text = InputBox("Das Häkchen zum Versenden von Hartware Kartons wurde gesetzt.  _
    Allerdings wurde keine Kartonanzahl angegeben. Bitte geben Sie im unteren Feld eine Anzahl zwischen 1 und 999 Kartons an oder klicken sie auf Abbrechen.")
    If TextBox6.Text = vbchancel Then Exit Sub
    If TextBox6.Text = vbOK Then GoTo weite
    If CheckBox2.Value = False Then Exit Sub
    If (TextBox6.Text And CheckBox2.Value = True) Then GoTo weite
    weite:       ActiveSheet.PrintOut Copies:=Me.TextBox6.Value
    End If
    End Sub
    

    Private Sub CommandButton2_Click()
    Unload Me
    End Sub
    

    Private Sub userform_activate()
    'TextBox8.Value = Date
    End Sub
    

    Private Sub UserForm_initialize()
    lsumkarton = 0
    TextBox1 = lsumkarton
    ComboBox1.RowSource = "Parameter!A1:A12"
    ComboBox1.ListIndex = 0
    ComboBox3.RowSource = "Parameter!C1:C2"
    ComboBox3.ListIndex = 0
    TextBox5 = ""
    TextBox6 = ""
    TextBox7 = ""
    TextBox8 = Date
    With Worksheets("Retouren_Template")
    .Range("B6") = Me.TextBox4.Value
    .Range("J6") = Me.TextBox8.Value
    .Range("B9") = Me.ComboBox1.Value
    .Range("J9") = Me.ComboBox3.Value
    .Range("B12") = Me.TextBox1.Value
    .Range("J12") = Me.TextBox2.Value
    .Range("B15") = Me.TextBox3.Value
    End With
    'ComboBox1.AddItem "SR NBG"
    'ComboBox1.AddItem "SR Berlin"
    'ComboBox1.AddItem "SR Mainhausen"
    'ComboBox1.AddItem "SR Heilbronn"
    'ComboBox1.AddItem "SR Bonn"
    'ComboBox1.AddItem "SR Hannover"
    'ComboBox1.AddItem "Outdoor Experten"
    'ComboBox1.AddItem "Outdoor Agenturen"
    'ComboBox1.AddItem "Running Experten"
    'ComboBox1.AddItem "GTM HZO"
    'ComboBox1.AddItem "KAM HZO"
    'ComboBox1.AddItem "SMM"
    'ComboBox1.AddItem "Siemes"
    'ComboBox1.AddItem "Teamsport11"
    'ComboBox1.AddItem "Zalando"
    'ComboBox3.AddItem "Adidas"
    'ComboBox3.AddItem "Reebok"
    ' Sperrt die Checkboxen und ändert die Farbe
    Me.CheckBox1 = False
    Me.TextBox5.SpecialEffect = 0
    Me.TextBox5.BackColor = &HC0C0C0
    Me.TextBox5.ForeColor = &HC0C0C0
    Me.TextBox5.Locked = True
    Me.CheckBox3 = False
    Me.TextBox7.SpecialEffect = 0
    Me.TextBox7.BackColor = &HC0C0C0
    Me.TextBox7.ForeColor = &HC0C0C0
    Me.TextBox7.Locked = True
    Me.CheckBox2 = False
    Me.TextBox6.SpecialEffect = 0
    Me.TextBox6.BackColor = &HC0C0C0
    Me.TextBox6.ForeColor = &HC0C0C0
    Me.TextBox6.Locked = True
    End Sub
    

    Private Sub CheckBox1_Click()
    If Not Me.CheckBox1 Then
    Me.TextBox5.SpecialEffect = 0
    Me.TextBox5.BackColor = &HC0C0C0
    Me.TextBox5.ForeColor = &HC0C0C0
    Me.TextBox5.Locked = True
    Else
    Me.TextBox5.SpecialEffect = 2
    Me.TextBox5.BackColor = &HFFFFFF
    Me.TextBox5.ForeColor = &H80000006
    Me.TextBox5.Locked = False
    End If
    End Sub
    

    Private Sub CheckBox3_Click()
    If Not Me.CheckBox3 Then
    Me.TextBox7.SpecialEffect = 0
    Me.TextBox7.BackColor = &HC0C0C0
    Me.TextBox7.ForeColor = &HC0C0C0
    Me.TextBox7.Locked = True
    Else
    Me.TextBox7.SpecialEffect = 2
    Me.TextBox7.BackColor = &HFFFFFF
    Me.TextBox7.ForeColor = &H80000006
    Me.TextBox7.Locked = False
    End If
    End Sub
    

    Private Sub CheckBox2_Click()
    If Not Me.CheckBox2 Then
    Me.TextBox6.SpecialEffect = 0
    Me.TextBox6.BackColor = &HC0C0C0
    Me.TextBox6.ForeColor = &HC0C0C0
    Me.TextBox6.Locked = True
    Else
    Me.TextBox6.SpecialEffect = 2
    Me.TextBox6.BackColor = &HFFFFFF
    Me.TextBox6.ForeColor = &H80000006
    Me.TextBox6.Locked = False
    End If
    End Sub
    

    Private Function calcKarton()
    'Berechung Kartonanzahl
    TextBox1.Text = Val(TextBox5.Text) + Val(TextBox6.Text) + Val(TextBox7.Text)
    End Function
    


  • Nun möchte ich allerdings das anhand der Retouren Nr. in TextBox4 der Barcode generiert wird. Ich habe für die Barcode Generierung folgenden Code:
  • 
    Public Function ContentStringGenerator(content As String) As String
    ' Supports B and C charsets only; values 00-94, 99,101, 103-105 for B, 00-101, 103-105 for  _
    C
    Dim WeightSum As Single
    Const XmmTopt As Single = 0.351
    Const YmmTopt As Single = 0.351
    Const XCompRatio As Single = 0.9
    Const Tbar_Symbol As String * 2 = "11"
    Dim CurBar As Integer
    Dim i, j, k, CharIndex, SymbolIndex As Integer
    Dim tstr2 As String * 2
    Dim tstr1 As String * 1
    Dim ContentString As String ' bars sequence
    Const Asw As String * 1 = "A" ' alpha switch
    Const Dsw As String * 1 = "D" 'digital switch
    Const Arrdim As Byte = 30
    Dim Sw, PrevSw As String * 1  ' switch
    Dim BlockIndex, BlockCount, DBlockMod2, DBlockLen As Byte
    Dim BlockLen(Arrdim) As Byte
    Dim BlockSw(Arrdim) As String * 1
    Dim SymbolValue(0 To 106) As Integer ' values
    Dim SymbolString(0 To 106) As String * 11 'bits sequence
    Dim SymbolCharB(0 To 106) As String * 1  'Chars in B set
    Dim SymbolCharC(0 To 106) As String * 2  'Chars in B set
    For i = 0 To 106 ' values
    SymbolValue(i) = i
    Next i
    ' Symbols in charset B
    For i = 0 To 94
    SymbolCharB(i) = Chr(i + 32)
    Next i
    ' Symbols in charset C
    SymbolCharC(0) = "00"
    SymbolCharC(1) = "01"
    SymbolCharC(2) = "02"
    SymbolCharC(3) = "03"
    SymbolCharC(4) = "04"
    SymbolCharC(5) = "05"
    SymbolCharC(6) = "06"
    SymbolCharC(7) = "07"
    SymbolCharC(8) = "08"
    SymbolCharC(9) = "09"
    For i = 10 To 99
    SymbolCharC(i) = CStr(i)
    Next i
    ' bit sequences
    SymbolString(0) = "11011001100"
    SymbolString(1) = "11001101100"
    SymbolString(2) = "11001100110"
    SymbolString(3) = "10010011000"
    SymbolString(4) = "10010001100"
    SymbolString(5) = "10001001100"
    SymbolString(6) = "10011001000"
    SymbolString(7) = "10011000100"
    SymbolString(8) = "10001100100"
    SymbolString(9) = "11001001000"
    SymbolString(10) = "11001000100"
    SymbolString(11) = "11000100100"
    SymbolString(12) = "10110011100"
    SymbolString(13) = "10011011100"
    SymbolString(14) = "10011001110"
    SymbolString(15) = "10111001100"
    SymbolString(16) = "10011101100"
    SymbolString(17) = "10011100110"
    SymbolString(18) = "11001110010"
    SymbolString(19) = "11001011100"
    SymbolString(20) = "11001001110"
    SymbolString(21) = "11011100100"
    SymbolString(22) = "11001110100"
    SymbolString(23) = "11101101110"
    SymbolString(24) = "11101001100"
    SymbolString(25) = "11100101100"
    SymbolString(26) = "11100100110"
    SymbolString(27) = "11101100100"
    SymbolString(28) = "11100110100"
    SymbolString(29) = "11100110010"
    SymbolString(30) = "11011011000"
    SymbolString(31) = "11011000110"
    SymbolString(32) = "11000110110"
    SymbolString(33) = "10100011000"
    SymbolString(34) = "10001011000"
    SymbolString(35) = "10001000110"
    SymbolString(36) = "10110001000"
    SymbolString(37) = "10001101000"
    SymbolString(38) = "10001100010"
    SymbolString(39) = "11010001000"
    SymbolString(40) = "11000101000"
    SymbolString(41) = "11000100010"
    SymbolString(42) = "10110111000"
    SymbolString(43) = "10110001110"
    SymbolString(44) = "10001101110"
    SymbolString(45) = "10111011000"
    SymbolString(46) = "10111000110"
    SymbolString(47) = "10001110110"
    SymbolString(48) = "11101110110"
    SymbolString(49) = "11010001110"
    SymbolString(50) = "11000101110"
    SymbolString(51) = "11011101000"
    SymbolString(52) = "11011100010"
    SymbolString(53) = "11011101110"
    SymbolString(54) = "11101011000"
    SymbolString(55) = "11101000110"
    SymbolString(56) = "11100010110"
    SymbolString(57) = "11101101000"
    SymbolString(58) = "11101100010"
    SymbolString(59) = "11100011010"
    SymbolString(60) = "11101111010"
    SymbolString(61) = "11001000010"
    SymbolString(62) = "11110001010"
    SymbolString(63) = "10100110000"
    SymbolString(64) = "10100001100"
    SymbolString(65) = "10010110000"
    SymbolString(66) = "10010000110"
    SymbolString(67) = "10000101100"
    SymbolString(68) = "10000100110"
    SymbolString(69) = "10110010000"
    SymbolString(70) = "10110000100"
    SymbolString(71) = "10011010000"
    SymbolString(72) = "10011000010"
    SymbolString(73) = "10000110100"
    SymbolString(74) = "10000110010"
    SymbolString(75) = "11000010010"
    SymbolString(76) = "11001010000"
    SymbolString(77) = "11110111010"
    SymbolString(78) = "11000010100"
    SymbolString(79) = "10001111010"
    SymbolString(80) = "10100111100"
    SymbolString(81) = "10010111100"
    SymbolString(82) = "10010011110"
    SymbolString(83) = "10111100100"
    SymbolString(84) = "10011110100"
    SymbolString(85) = "10011110010"
    SymbolString(86) = "11110100100"
    SymbolString(87) = "11110010100"
    SymbolString(88) = "11110010010"
    SymbolString(89) = "11011011110"
    SymbolString(90) = "11011110110"
    SymbolString(91) = "11110110110"
    SymbolString(92) = "10101111000"
    SymbolString(93) = "10100011110"
    SymbolString(94) = "10001011110"
    SymbolString(95) = "10111101000"
    SymbolString(96) = "10111100010"
    SymbolString(97) = "11110101000"
    SymbolString(98) = "11110100010"
    SymbolString(99) = "10111011110"
    SymbolString(100) = "10111101110"
    SymbolString(101) = "11101011110"
    SymbolString(102) = "11110101110"
    SymbolString(103) = "11010000100"
    SymbolString(104) = "11010010000"
    SymbolString(105) = "11010011100"
    SymbolString(106) = "11000111010"
    X = X / XmmTopt 'mm to pt
    Y = Y / YmmTopt 'mm to pt
    Height = Height / YmmTopt 'mm to pt
    If IsNumeric(content) = True And Len(content) Mod 2 = 0 Then 'numeric, mode C
    WeightSum = SymbolValue(105) ' start-c
    ContentString = ContentString + SymbolString(105)
    i = 0 ' symbol count
    For j = 1 To Len(content) Step 2
    tstr2 = Mid(content, j, 2)
    i = i + 1
    k = 0
    Do While tstr2  SymbolCharC(k)
    k = k + 1
    Loop
    WeightSum = WeightSum + i * SymbolValue(k)
    ContentString = ContentString + SymbolString(k)
    Next j
    ContentString = ContentString + SymbolString(SymbolValue(WeightSum Mod 103))
    ContentString = ContentString + SymbolString(106)
    ContentString = ContentString + Tbar_Symbol
    Else ' alpha-numeric
    ' first digit
    Select Case IsNumeric(Mid(content, 1, 1))
    Case Is = True 'digit
    Sw = Dsw
    Case Is = False 'alpha
    Sw = Asw
    End Select
    BlockCount = 1
    BlockSw(BlockCount) = Sw
    BlockIndex = 1
    BlockLen(BlockCount) = 1 'block length
    i = 2 ' symbol index
    Do While i = 4 Then ' switch to C
    Select Case BlockIndex
    Case Is = 1
    WeightSum = SymbolValue(105) ' Start-C
    ContentString = ContentString + SymbolString(105)
    Case Else
    SymbolIndex = SymbolIndex + 1
    WeightSum = WeightSum + SymbolIndex * SymbolValue(99) 'switch c
    ContentString = ContentString + SymbolString(99)
    End Select
    PrevSw = Dsw
    ' encoding even amount of chars in a D block
    DBlockMod2 = BlockLen(BlockIndex) Mod 2
    If DBlockMod2  0 Then 'even chars always to encode
    DBlockLen = BlockLen(BlockIndex) - DBlockMod2
    Else
    DBlockLen = BlockLen(BlockIndex)
    End If
    For j = 1 To DBlockLen / 2 Step 1
    tstr2 = Mid(content, CharIndex, 2)
    CharIndex = CharIndex + 2
    SymbolIndex = SymbolIndex + 1
    k = 0
    Do While tstr2  SymbolCharC(k)
    k = k + 1
    Loop
    WeightSum = WeightSum + SymbolIndex * SymbolValue(k)
    ContentString = ContentString + SymbolString(k)
    Next j
    If DBlockMod2  0 Then ' switch to B, encode 1 char
    PrevSw = Asw
    SymbolIndex = SymbolIndex + 1
    WeightSum = WeightSum + SymbolIndex * SymbolValue(100) 'switch b
    ContentString = ContentString + SymbolString(100)
    'CharIndex = CharIndex + 1
    SymbolIndex = SymbolIndex + 1
    tstr1 = Mid(content, CharIndex, 1)
    k = 0
    Do While tstr1  SymbolCharB(k)
    k = k + 1
    Loop
    WeightSum = WeightSum + SymbolIndex * SymbolValue(k)
    ContentString = ContentString + SymbolString(k)
    CharIndex = CharIndex + 1
    End If
    Else 'alpha in B mode
    Select Case BlockIndex
    Case Is = 1
    '   PrevSw = Asw
    WeightSum = SymbolValue(104) ' start-b
    ContentString = ContentString + SymbolString(104)
    Case Else
    If PrevSw  Asw Then
    SymbolIndex = SymbolIndex + 1
    WeightSum = WeightSum + SymbolIndex * SymbolValue(100) 'switch b
    ContentString = ContentString + SymbolString(100)
    End If
    End Select
    PrevSw = Asw
    For j = CharIndex To CharIndex + BlockLen(BlockIndex) - 1 Step 1
    tstr1 = Mid(content, j, 1)
    SymbolIndex = SymbolIndex + 1
    k = 0
    Do While tstr1  SymbolCharB(k)
    k = k + 1
    Loop
    WeightSum = WeightSum + SymbolIndex * SymbolValue(k)
    ContentString = ContentString + SymbolString(k)
    Next j
    CharIndex = j
    End If
    Next BlockIndex
    ContentString = ContentString + SymbolString(SymbolValue(WeightSum Mod 103))
    ContentString = ContentString + SymbolString(106)
    ContentString = ContentString + Tbar_Symbol
    End If
    ContentStringGenerator = ContentString
    End Function
    

    'you call this, it's the main worker here. content is the barcode data. r is cell address where you want your bar code to appear
    Sub mainBarCoder(content As String, ByVal r As Range, Optional ByVal barHeight As Integer = 20, _
    Optional fontSize As Integer = 7, _
    Optional sideMargin As Integer = 10)
    Dim data As String
    data = ContentStringGenerator(content)
    Dim i As Integer
    Dim k As Integer
    Dim shapeArr() As String 'to store all the names of the new shapes
    Dim sh As Worksheet
    Set sh = r.Worksheet
    k = Len(data)
    ReDim shapeArr(0 To k + 1)
    'creating the white background
    shapeArr(0) = sh.Shapes.AddShape(msoShapeRectangle, _
    r.Left, r.Top, k + (2 * sideMargin), barHeight + fontSize + 3).Name
    With sh.Shapes.Range(shapeArr(0))
    .Fill.Visible = msoCTrue
    .Fill.ForeColor.RGB = RGB(255, 255, 255)
    .Line.Visible = msoFalse
    End With
    'actual barcode maker
    Dim l As Integer
    Dim startPos As Integer
    For i = 1 To k
    startPos = i
    l = 1
    Do While i k And Mid(data, i, 1) = Mid(data, i + 1, 1) 'checking for continus block
    l = l + 1
    i = i + 1
    Loop
    If CInt(Mid(data, i, 1)) Then
    shapeArr(i) = barDrawer(r, startPos, CInt(Mid(data, i, 1)), l, barHeight, sideMargin)
    End If
    Next i
    Dim grp As Variant
    shapeArr(UBound(shapeArr)) = textBoxDrawer(content, r, barHeight, k, fontSize)
    'grouping all shapes into one unit
    Set grp = ActiveSheet.Shapes.Range(shapeArr).Group
    'This renders barcode shapes into a vector image
    grp.Copy
    r.Select
    sh.PasteSpecial Format:="Picture (Enhanced Metafile)", Link:=False, DisplayAsIcon:=False
    grp.Delete
    End Sub 'This draws the barcode shapes
    Private Function barDrawer(r As Range, X As Integer, ch As Integer, blockLength As Integer, _
    barHeight As Integer, sideMargin As Integer) As String
    Dim sh As Shape
    Set sh = ActiveSheet.Shapes.AddShape(msoShapeRectangle, r.Left + sideMargin + X, r.Top + 3,  _
    blockLength, barHeight)
    sh.Fill.Visible = msoCTrue
    sh.Fill.ForeColor.RGB = RGB(0, 0, 0)
    sh.Line.Visible = msoFalse
    sh.Placement = xlMove
    barDrawer = sh.Name
    End Function
    
    'this draws text box under the barcode
    Private Function textBoxDrawer(content As String, _
    r As Range, _
    highFromTop As Integer, _
    length As Integer, _
    Optional ByVal fontSize As Integer = 7) As String
    Dim textBox As Shape
    Set textBox = r.Worksheet.Shapes.AddShape(msoShapeRectangle, _
    r.Left + 10, r.Top + highFromTop + 3, length, fontSize + 2)
    With textBox
    With .TextFrame2
    .TextRange.Font.Size = fontSize
    .VerticalAnchor = msoAnchorMiddle
    .HorizontalAnchor = msoAnchorCenter
    .MarginBottom = 0
    .AutoSize = msoAutoSizeShapeToFitText
    .MarginTop = 0
    With .TextRange
    With .Font
    .NameComplexScript = "Arial"
    .NameFarEast = "Arial"
    .Name = "Arial"
    .BaselineOffset = 0
    .Spacing = 4
    With .Fill
    .Visible = msoTrue
    .ForeColor.RGB = RGB(0, 0, 0)
    .ForeColor.TintAndShade = 0
    .ForeColor.Brightness = 0
    .Transparency = 0
    .Solid
    End With
    End With
    .Characters.Text = content
    End With
    End With
    .Fill.Visible = msoFalse
    .Line.Visible = msoFalse
    End With
    textBoxDrawer = textBox.Name
    End Function
    
    Sub test()
    Call mainBarCoder("R-20-09-01-000", Range("A3"), 50, 10)
    End Sub

  • Nun möchte ich das dass Makro im UserForm die Retouren Nr. In Textbox4 nimmt und zusätzlich einen Neuen Barcode pro Karton anzahl generiert bsp.: Insgesamt werden 20 Kartons verschickt 10 APP 5 FTW 5 HDW dann sollte die Barcode Generierung so aussehen: Inhalt von Textbox4+001 Textbox4+002 Textbox4+003 Textbox4+005...Textbox4+020, nach jeder Generierung dann der Druck eben 10 APP vorlagen+10 generierte Barcodes dann 10 Drucks mit unterschiedlichen Barcodes und das selbe dann für z.b. die 5 FTW und 5 HDW.
    Nun muss man noch daran denken das es die Barcodes die er generiert nach dem Druck gelöscht werden da sonst diese sich Wahrscheinlich überlappen oder?
    Ich hoffe ihr könnt mir helfen ich bin wirklich am verzweifeln. :(
    hier die Beispiel Datei: https://www.herber.de/bbs/user/138867.xlsm
    Viele Grüße,
    Pascal

    3
    Beiträge zum Forumthread
    Beiträge zu diesem Forumthread

    Betreff
    Datum
    Anwender
    Anzeige
    AW: Generierung eines Barcodes pro Druck
    09.07.2020 08:11:38
    Pascal
    Guten morgen zusammen,
    UPDATE:
    Es würde reichen wenn er beim schließen der Datei alle Bilder (Barcodes) löscht.
    Und im Grunde genommen bräuchte ich nur ein Schleife der so oft die UserForm und das Modul auslöst wie Zahlen im Textfeld stehen.
    AW: Generierung eines Barcodes pro Druck
    09.07.2020 09:40:37
    Pascal
    Hallo zusammen,
    bin wieder etwas weiter gekommen.
    Jetzt bräuchte ich jedoch Hilfe bei einer Schleifen oder Loop.
    Folgender Code:
  • If CheckBox1.Value = True Then
    Worksheets("Retouren_Template").Range("J15") = "APP"
    Else
    Worksheets("Retouren_Template").Range("J15") = ""
    End If
    If (TextBox5.Text "" And CheckBox1.Value = True) Then GoTo weit
    On Error GoTo la
    la: If (TextBox5.Text = "" And CheckBox1.Value = True) Then
    TextBox5.Text = InputBox("Das Häkchen zum Versenden von Textil Kartons wurde gesetzt. Allerdings wurde keine Kartonanzahl angegeben. Bitte geben Sie im unteren Feld eine Anzahl zwischen 1 und 999 Kartons an oder klicken sie auf Abbrechen.")
    If TextBox5.Text = vbchancel Then GoTo weiter
    If TextBox5.Text = vbOK Then GoTo weit
    If CheckBox1.Value = False Then GoTo weiter
    weit: Call mainBarCoder(Worksheets("Retouren_Template").Range("B6"), Range("A3"), 50, 10)
    ActiveSheet.PrintOut Copies:=Me.TextBox5.Value
    End If

  • Ich möchte nun bei: Call mainBarCoder(Worksheets("Retouren_Template").Range("B6"), Range("A3"), 50, 10) eine schleife einfügen die das modul so oft ausführt und das Worksheets("Retouren_Template") Druckt, wie in TextBox5 steht. Also z.b. wenn in Textbox5 eine 63 steht dann soll das Modul 63 aufgerufen werden und 63 drucke angestoßen werden.
    Anzeige
    AW: Generierung eines Barcodes pro Druck
    10.07.2020 06:58:11
    Pascal
    Hallo zusammen,
    mir wurde in einem anderen Forum geholfen.
    hier der Link:
    https://www.ms-office-forum.net/forum/showthread.php?t=368879
    Nun hätte ich noch eine Frage.
    Ich würde gerne zusätzlich für Textbox5 eine Prüfziffer mit anhängen nach jedem Call mainBarCoder also sollte dann so aussehen: TextBox5 + 001, Textbox5 + 002 usw. bis die Schleife eben abgeschlossen ist.
    Hier nochmal der neue Code:
     If CheckBox1.Value = True Then
    Worksheets("Retouren_Template").Range("J15") = "APP"
    Else
    Worksheets("Retouren_Template").Range("J15") = ""
    End If
    If (TextBox5.Text  "" And CheckBox1.Value = True) Then GoTo weit
    On Error GoTo la
    la:  If (TextBox5.Text = "" And CheckBox1.Value = True) Then
    TextBox5.Text = InputBox("Das Häkchen zum Versenden von Textil Kartons wurde gesetzt.  _
    Allerdings wurde keine Kartonanzahl angegeben. Bitte geben Sie im unteren Feld eine Anzahl zwischen 1 und 999 Kartons an oder klicken sie auf Abbrechen.")
    If TextBox5.Text = vbchancel Then GoTo weiter
    If TextBox5.Text = vbOK Then GoTo weit
    If CheckBox1.Value = False Then GoTo weiter
    weit:
    Dim x As Integer
    For x = 1 To CInt(Me.TextBox5.Value)
    Call mainBarCoder(Worksheets("Retouren_Template").Range("B6"), Range("A3"), 50, 10)
    ActiveSheet.PrintOut Copies:=1
    Next x
    End If
    

    Anzeige

    Links zu Excel-Dialogen

    Beliebteste Forumthreads (12 Monate)

    Anzeige

    Beliebteste Forumthreads (12 Monate)

    Anzeige
    Anzeige
    Anzeige