Tetra201
MrExcel MVP
- Joined
- Oct 14, 2016
- Messages
- 4,046
I encountered a need to generate barcodes from alphanumeric strings from within Excel (by the way, Word has a built-in capability for this). So I wrote a piece of VBA code shown below. It was inspired by the posts of yakovleff from this forum.
The resulting barcode is a group of rectangular shapes, so it can be handled as a single object – moved, rotated, etc. It can also be stretched/shrunk as needed without losing the barcode structure. The EncStr argument in the barcode drawing sub is a string of ones and zeros that can be generated by a desired encoding function. I am attaching my Code128B function as an example. Everything else is pretty much self-explanatory.
If you find this barcode generator useful, please provide a feedback.
The resulting barcode is a group of rectangular shapes, so it can be handled as a single object – moved, rotated, etc. It can also be stretched/shrunk as needed without losing the barcode structure. The EncStr argument in the barcode drawing sub is a string of ones and zeros that can be generated by a desired encoding function. I am attaching my Code128B function as an example. Everything else is pretty much self-explanatory.
If you find this barcode generator useful, please provide a feedback.
Code:
Type BarParams
Pos As Long
Width As Byte
End Type
Sub DrawBarcode(EncStr As String, Left As Single, Top As Single, _
SingleWidth As Single, Height As Single, Optional Color As Long)
'
' Parameters:
'
' EncStr - a string of ones and zeros, e.g., "11001011"
' Left - the position (in points) of the upper-left corner of the barcode
' relative to the upper-left corner of the worksheet.
' Top - the position (in points) of the upper-left corner of the barcode
' relative to the upper-left corner of the worksheet.
' SingleWidth - the width (in points) of a single-wide bar or space.
' Height - the height of the bars, in points.
' Color - (optional) the color of bars; if omitted, the color vill be black.
'
Dim TgtSht As Worksheet
Dim Bars() As BarParams
Dim NextBar As Boolean
Dim i, j As Long
Dim BarColl() As Variant
'
Set TgtSht = ActiveSheet
'
ReDim Bars(1 To 1)
Bars(1).Width = 0
NextBar = False
j = 1
'
For i = 1 To Len(EncStr) Step 1
If Mid(EncStr, i, 1) = "1" Then
If Not NextBar Then Bars(j).Pos = i
Bars(j).Width = Bars(j).Width + 1
NextBar = True
Else
If NextBar Then
j = j + 1
ReDim Preserve Bars(1 To j)
Bars(j).Width = 0
End If
NextBar = False
End If
Next i
'
ReDim BarColl(1 To j)
'
For i = 1 To j Step 1
With TgtSht.Shapes.AddShape(msoShapeRectangle, _
Left + (Bars(i).Pos - 1) * SingleWidth, Top, _
Bars(i).Width * SingleWidth, Height)
.Line.Visible = msoFalse
.Fill.ForeColor.RGB = Color
BarColl(i) = .Name
End With
Next i
'
TgtSht.Shapes.Range(BarColl).Group
'
End Sub
Code:
Function Code128B(TxtStr As String) As String
'
' Parameters
'
' TxtSrt - an alphanumeric string; Chr(32) to Chr(106) can be used.
'
Const MaxChB = 94
'
Dim i, j As Long
Dim SymChB(0 To MaxChB) As String * 1
Dim SymEnc As Variant
Dim WgtSum As Long
Dim EncStr As String
'
For i = 0 To 94
SymChB(i) = Chr(i + 32)
Next i
'
SymEnc = Array( _
"11011001100", "11001101100", "11001100110", "10010011000", "10010001100", _
"10001001100", "10011001000", "10011000100", "10001100100", "11001001000", _
"11001000100", "11000100100", "10110011100", "10011011100", "10011001110", _
"10111001100", "10011101100", "10011100110", "11001110010", "11001011100", _
"11001001110", "11011100100", "11001110100", "11101101110", "11101001100", _
"11100101100", "11100100110", "11101100100", "11100110100", "11100110010", _
"11011011000", "11011000110", "11000110110", "10100011000", "10001011000", _
"10001000110", "10110001000", "10001101000", "10001100010", "11010001000", _
"11000101000", "11000100010", "10110111000", "10110001110", "10001101110", _
"10111011000", "10111000110", "10001110110", "11101110110", "11010001110", _
"11000101110", "11011101000", "11011100010", "11011101110", "11101011000", _
"11101000110", "11100010110", "11101101000", "11101100010", "11100011010", _
"11101111010", "11001000010", "11110001010", "10100110000", "10100001100", _
"10010110000", "10010000110", "10000101100", "10000100110", "10110010000", _
"10110000100", "10011010000", "10011000010", "10000110100", "10000110010", _
"11000010010", "11001010000", "11110111010", "11000010100", "10001111010", _
"10100111100", "10010111100", "10010011110", "10111100100", "10011110100", _
"10011110010", "11110100100", "11110010100", "11110010010", "11011011110", _
"11011110110", "11110110110", "10101111000", "10100011110", "10001011110", _
"10111101000", "10111100010", "11110101000", "11110100010", "10111011110", _
"10111101110", "11101011110", "11110101110", "11010000100", "11010010000", _
"11010011100", "11000111010")
ReDim Preserve SymEnc(0 To 106)
'
WgtSum = 104 ' START-B
EncStr = EncStr + SymEnc(104)
For i = 1 To Len(TxtStr) Step 1
j = 0
Do While (Mid(TxtStr, i, 1) <> SymChB(j)) And (j <= MaxChB)
j = j + 1
Loop
If j > MaxChB Then j = 0
WgtSum = WgtSum + i * j
EncStr = EncStr + SymEnc(j)
Next i
Code128B = EncStr + SymEnc(WgtSum Mod 103) + SymEnc(106) + "11"
'
End Function
