Attribute VB_Name = "ModulDataMatrix"

Option Explicit

' creates Data Matrix barcode symbol as shape in Excel cell.

' param text to encode
' param rectangle boolean, default autodetect on cell dimension
' Data Matrix symbol creation according ISO/IEC 16022:2006
Public Function DataMatrix(text As String, Optional rectangle As Integer = -2) As
String
Attribute DataMatrix.VB_Description = "Draw DataMatrix barcode"
Attribute DataMatrix.VB_ProcData.VB_Invoke_Func = " \n18"
On Error GoTo failed
If Not TypeOf Application.Caller Is Range Then Err.Raise 513, "DataMatrix", "Call
only from sheet"
Dim enc As String, en As String, el As Long, k As Variant, l As Long
Dim h As Long, w As Long, nc As Byte, nr As Byte, shp As Shape
Dim fw As Integer, fh As Integer, i As Long, j As Long, b As Double
Dim c As Long, r As Double, s As Long, x As Long, y As Long, txt As String
Dim fColor As Long, bColor As Long, line As Long
fColor = vbBlack: bColor = vbBlack: line = xlHairline ' redraw graphic ?
For Each shp In Application.Caller.Parent.Shapes
If shp.Name = Application.Caller.Address Then
If shp.Title = text Then Exit Function ' same as prev ?
fColor = shp.Fill.ForeColor.RGB ' remember format
bColor = shp.line.ForeColor.RGB
line = shp.line.Weight
shp.Delete
End If
Next shp
txt = IIf(text = "", " ", (text)): l = Len(txt)
For i = 1 To l ' ASCII mode encoding
c = Asc(Mid(txt, i, 1)): r = 0
If i < l Then r = Asc(Mid(txt, i + 1, 1))
If c > 47 And c < 58 And r > 47 And r < 58 Then
enc = enc + Chr((c - 48) * 10 + r - 48 + 130) ' 2 digits
i = i + 1
ElseIf (c > 127) Then ' extended char
enc = enc + Chr(235) + Chr(c - 127)
Else
enc = enc + Chr(c + 1)
End If
Next i
For x = 0 To 2 ' C40, TEXT and X12 modes encoding
k = Array(Array(230, 31, 0, 0, 32, 9, 32 - 3, 47, 1, 33, 57, 9, 48 - 4, 64, 1,
58 - 15, 90, 9, 65 - 14, 95, 1, 91 - 22, 127, 2, 96, 255, 1, 0), _
Array(239, 31, 0, 0, 32, 9, 32 - 3, 47, 1, 33, 57, 9, 48 - 4, 64, 1,
58 - 15, 90, 2, 64, 95, 1, 91 - 22, 122, 9, 97 - 14, 127, 2, 123 - 27, 255, 1, 0),
_
Array(238, 12, 8, 0, 13, 9, 13, 31, 8, 0, 32, 9, 32 - 3, 41, 8, 0,
42, 9, 42 - 1, 47, 8, 0, 57, 9, 48 - 4, 64, 8, 0, 90, 9, 65 - 14, 255, 8, 0))(x)
b = 0: h = 0
en = Chr(k(0)) ' start switch
For i = 1 To l
If h = 0 And i = l Then Exit For
c = Asc(Mid(txt, i, 1))
If c > 127 And k(0) <> 238 Then
b = b * 40 + 1: b = b * 40 + 30
h = h + 2: c = c - 128 ' hi bit in C40 & TEXT
End If
 For j = 1 To 90 Step 3 ' select char set
If c <= k(j) Then Exit For
Next j
s = k(j + 1) ' set
If s = 8 Or (s = 9 And h = 0 And i = l) Then
en = txt + txt
Exit For ' char not in set, next mode
End If
If s < 5 And h = 2 And i = l Then 'Exit For ' last char in ASCII
b = b * 40: h = 3 ' add padding
i = i - 1
Else
If s < 5 Then b = b * 40 + s: h = h + 1 ' set
b = b * 40 + c - k(j + 2): h = h + 1 ' char offset
If h Mod 3 = 2 And k(0) <> 238 And i = l Then b = b * 40: h = h + 1 '
add padding
End If
Do While h > 2 ' pack 3 chars in 2 bytes
h = h - 3: r = 40& ^ h
c = Int(b / r) + 1
en = en + Chr((c \ 256) And 255) + Chr(c And 255)
b = b - c * r + r
Loop
Next i
en = en + Chr(254) ' return to ASCII
For i = i - h To l ' add last chars
c = Asc(Mid(txt, i, 1))
If (c > 127) Then en = en + Chr(235)
en = en + Chr((c And 127) + 1)
Next i
If Len(en) < Len(enc) Then enc = en ' take shorter
Next x

j = (l + 1) And -4: b = 0: en = Chr(240) ' switch to Edifact

For i = 1 To j
If i < j Then ' encode char
c = Asc(Mid(txt, i, 1))
If c < 32 Or c > 94 Then Exit For ' not in set
Else
c = 31 ' return to ASCII
End If
b = b * 64 + (c And 63)
If (i And 3) = 0 Then ' 4 data in 3 bytes
en = en + Chr(b \ 65536) + Chr((b \ 256) And 255) + Chr(b And 255)
b = 0
End If
Next i
If j > 0 And i > j Then
For i = i - 1 To l ' add last chars
c = Asc(Mid(txt, i, 1))
If (c > 127) Then en = en + Chr(235)
en = en + Chr((c And 127) + 1)
Next i
If Len(en) < Len(enc) Then enc = en ' take shorter
End If

en = Chr(231) ' Base256 encoding

If l > 250 Then en = en + Chr((l \ 250 + 37) And 255) ' len high byte
en = en + Chr((l Mod 250 + (149 * (Len(en) + 1)) Mod 255 + 1) And 255) ' low
For i = 1 To l ' data in 255 state algo
en = en + Chr((Asc(Mid(txt, i, 1)) + (149 * (Len(en) + 1)) Mod 255 + 1) And
255)
Next i
If Len(en) < Len(enc) Then enc = en ' take shorter

' compute symbol size

nc = 1: nr = 1: j = -1: b = 1: el = Len(enc) ' symbol size, regions, region size
If (rectangle = -1 Or (rectangle = -2 And (Application.Caller.MergeArea.Width * 3 >
Application.Caller.MergeArea.Height * 4))) And el < 50 Then ' rectangular pattern ?
k = Array(16, 7, 28, 11, 24, 14, 32, 18, 32, 24, 44, 28) ' symbol width,
checkwords
Do
j = j + 1: w = k(j) ' width w/o finder pattern
h = 6 + (j And 12) ' height
l = w * h / 8: j = j + 1 ' # of bytes in symbol
Loop While l - k(j) < el ' data fit in symbol ?
If w > 25 Then nc = 2 ' column regions
Else ' square symbol
w = 6: h = w
i = 2 ' size increment
k = Array(5, 7, 10, 12, 14, 18, 20, 24, 28, 36, 42, 48, 56, 68, 84, _
112, 144, 192, 224, 272, 336, 408, 496, 620) ' checkwords
Do
If j = UBound(k) Then Err.Raise 514, "DataMatrix", "Message too long"
j = j + 1
If w > 11 * i Then i = 4 + i And 12 ' advance increment
w = w + i: h = w
l = (w * h) \ 8
Loop While l - k(j) < el
If w > 27 Then nr = 2 * (w \ 54) + 2: nc = nr ' regions
If l > 255 Then b = 2 * (l \ 512) + 2 ' blocks
End If
s = k(j) ' checkwords
fw = w / nc: fh = h / nr ' region size

If el < l - s Then enc = enc + Chr(129): el = el + 1 ' first padding

Do While el < l - s ' add more padding
el = el + 1
enc = enc + Chr((((149 * el) Mod 253) + 130) Mod 254)
Loop

enc = enc + Space(s) ' compute Reed Solomon error detection and correction
Dim rs(70) As Integer, rc(70) As Integer ' RS code
Dim lg(256) As Integer, ex(255) As Integer ' log/exp table
s = s / b: j = 1
For i = 0 To 254
ex(i) = j: lg(j) = i ' compute log/exp table of Galois field
j = j + j: If j > 255 Then j = j Xor 301 ' GF polynomial a^8+a^5+a^3+a^2+1 =
100101101b = 301
Next i
rs(s + 1) = 0 ' compute RS generator polynomial
For i = 0 To s
rs(s - i) = 1
For j = s - i + 1 To s
rs(j) = rs(j + 1) Xor ex((lg(rs(j)) + i) Mod 255)
Next j
Next i
For c = 1 To b ' compute RS correction data for each block
 For i = 0 To s: rc(i) = 0: Next i
For i = c To el Step b
x = rc(0) Xor Asc(Mid(enc, i, 1))
For j = 1 To s
rc(j - 1) = rc(j) Xor IIf(x, ex((lg(rs(j)) + lg(x)) Mod 255), 0)
Next j
Next i
For i = 0 To s - 1 ' add interleaved correction data
Mid(enc, el + c + i * b, 1) = Chr(rc(i))
Next i
Next c

With Application.Caller.Parent.Shapes
b = .Count + 1 ' layout DataMatrix barcode
For i = 0 To h + 2 * nr - 1 Step fh + 2 ' finder horizontal
For j = 0 To w + 2 * nc - 1
.AddShape(msoShapeRectangle, j, i + fh + 1, 1, 1).Name =
Application.Caller.Address
If (j And 1) = 0 Then .AddShape(msoShapeRectangle, j, i, 1, 1).Name =
Application.Caller.Address
Next j
Next i
For i = 0 To w + 2 * nc - 1 Step fw + 2 ' finder vertical
For j = 0 To h - 1
.AddShape(msoShapeRectangle, i, j + (j \ fh) * 2 + 1, 1, 1).Name =
Application.Caller.Address
If (j And 1) = 1 Then .AddShape(msoShapeRectangle, i + fw + 1, j + (j \
fh) * 2, 1, 1).Name = Application.Caller.Address
Next j
Next i
'layout data
s = 2: c = 0: r = 4 ' step,column,row of data position
For i = 1 To l
If (r = h - 3 And c = -1) Then ' corner A
k = Array(w, 6 - h, w, 5 - h, w, 4 - h, w, 3 - h, w - 1, 3 - h, 3, 2,
2, 2, 1, 2)
ElseIf r = h + 1 And c = 1 And (w And 7) = 0 And (h And 7) = 6 Then '
corner D
k = Array(w - 2, -h, w - 3, -h, w - 4, -h, w - 2, -1 - h, w - 3, -1 -
h, w - 4, -1 - h, w - 2, -2, -1, -2)
Else
If r = 0 And c = w - 2 And (w And 3) Then i = i - 1: GoTo continue '
corner B
If r < 0 Or c >= w Or r >= h Or c < 0 Then ' outside
s = -s: r = r + 2 + s / 2: c = c + 2 - s / 2 ' turn around
Do While r < 0 Or c >= w Or r >= h Or c < 0
r = r - s: c = c + s
Loop
End If
If r = h - 2 And c = 0 And (w And 3) Then ' corner B
k = Array(w - 1, 3 - h, w - 1, 2 - h, w - 2, 2 - h, w - 3, 2 - h, w
- 4, 2 - h, 0, 1, 0, 0, 0, -1)
ElseIf r = h - 2 And c = 0 And (w And 7) = 4 Then ' corner C
k = Array(w - 1, 5 - h, w - 1, 4 - h, w - 1, 3 - h, w - 1, 2 - h, w
- 2, 2 - h, 0, 1, 0, 0, 0, -1)
ElseIf r = 1 And c = w - 1 And (w And 7) = 0 And (h And 7) = 6 Then '
omit corner D
i = i - 1: GoTo continue
Else
 k = Array(0, 0, -1, 0, -2, 0, 0, -1, -1, -1, -2, -1, -1, -2, -2, -
2) ' nominal layout
End If
End If
el = Asc(Mid(enc, i, 1))
For j = 0 To 15 Step 2 ' layout each bit
If el And 1 Then
x = c + k(j): y = r + k(j + 1)
If x < 0 Then x = x + w: y = y + 4 - ((w + 4) And 7) ' wrap around
If y < 0 Then y = y + h: x = x + 4 - ((h + 4) And 7)
.AddShape(msoShapeRectangle, x + 2 * (x \ fw) + 1, y + 2 * (y \ fh)
+ 1, 1, 1).Name = Application.Caller.Address
End If
el = el \ 2
Next j
continue:
r = r - s: c = c + s ' diagonal step
Next i
For i = (w And -4) + 1 To w ' unfilled corner
.AddShape(msoShapeRectangle, i, i, 1, 1).Name = Application.Caller.Address
Next i
b = .Count - b
ReDim shps(b) As Integer ' group all shapes
For i = .Count To 1 Step -1
If .Range(i).Name = Application.Caller.Address Then
shps(b) = i: b = b - 1
If b < 0 Then Exit For
End If
Next i
s = 2 ' padding around symbol
x = Application.Caller.MergeArea.Width * w / (w + s)
y = Application.Caller.MergeArea.Height * h / (h + s) * (w + s) / (h + s)
If x > y Then x = y
With .Range(shps).Group
.Fill.ForeColor.RGB = fColor ' format barcode shape
.line.ForeColor.RGB = bColor
.line.Weight = line
.Width = x ' fit symbol in excel cell
.Height = .Width * (h + s) / (w + s)
.Left = Application.Caller.Left + (Application.Caller.MergeArea.Width
- .Width) / 2
.Top = Application.Caller.Top + (Application.Caller.MergeArea.Height
- .Height) / 2
.Name = Application.Caller.Address ' link shape to data
.Title = text
.AlternativeText = "DataMatrix barcode, " & (w + 2 * nc) & "x" & (h + 2 *
nr) & " cells"
.LockAspectRatio = True
.Placement = xlMove
End With
End With
failed:
If Err.Number Then DataMatrix = "ERROR DataMatrix: " & Err.Description
End Function