"Code128" barcode generator in VBA

yakovleff

New Member
Joined
May 20, 2013
Messages
41
Office Version
  1. 2010
  2. 2007
Platform
  1. Windows
Hello All,

Since the Code93 barcode generator has been developed I've been thinking of Code128. And finally I've developed it! As before want to share it with other Mr.Excel users and Google searchers. :)
It was much easier and faster than Code93 as Code128 is simpler to encode and yet more powerful particularly for strings of digits.

Main features:
- Main symbology has been picked from CODE128 SYMBOLOGY;
- The sub uses Shapes collection to draw lines of a barcode instead of special fonts;
- Sub draws a barcode onto a target Worksheet from beginning position which is defined by horizontal offset (X), vertical offset (Y) measured in mm of required height in mm; bar width is defined in pt;
- Code uses "B" and "C" charsets only;
- A "tweak" for numeric strings has been implemented: If a numeric string to be encoded is of odd length the first symbol is encoded as "B"; the rest of symbols are encoded as "C". This tweak significantly reduces barcode length for a numeric string.
- 10% bars overlapping is used for drawing as this value showed the best result at scanning tests.

Weaknesses/incompletenesses:
- Code does not generate any special "instruction" symbols: symbols 95-98, 100, 102 in charset "B" and 102 in charset "C".
- Code does not check the length of the encoded string;
- A complete barcode width is not pre-calulated and drawing begins from left which can cause unexpected overhangs;
- Sub does not support a barcode inclination; just vertical orientation
- A barcode position is only correct when 100% print size is set.
- Obviously version-depended code (different versions/OSs/printers can vary the result, NOT tested).

Win 7 Ultimate, MS Office 2007 were used to develop and tests.
So, the main code is:
Code:
<code>
Sub Code128Generate(ByVal X As Single, ByVal Y As Single, ByVal Height As Single, ByVal LineWeight As Single, _
                  ByRef TargetSheet As Worksheet, ByVal Content As String)
' Supports B and C charsets only; values 00-94, 99,101, 103-105 for B, 00-101, 103-105 for C
' X, Y - top-left corner coordinates
' X in mm (0.376042)
' Y in mm (0.341)
' Height in mm
' LineWeight in pt

Const Tbar_Symbol As String * 2 = "11" ' termination bar
Dim WeightSum As Single
Dim CurBar As Integer
Dim i, j, k, FirstSymbol As Integer
Dim tstr2 As String * 2
Dim tstr1 As String * 1
Dim ContentString As String ' bars sequence

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 / 0.376042 'mm to pt
Y = Y / 0.341 'mm to pt
Height = Height / 0.341 'mm to pt

If IsNumeric(Content) = True Then  ' value is numeric
   i = 1 'symbol and weight index
   If Len(Content) Mod 2 = 1 Then 'odd
       WeightSum = SymbolValue(104) ' start-b
       ContentString = ContentString + SymbolString(104)
      tstr1 = Mid(Content, 1, 1)
      k = 0
      Do While tstr1 <> SymbolCharB(k)
         k = k + 1
      Loop
      WeightSum = WeightSum + i * SymbolValue(k)
      ContentString = ContentString + SymbolString(k)
      i = i + 1
      WeightSum = WeightSum + i * SymbolValue(99) 'Code-C
      ContentString = ContentString + SymbolString(99) 'Code-C
      Content = Right(Content, Len(Content) - 1) 'cut 1st symbol
   Else 'even
      WeightSum = SymbolValue(105) ' start-c
      ContentString = ContentString + SymbolString(105)
      i = 0
   End If
   
   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)

   
   Else ' alpha-numeric
   WeightSum = SymbolValue(104) ' start-b
   ContentString = ContentString + SymbolString(104)
   i = 0 ' symbol count
   For j = 1 To Len(Content) Step 1
      tstr1 = Mid(Content, j, 1)
      i = i + 1
      k = 0
      Do While tstr1 <> SymbolCharB(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)

End If

ContentString = ContentString + Tbar_Symbol

'Barcode drawing
CurBar = 0

For i = 1 To Len(ContentString)
    Select Case Mid(ContentString, i, 1)
    Case 0
        CurBar = CurBar + 1
    Case 1
        CurBar = CurBar + 1
' (CurBar * LineWeight) * [B]0.9[/B] -  here is 10% overlapping :-)
        With TargetSheet.Shapes.AddLine(X + (CurBar * LineWeight) * 0.9, Y, X + (CurBar * LineWeight) * 0.9, (Y + Height)).Line
        .Weight = LineWeight
        .ForeColor.RGB = vbBlack ' my Excel writes light-blue lines by default, so the color is forcibly switched
        End With
    End Select
Next i

End Sub
</code>

Barcode reading has been tested by an Android phone (Accusoft Barcode Scanner program) as well as by a PROTON IMS-3100 and a cheap Chineese (PAN.CODE A500) hardware scanners.

Hope it would be of any help to anybody. :)
Would be helpful for me if you comment this thread when using it in your apps.

Regards,
Yakovleff
 
@yakovleff
It was project on upwork, I wrote this before applying for that project. I was pretty successful but I was too late to apply for this job. :confused: I'm still looking for freelance work in excel VBA.
Anyway, Here's a first snippet of your brilliant code which I modified. I used it to return barcode info like "1010101". There's no drawing from this function. Not much else has changed here.

VBA 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 <= Len(content)
          Select Case IsNumeric(Mid(content, i, 1))
          Case Is = True 'digit
             Sw = Dsw
          Case Is = False 'alpha
             Sw = Asw
          End Select

          If Sw = BlockSw(BlockCount) Then
             BlockLen(BlockCount) = BlockLen(BlockCount) + 1
          Else
             BlockCount = BlockCount + 1
             BlockSw(BlockCount) = Sw
             BlockLen(BlockCount) = 1
             BlockIndex = BlockIndex + 1


          End If

          i = i + 1
       Loop



       'encoding
       CharIndex = 1 'index of Content character
       SymbolIndex = 0

       For BlockIndex = 1 To BlockCount ' encoding by blocks


          If BlockSw(BlockIndex) = Dsw And BlockLen(BlockIndex) >= 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

Below code is used for drawing. It draws the shapes of barcode then renders it to vector image and deletes the old shapes. Being an image it can be moved and resized. It's lighter for excel to handle too. It will not work on older versions of office. About the image, it's a vector image hence doesn't get pixelated and needs extremely little space compared to jpg.

Also I added 'quite zone' according to code128 protocols (as stated on wiki). Although I suppose it's not necessary and most don't follow it.

VBA Code:
Option Explicit

'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

Finally you can call mainBarCoder sub to do your work like this.

VBA Code:
Sub test()
     Call mainBarCoder("Hello World!", Range("B4"), 30, 10)
End Sub


Everything was written from experimental perspective. I haven't tested it for any commercial application. So there's the disclaimer.
If you go through the code then kindly critique.


View attachment 14527

Hello together,

i have a short question.

how can I adjust the width of the barcode?

Because my scanner does not scan some barcodes.

And I suspected that the barcode is too narrow.

Thanks & best regards,

Pocher
 

Attachments

  • Barcode size.PNG
    Barcode size.PNG
    19 KB · Views: 32
Upvote 0

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.
how can I adjust the width of the barcode?
Hello, please see the notes to message #8 in the thread.
2. Maximum width of a barcode can be set now. Optional MaxWidth (in mm) argument has been added. The code will check and reduce bar width in order to place whole the barcode into the width limit. This may cause extremely narrow bar widths and lacks of reading.
If MaxWidth is omitted LineWeight would be used unchanged.
3. The mm to pt ratio has been changed to 0.351 (1 mm = 2.8 pt) as it is pre-defined in Excel. It seems it shows better results in 100% scale printing. To restore your settings just set constants XmmTopt, YmmTopt to preferred values.
4. The constant XCompRatio is now responsible for "overlapping" of the bar strokes.
And here is the Gdrive and Dropbox links for download.

And the user SmartyPants has offered smarter solution with conversion bars to vector graphics. I havent updated my code with his/her adjustments so explore it yourself if you wish to use it.
 
Upvote 0
Hallo Jakowleff,

Ich habe jetzt beschlossen, meine Druckvorlage anzupassen und Ihren Originalcode zu verwenden. Ich möchte mich noch einmal bei Ihnen dafür bedanken, dass Sie diesen Code mit uns geteilt haben. Ich suchte nach einem Barcode-Generator für den internen und externen Gebrauch und fand hier, wonach ich suchte. Vielen, vielen, vielen Dank!!!!
 
Upvote 0
@yakovleff
It was project on upwork, I wrote this before applying for that project. I was pretty successful but I was too late to apply for this job. :confused: I'm still looking for freelance work in excel VBA.
Anyway, Here's a first snippet of your brilliant code which I modified. I used it to return barcode info like "1010101". There's no drawing from this function. Not much else has changed here.

VBA 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 <= Len(content)
          Select Case IsNumeric(Mid(content, i, 1))
          Case Is = True 'digit
             Sw = Dsw
          Case Is = False 'alpha
             Sw = Asw
          End Select

          If Sw = BlockSw(BlockCount) Then
             BlockLen(BlockCount) = BlockLen(BlockCount) + 1
          Else
             BlockCount = BlockCount + 1
             BlockSw(BlockCount) = Sw
             BlockLen(BlockCount) = 1
             BlockIndex = BlockIndex + 1


          End If

          i = i + 1
       Loop



       'encoding
       CharIndex = 1 'index of Content character
       SymbolIndex = 0

       For BlockIndex = 1 To BlockCount ' encoding by blocks


          If BlockSw(BlockIndex) = Dsw And BlockLen(BlockIndex) >= 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

Below code is used for drawing. It draws the shapes of barcode then renders it to vector image and deletes the old shapes. Being an image it can be moved and resized. It's lighter for excel to handle too. It will not work on older versions of office. About the image, it's a vector image hence doesn't get pixelated and needs extremely little space compared to jpg.

Also I added 'quite zone' according to code128 protocols (as stated on wiki). Although I suppose it's not necessary and most don't follow it.

VBA Code:
Option Explicit

'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

Finally you can call mainBarCoder sub to do your work like this.

VBA Code:
Sub test()
     Call mainBarCoder("Hello World!", Range("B4"), 30, 10)
End Sub


Everything was written from experimental perspective. I haven't tested it for any commercial application. So there's the disclaimer.
If you go through the code then kindly critique.


View attachment 14527

dear friends, how to run this macro for the entire column? from C1 to C30?
 
Upvote 0
dear friends, how to run this macro for the entire column? from C1 to C30?
Hello, make a For ... Next or Do ... Loop or For Each .... Next cycle in an external Sub or Function to run through your source cells entering your source cell's .Value property as the Content argument for the Code128Generate_v2 macro.

Strongly suggest to study VBA basics as a cycle is one of fundamental things in any language.
Regards,
 
Upvote 0
Hi Yakovleff & SmartyPants,

Many thanks for making this extremely useful code / tool!

I have a question.

Is it possible to include a carriage return into a barcode using your code? I can see that the nit sequence contains the symbol string for a carriage return but I cannot fathom how to implement into a barcode.

Example of what I'm looking for is ABC<CR>123


Thanks again!
 
Upvote 0
Hi Yakovleff & SmartyPants,

Many thanks for making this extremely useful code / tool!

I have a question.

Is it possible to include a carriage return into a barcode using your code? I can see that the nit sequence contains the symbol string for a carriage return but I cannot fathom how to implement into a barcode.

Example of what I'm looking for is ABC<CR>123


Thanks again!
Just noticed that the code only supports B and C and think carriage return is under A.

But thanks anyway!
 
Upvote 0
Just noticed that the code only supports B and C and think carriage return is under A.

But thanks anyway!
Hello,
Yes, all of special unprinted symbols are in the A charset. I hadnt included the A charset into the macro as supposed it quite useless ;). Do you really need it?
 
Upvote 0
I realise this is an old topic, but still would like to add this in case anybody needs it :)

First of all : Great code for educational purposes and practical use, many thanks @yakovleff & @smartyPants for sharing this !

I took the liberty to make a few small changes/additions to smartyPants his code for my usage scenario :
  • Added a new boolean option CodeTypeA to encode as the whole as Code128A
    • This defaults to False and is optional
    • This mode also processes TAB/ENTER commands (using the lowercase chars etc)
    • Command characters are replaced by a space on the text label by default
  • Added a new boolean option ShowText to show or hide the text label
    • This defaults to False now and is optional, before the text was always shown

VBA Code:
Public Function ContentStringGenerator(content As String, Optional CodeTypeA As Boolean) As String
    'Supports charset A (explicit) or B and C ; 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, kspec, 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 C 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

    '******
    ' ADD * : switch to start-a if CodeTypeA is True
    '******
    If CodeTypeA = True Then
       WeightSum = SymbolValue(103) ' start-a
       ContentString = ContentString + SymbolString(103)
       For j = 1 To Len(content) 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
       ContentString = ContentString + SymbolString(SymbolValue(WeightSum Mod 103))
       ContentString = ContentString + SymbolString(106)
       ContentString = ContentString + Tbar_Symbol
    '******
    
    ElseIf 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 <= Len(content)
          Select Case IsNumeric(Mid(content, i, 1))
          Case Is = True 'digit
             Sw = Dsw
          Case Is = False 'alpha
             Sw = Asw
          End Select

          If Sw = BlockSw(BlockCount) Then
             BlockLen(BlockCount) = BlockLen(BlockCount) + 1
          Else
             BlockCount = BlockCount + 1
             BlockSw(BlockCount) = Sw
             BlockLen(BlockCount) = 1
             BlockIndex = BlockIndex + 1


          End If

          i = i + 1
       Loop



       'encoding
       CharIndex = 1 'index of Content character
       SymbolIndex = 0

       For BlockIndex = 1 To BlockCount ' encoding by blocks


          If BlockSw(BlockIndex) = Dsw And BlockLen(BlockIndex) >= 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

VBA Code:
Option Explicit

Sub ExampleCreateBarcode()
     Call mainBarCoder("EXAMPLESm'--------mTAB:iNEWLINE:m", Range("B4"), 30, 10, , True, True)
End Sub

'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, _
                            Optional CodeTypeA As Boolean = False, Optional ShowText As Boolean = False)
    Dim data As String
    data = ContentStringGenerator(content, CodeTypeA)
    
    Dim i As Integer
    Dim k As Integer
    Dim non_chars() As Variant
    Dim a As Variant
    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
    
    '******
    ' ADD * : switch to show/hide text below barcode
    '******
    
    If ShowText = True Then
        
        '******
        ' ADD * : switch to process as code 128 a (to enable TAB / ENTER / etc)
        '******
        If CodeTypeA = True Then
            non_chars = Array("a", "b", "c", "d", "e", "f", "g", "h", "i", _
                          "j", "k", "l", "m", "n", "o", "p", "q", "r", _
                          "s", "t", "u", "v", "w", "x", "y", "z", "{", _
                          "|", "}", "~", "`") 'list of command codes to exclude from text label
                          
            For Each a In non_chars
                content = Replace(content, a, " ") 'show all command codes as spaces on text label
            Next a
        End If
        '******
        
        shapeArr(UBound(shapeArr)) = textBoxDrawer(content, r, barHeight, k, fontSize)
    
    End If
    
    '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:="Image (Enhanced Metafile)", link:=False, DisplayAsIcon:=False ' Default
    
    '******
    ' ERR * : default code could not paste enhanced metafile in my language of excel
    '******
    '
    'sh.PasteSpecial Format:="Afbeelding (enhanced metabestand)", link:=False, DisplayAsIcon:=False ' Dutch (for other languages check marco recorder)
    '
    '******
    
    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
 
Upvote 0

Forum statistics

Threads
1,215,111
Messages
6,123,155
Members
449,098
Latest member
Doanvanhieu

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top