jesso

Attribute VB_Name = „ModulQRcode“
Option Explicit
Dim mat() As Byte ‚ matrix of QR

‚ QR Code 2005 bar code symbol creation according ISO/IEC 18004:2006
‚ param text to encode
‚ param level optional: quality level LMQH
‚ param version optional: minimum version size (-3:M1, -2:M2, .. 1, .. 40)
‚ creates QR and micro QR bar code symbol as shape in Excel cell.
‚ Kanji mode needs the custom property ‚kanji‘ of the Application.Caller sheet to convert from unicode to kanji
‚ the string contains the 6879 chars of Kanji followed by the 6879 equivalent unicode chars
Public Function QRCode(text As String, Optional level As String, Optional version As Integer = 1) As String
Attribute QRCode.VB_Description = „Draw QR code“
Attribute QRCode.VB_ProcData.VB_Invoke_Func = “ \n18″
On Error GoTo failed
If Not TypeOf Application.Caller Is Range Then Err.Raise 513, „QR code“, „Call only from sheet“
Dim mode As Byte, lev As Byte, s As Long, a As Long, blk As Long, ec As Long
Dim i As Long, j As Long, k As Long, l As Long, c As Long, b As Long, txt As String
Dim w As Long, x As Long, y As Long, v As Double, el As Long, eb As Long
Dim shp As Shape, m As Long, p As Variant, ecw As Variant, ecb As Variant
Dim k1 As String, k2 As String, fColor As Long, bColor As Long, line As Long
Const alpha = „0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ $%*+-./:“

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
For Each ecw In ActiveWorkbook.Worksheets
For Each p In ecw.CustomProperties ‚ look for kanji conversion string
If p.Name = „kanji“ Then If Len(p.Value) > 10000 Then k1 = p.Value
Next p
Next ecw
lev = (InStr(„LMQHlmqh0123“, level) – 1) And 3
For i = 1 To Len(text) ‚ compute mode
c = AscW(Mid(text, i, 1))
If c < 48 Or c > 57 Then
If mode = 0 Then mode = 1 ‚ alphanumeric mode
If InStr(alpha, ChrW(c)) = 0 Then
If mode = 1 Then mode = 2 ‚ binary or kanji ?
If c < 32 Or c > 126 Then
If InStr(Len(k1) / 2 + 1, k1, ChrW(c)) = 0 Then mode = 2: Exit For ‚ binary
mode = 3 ‚ kanji
End If
End If
End If
Next i
txt = IIf(mode = 2, utf16to8(text), text) ‚ for reader conformity
l = Len(txt)
w = Int(l * Array(10 / 3, 11 / 2, 8, 13)(mode) + 0.5) ‚ 3 digits in 10 bits, 2 chars in 11 bits, 1 byte, 13 bits/byte
p = Array(Array(10, 12, 14), Array(9, 11, 13), Array(8, 16, 16), Array(8, 10, 12))(mode) ‚ # of bits of count indicator
‚ error correction words L,M,Q,H and blocks L,M,Q,H for all version sizes (99=N/A)
ecw = Array(Array(2, 5, 6, 8, 7, 10, 15, 20, 26, 18, 20, 24, 30, 18, 20, 24, 26, 30, 22, 24, 28, 30, 28, 28, 28, 28, 30, 30, 26, 28, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30), _
Array(99, 6, 8, 10, 10, 16, 26, 18, 24, 16, 18, 22, 22, 26, 30, 22, 22, 24, 24, 28, 28, 26, 26, 26, 26, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28), _
Array(99, 99, 99, 14, 13, 22, 18, 26, 18, 24, 18, 22, 20, 24, 28, 26, 24, 20, 30, 24, 28, 28, 26, 30, 28, 30, 30, 30, 30, 28, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30), _
Array(99, 99, 99, 99, 17, 28, 22, 16, 22, 28, 26, 26, 24, 28, 24, 28, 22, 24, 24, 30, 28, 28, 26, 28, 30, 24, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30))
ecb = Array(Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 4, 4, 4, 4, 4, 6, 6, 6, 6, 7, 8, 8, 9, 9, 10, 12, 12, 12, 13, 14, 15, 16, 17, 18, 19, 19, 20, 21, 22, 24, 25), _
Array(1, 1, 1, 1, 1, 1, 1, 2, 2, 4, 4, 4, 5, 5, 5, 8, 9, 9, 10, 10, 11, 13, 14, 16, 17, 17, 18, 20, 21, 23, 25, 26, 28, 29, 31, 33, 35, 37, 38, 40, 43, 45, 47, 49), _
Array(1, 1, 1, 1, 1, 1, 2, 2, 4, 4, 6, 6, 8, 8, 8, 10, 12, 16, 12, 17, 16, 18, 21, 20, 23, 23, 25, 27, 29, 34, 34, 35, 38, 40, 43, 45, 48, 51, 53, 56, 59, 62, 65, 68), _
Array(1, 1, 1, 1, 1, 1, 2, 4, 4, 4, 5, 6, 8, 8, 11, 11, 16, 16, 18, 16, 19, 21, 25, 25, 25, 34, 30, 32, 35, 37, 40, 42, 45, 48, 51, 54, 57, 60, 63, 66, 70, 74, 77, 81))
version = IIf(version < mode – 3, mode – 3, version) – 1
Do ‚ compute QR size
version = version + 1
If version + 3 > UBound(ecb(0)) Then Err.Raise 515, „QRCode“, „Message too long“
s = version * IIf(version < 1, 2, 4) + 17 ‚ symbol size
j = ecb(lev)(version + 3) * ecw(lev)(version + 3) ‚ error correction
a = IIf(version < 2, 0, version \ 7 + 2) ‚ # of align pattern
el = (s – 1) * (s – 1) – (5 * a – 1) * (5 * a – 1) ‚ total bits – align – timing
el = el – IIf(version < 1, 59, IIf(version < 2, 191, IIf(version < 7, 136, 172))) ‚ finder, version, format
k = IIf(version < 1, version + (19 – 2 * mode) \ 3, p((version + 7) \ 17)) ‚ count indcator bits
i = IIf(version < 1, version + (version And 1) * 4 + 3, 4) ‚ mode indicator bits, M1+M3: +4 bits
Loop While (el And -8) – 8 * j < w + i + k
For lev = lev To 2 ‚ increase security level if data still fits
j = ecb(lev + 1)(version + 3) * ecw(lev + 1)(version + 3)
If (el And -8) – 8 * j < w + i + k Then Exit For
Next lev
blk = ecb(lev)(version + 3) ‚ # of error correction blocks
ec = ecw(lev)(version + 3) ‚ # of error correction bytes
el = el \ 8 – ec * blk ‚ data capacity
w = el \ blk ‚ # of words in group 1
b = blk + w * blk – el ‚ # of blocks in group 1

ReDim enc(el + ec * blk) As Byte, mat(s – 1, s – 1) As Byte
c = 0 ‚ encode head indicator bits
If version > 0 Then v = 2 ^ mode: eb = 4 Else v = mode: eb = version + 3 ‚ mode indicator
eb = eb + k: v = v * 2 ^ k + l ‚ character count indicator
For i = 1 To l ‚ encode data
Select Case mode
Case 0: ‚ numeric
v = v * IIf(i + 1 < l, 1024, IIf(i < l, 128, 16)) + val(Mid(txt, i, 3))
eb = eb + IIf(i + 1 < l, 10, 4 + 3 * (l – i)): i = i + 2
Case 1: ‚ alphanumeric
j = InStr(alpha, Mid(txt, i, 1)) – 1
If i < l Then j = 45 * j + InStr(alpha, Mid(txt, i + 1, 1)) – 1
v = v * IIf(i < l, 2048, 64) + j
eb = eb + IIf(i < l, 11, 6): i = i + 1
Case 2: ‚ binary
v = v * 256 + Asc(Mid(txt, i, 1))
eb = eb + 8
Case 3: ‚ Kanji
j = InStr(Len(k1) / 2 + 1, k1, Mid(txt, i, 1)) – Len(k1) / 2
j = (AscW(Mid(k1, j, 1)) And &H3FFF) – 320 ‚ unicode to shift JIS X 2008
v = v * 8192 + (j \ 256) * 192 + (j And 255) ‚ to 13 bit kanji
eb = eb + 13
End Select
For eb = eb To 8 Step -8 ‚ add data to bit stream
j = 2 ^ (eb – 8): enc(c) = v \ j
v = v – enc(c) * j: c = c + 1
Next eb
Next i
If el > c Then i = IIf(version > 0, 4, version + 6): v = v * 2 ^ i: eb = eb + i ‚ terminator
enc(c) = (v * 256) \ 2 ^ eb: c = c + 1: enc(c) = ((v * 65536) \ 2 ^ eb) And 255
If eb > 8 And el >= c Then c = c + 1 ‚ bit padding
If (version And -3) = -3 And el = c Then enc(c) = enc(c) \ 16 ‚ M1,M3: shift high bits to low nibble
i = 236
For c = c To el – 1 ‚ byte padding
enc(c) = IIf((version And -3) = -3 And c = el – 1, 0, i)
i = i Xor 236 Xor 17
Next c

ReDim rs(ec + 1) As Integer ‚ compute Reed Solomon error detection and correction
Dim lg(256) As Integer, ex(255) As Integer ‚ log/exp table
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 285 ‚ GF polynomial a^8+a^4+a^3+a^2+1 = 100011101b = 285
Next i
rs(0) = 1 ‚ compute RS generator polynomial
For i = 0 To ec – 1
rs(i + 1) = 0
For j = i + 1 To 1 Step -1
rs(j) = rs(j) Xor ex((lg(rs(j – 1)) + i) Mod 255)
Next j
Next i
eb = el: k = 0
For c = 1 To blk ‚ compute RS correction data for each block
For i = IIf(c <= b, 1, 0) To w
x = enc(eb) Xor enc(k)
For j = 1 To ec
enc(eb + j – 1) = enc(eb + j) Xor IIf(x, ex((lg(rs(j)) + lg(x)) Mod 255), 0)
Next j
k = k + 1
Next i
eb = eb + ec
Next c

‚ fill QR matrix
For i = 8 To s – 1 ‚ timing pattern
mat(i, IIf(version < 1, 0, 6)) = i And 1 Xor 3
mat(IIf(version < 1, 0, 6), i) = i And 1 Xor 3
Next i
If version > 6 Then ‚ reserve version area
For i = 0 To 17
mat(i \ 3, s – 11 + i Mod 3) = 2
mat(s – 11 + i Mod 3, i \ 3) = 2
Next i
End If
If a < 2 Then a = IIf(version < 1, 1, 2)
For x = 1 To a ‚ layout finder/align pattern
For y = 1 To a
If x = 1 And y = 1 Then ‚ finder upper left
i = 0: j = 0
p = Array(383, 321, 349, 349, 349, 321, 383, 256, 511)
ElseIf x = 1 And y = a Then ‚ finder lower left
i = 0: j = s – 8
p = Array(256, 383, 321, 349, 349, 349, 321, 383)
ElseIf x = a And y = 1 Then ‚ finder upper right
i = s – 8: j = 0
p = Array(254, 130, 186, 186, 186, 130, 254, 0, 255)
Else ‚ alignment grid
c = 2 * Int(2 * (version + 1) / (1 – a)) ‚ pattern spacing
i = IIf(x = 1, 4, s – 9 + c * (a – x))
j = IIf(y = 1, 4, s – 9 + c * (a – y))
p = Array(31, 17, 21, 17, 31) ‚ alignment pattern
End If
If version <> 1 Or x + y < 4 Then ‚ no align pattern for version 1
For c = 0 To UBound(p) ‚ set fixed pattern, reserve space
m = p(c): k = 0
Do
mat(i + k, j + c) = (m And 1) Or 2
m = m \ 2: k = k + 1
Loop While 2 ^ k <= p(0)
Next c
End If
Next y
Next x
x = s: y = s – 1 ‚ layout codewords
For i = 0 To eb – 1
c = 0: k = 0: j = w + 1 ‚ interleave data
If i >= el Then
c = el: k = el: j = ec ‚ interleave checkwords
ElseIf i + blk – b >= el Then
c = -b: k = c ‚ interleave group 2 last bytes
ElseIf (i Mod blk) >= b Then
c = -b ‚ interleave group 2
Else
j = j – 1 ‚ interleave group 1
End If
c = enc(c + ((i – k) Mod blk) * j + (i – k) \ blk) ‚ interleave data
For j = IIf((-3 And version) = -3 And i = el – 1, 3, 7) To 0 Step -1 ‚ M1,M3: 4 bit
k = IIf(version > 0 And x < 6, 1, 0) ‚ skip vertical timing pattern
Do ‚ advance x,y
x = x – 1
If 1 And (x + 1) Xor k Then
If s – x – k And 2 Then
If y > 0 Then y = y – 1: x = x + 2 ‚ up, top turn
Else
If y < s – 1 Then y = y + 1: x = x + 2 ‚ down, bottom turn
End If
End If
Loop While mat(x, y) And 2 ‚ skip reserved area
If c And 2 ^ j Then mat(x, y) = 1
Next j
Next i

m = 0: p = 1000000 ‚ data masking
For k = 0 To IIf(version < 1, 3, 7)
If version < 1 Then ‚ penalty micro QR
x = 1: y = 1
For i = 1 To s – 1
x = x – getPattern(i, s – 1, k, version)
y = y – getPattern(s – 1, i, k, version)
Next i
j = IIf(x > y, 16 * x + y, x + 16 * y)
Else ‚ penalty QR
l = 0: k2 = „“: j = 0
For y = 0 To s – 1 ‚ horizontal
c = 0: i = 0: k1 = „0000“
For x = 0 To s – 1
w = getPattern(x, y, k, version)
l = l + w: k1 = k1 & w ‚ rule 4: count darks
If c = w Then ‚ same as prev
i = i + 1
If x And Mid(k2, x + 4, 2) = c & c Then j = j + 3 ‚ rule 2: block 2×2
Else
If i > 5 Then j = j + i – 2 ‚ rule 1: >5 adjacent
c = 1 – c: i = 1
End If
Next x
If i > 5 Then j = j + i – 2 ‚ rule 1: >5 adjacent
i = 0
Do ‚ rule 3: like finder pattern
i = InStr(i + 4, k1, „1011101“)
If i < 1 Then Exit Do
If Mid(k1, i – 4, 4) = „0000“ Or Mid(k1 & „0000“, i + 7, 4) = „0000“ Then j = j + 40
Loop
k2 = k1 ‚ rule 2: remember last line
Next y
For x = 0 To s – 1 ‚ vertical
c = 0: i = 0: k1 = „0000“
For y = 0 To s – 1
w = getPattern(x, y, k, version)
k1 = k1 & w ‚ vertical to string
If c = w Then ‚ same as prev
i = i + 1
Else
If i > 5 Then j = j + i – 2 ‚ rule 1: >5 adjacent
c = 1 – c: i = 1
End If
Next y
If i > 5 Then j = j + i – 2 ‚ rule 1: >5 adjacent
i = 0
Do ‚ rule 3: like finder pattern
i = InStr(i + 4, k1, „1011101“)
If i < 1 Then Exit Do
If Mid(k1, i – 4, 4) = „0000“ Or Mid(k1 & „0000“, i + 7, 4) = „0000“ Then j = j + 40
Loop
Next x
j = j + Int(Abs(10 – 20 * l / (s * s))) * 10 ‚ rule 4: darks
End If
If j < p Then p = j: m = k ‚ take mask of lower penalty
Next k
‚ add format information, code level and mask
j = IIf(version = -3, m, IIf(version < 1, (2 * version + lev + 5) * 4 + m, ((5 – lev) And 3) * 8 + m))
j = j * 1024: k = j
For i = 4 To 0 Step -1 ‚ BCH error correction: 5 data, 10 error bits
If j >= 1024 * 2 ^ i Then j = j Xor 1335 * 2 ^ i
Next i ‚ generator polynom: x^10+x^8+x^5+x^4+x^2+x+1 = 10100110111b = 1335
k = k Xor j Xor IIf(version < 1, 17477, 21522) ‚ XOR masking
For j = 0 To 14 ‚ layout format information
If version < 1 Then
mat(IIf(j < 8, 8, 15 – j), IIf(j < 8, j + 1, 8)) = k And 1 Xor 2 ‚ micro QR
Else
mat(IIf(j < 8, s – j – 1, IIf(j = 8, 7, 14 – j)), 8) = k And 1 Xor 2 ‚ QR horizontal
mat(8, IIf(j < 6, j, IIf(j < 8, j + 1, s + j – 15))) = k And 1 Xor 2 ‚ vertical
End If
k = k \ 2
Next j
If version > 6 Then ‚ add version information
k = version * 4096&
For i = 5 To 0 Step -1 ‚ BCH error correction: 6 data, 12 error bits
If k >= 4096 * 2 ^ i Then k = k Xor 7973 * 2 ^ i
Next i ‚ generator polynom: x^12+x^11+x^10+x^9+x^8+x^5+x^2+1 = 1111100100101b = 7973
k = k Xor (version * 4096&)
For j = 0 To 17 ‚ layout version information
mat(j \ 3, s + j Mod 3 – 11) = k And 1 Xor 2
mat(s + j Mod 3 – 11, j \ 3) = k And 1 Xor 2
k = k \ 2
Next j
End If
With Application.Caller.Parent.Shapes
k = .Count + 1 ‚ layout QR code
For y = 0 To s – 1
For x = 0 To s – 1
If getPattern(x, y, m, version) Then ‚ apply mask
.AddShape(msoShapeRectangle, x, y, 1, 1).Name = Application.Caller.Address
End If
Next x
Next y
k = .Count – k
ReDim shps(k) As Integer ‚ group all shapes
For i = .Count To 1 Step -1
If .Range(i).Name = Application.Caller.Address Then
shps(k) = i: k = k – 1
If k < 0 Then Exit For
End If
Next i

With .Range(shps).Group
.Fill.ForeColor.RGB = fColor ‚ format barcode shape
.line.ForeColor.RGB = bColor
.line.Weight = line
x = Application.Caller.MergeArea.Width
y = Application.Caller.MergeArea.Height
If x > y Then x = y
.Width = x * s / (s + 2) ‚ fit symbol in excel cell
.Height = .Width
.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 = „QuickResponse barcode, level “ & Mid(„LMQH“, lev + 1, 1) & „, version “ & IIf(version < 1, „M“ & (version + 4), version) & „, mode “ & Array(„digit“, „alpha“, „binary“, „kanji“)(mode) & „, “ & s & „x“ & s & “ cells“
.LockAspectRatio = True
.Placement = xlMove
End With
End With
failed:
If Err.Number Then QRCode = „ERROR QRCode: “ & Err.Description
End Function

‚ get QR pattern mask
Private Function getPattern(ByVal x As Long, ByVal y As Long, ByVal m As Integer, ByVal version As Integer) As Integer
Dim i As Integer, j As Long
If version < 1 Then m = Array(1, 4, 6, 7)(m) ‚ mask pattern of micro QR
i = mat(x, y)
If i < 2 Then
Select Case m
Case 0: j = (x + y) And 1
Case 1: j = y And 1
Case 2: j = x Mod 3
Case 3: j = (x + y) Mod 3
Case 4: j = (x \ 3 + y \ 2) And 1
Case 5: j = ((x * y) And 1) + (x * y) Mod 3
Case 6: j = (x * y + (x * y) Mod 3) And 1
Case 7: j = (x + y + (x * y) Mod 3) And 1
End Select
If j = 0 Then i = i Xor 1 ‚ invert only data according mask
End If
getPattern = i And 1
End Function