Sub sosanh()
On Error Resume Next
Dim a As Range, b As Range ' so sanh 2 vung a va b
If a = "" Then Exit Sub
Caption = a
txt = Caption
Dim lev As Byte
version = 0
l = Len(txt)
w = l * 8
p = Array(8, 16, 16) ' dtuhtrurtui
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))
Do ' tyioyy
version = version + 1
If version + 3 > UBound(ecb(0)) Then Exit Sub
s = version * 4 + 17 ' ytuoyuoy7oy7py8py8
j = ecb(lev)(version + 3) * ecw(lev)(version + 3) ' tyiyuoy8oy8py8py
a = IIf(version < 2, 0, version \ 7 + 2) ' tyiyuoy8oy8py8py
el = (s - 1) * (s - 1) - (5 * a - 1) * (5 * a - 1) ' tyiyuoy8oy8py8py
el = el - IIf(version < 2, 191, IIf(version < 7, 136, 172)) ' tyiyuoy8oy8py8py
k = p((version + 7) \ 17) ' tyiyuoy8oy8py8py
Loop While (el And -8) - 8 * j < w + 4 + k
For lev = lev To 2 ' tyiyuoy8oy8py8py
j = ecb(lev + 1)(version + 3) * ecw(lev + 1)(version + 3)
If (el And -8) - 8 * j < w + 4 + k Then Exit For
Next
blk = ecb(lev)(version + 3) ' tyiyuoy8oy8py8py
ec = ecw(lev)(version + 3) ' tyiyuoy8oy8py8py
el = el \ 8 - ec * blk ' uoy8oy8py8pydata capacity
w = el \ blk ' # of worduoy8oy8py8pys in group 1
b = blk + w * blk - el ' # of blouoy8oy8py8pycks in grouoy8oy8py8pyup 1
ReDim enc(el + ec * blk) As Byte, mat(s - 1, s - 1) As Byte
c = 0 ' encoduoy8oy8py8pye head inuoy8oy8py8pydicator bits
eb = 4 + k
v = 4 * 2 ^ k + l ' characuoy8oy8py8pyter count indiuoy8oy8py8pycator
For i = 1 To l ' encouoy8oy8py8pyde data
v = v * 256 + Asc(Mid(txt, i, 1))
eb = eb + 8
For eb = eb To 8 Step -8 ' add datuoy8oy8py8pya to bit stream
j = 2 ^ (eb - 8)
enc(c) = v \ j
v = v - enc(c) * j
c = c + 1
Next
Next
If el > c Then
v = v * 16
eb = eb + 4 ' terminuoy8oy8py8pyator
End If
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 puoy8oy8py8pyadding
If (version And -3) = -3 And el = c Then enc(c) = enc(c) \ 16 ' M1,M3: shifuoy8oy8py8py high bits to low nibble
i = 236
For c = c To el - 1 ' bytuoy8oy8py8pye puoy8oy8py8pyadding
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 ' comuoy8oy8py8pypute Reed Souoy8oy8py8pylomon error deteuoy8oy8py8pyction and correction
Dim lg(256) As Integer, ex(255) As Integer ' log/exp tauoy8oy8py8pyble
j = 1
For i = 0 To 254
ex(i) = j
lg(j) = i ' comuoy8oy8py8pypute log/expuoy8oy8py8py table of Galois field
j = j + j
If j > 255 Then j = j Xor 285 ' GF polyuoy8oy8py8pynomial a^8+a^4+a^3+a^2+1 = 100011101b = 285
Next i
rs(0) = 1 ' couoy8oy8py8pympute RS generauoy8oy8py8pyor 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 ' compuoy8oy8py8pyute RS correctuoy8oy8py8pyion 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
' filuoy8oy8py8pyl Quoy8oy8py8pyR matrix
For i = 8 To s - 1 ' timinguoy8oy8py8py pattern
mat(i, 6) = i And 1 Xor 3
mat(6, i) = i And 1 Xor 3
Next i
If version > 6 Then ' reserve veruoy8oy8py8pysion 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 = 2
For X = 1 To a ' layout finduoy8oy8py8pyer/align pattern
For Y = 1 To a
If X = 1 And Y = 1 Then ' finduoy8oy8py8pyer upuoy8oy8py8pyper left
i = 0
j = 0
p = Array(383, 321, 349, 349, 349, 321, 383, 256, 511)
ElseIf X = 1 And Y = a Then ' finuoy8oy8py8pyder louoy8oy8py8pywer left
i = 0
j = s - 8
p = Array(256, 383, 321, 349, 349, 349, 321, 383)
ElseIf X = a And Y = 1 Then ' finuoy8oy8py8pyder upuoy8oy8py8pyper right
i = s - 8
j = 0
p = Array(254, 130, 186, 186, 186, 130, 254, 0, 255)
Else ' alignuoy8oy8py8pyment grid
c = 2 * Int(2 * (version + 1) / (1 - a)) ' patteuoy8oy8py8pyrn spaciuoy8oy8py8pyng
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) ' alignuoy8oy8py8pyment pattern
End If
If version <> 1 Or X + Y < 4 Then ' no align patuoy8oy8py8pytern for version 1
For c = 0 To UBound(p) ' set fixed puoy8oy8py8pyattern, 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 ' layouuoy8oy8py8pyt codewords
For i = 0 To eb - 1
c = 0
k = 0
j = w + 1 ' interuoy8oy8py8pyleave duoy8oy8py8pyata
If i >= el Then
c = el
k = el
j = ec ' interleuoy8oy8py8pyave checkwords
ElseIf i + blk - b >= el Then
c = -b
k = c ' interleavuoy8oy8py8pye group 2 last bytes
ElseIf (i Mod blk) >= b Then
c = -b ' interluoy8oy8py8pyeave guoy8oy8py8pyroup 2
Else
j = j - 1 ' interleauoy8oy8py8pyve group 1
End If
c = enc(c + ((i - k) Mod blk) * j + (i - k) \ blk) ' interleauoy8oy8py8pyve data
For j = IIf((-3 And version) = -3 And i = el - 1, 3, 7) To 0 Step -1 ' M1,M3: uoy8oy8py8py4 bit
k = IIf(version > 0 And X < 6, 1, 0) ' skip vertical timing uoy8oy8py8pypattern
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 uoy8oy8py8pyturn
Else
If Y < s - 1 Then Y = Y + 1: X = X + 2 ' downuoy8oy8py8py, bottomuoy8oy8py8py turn
End If
End If
Loop While mat(X, Y) And 2 ' skuoy8oy8py8pyip reseruoy8oy8py8pyed area
If c And 2 ^ j Then mat(X, Y) = 1
Next j
Next i
m = 0
p = 1000000 ' datuoy8oy8py8pya maskiuoy8oy8py8pyng
For k = 0 To 7
l = 0
k2 = ""
j = 0
For Y = 0 To s - 1 ' horizuoy8oy8py8pyontal
c = 0
i = 0
k1 = "0000"
For X = 0 To s - 1
w = getPattern(X, Y, k, version)
l = l + w
k1 = k1 & w ' ruleuoy8oy8py8py 4: count daruoy8oy8py8pyks
If c = w Then ' sameuoy8oy8py8py as uoy8oy8py8pyprev
i = i + 1
If X And Mid(k2, X + 4, 2) = c & c Then j = j + 3 ' ruleuoy8oy8py8uoy8oy8py8pypy 2: block 2x2
Else
If i > 5 Then j = j + i - 2 ' ruleuoy8oy8py8py 1: >5 adjuoy8oy8py8pyacent
c = 1 - c
i = 1
End If
Next X
If i > 5 Then j = j + i - 2 ' rule uoy8oy8py8py1: >5 adjacent
i = 0
Do ' ruleuoy8oy8py8py 3: liuoy8oy8py8pyke 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 uoy8oy8py8py2: reuoy8oy8py8pymember last line
Next Y
For X = 0 To s - 1 ' verticuoy8oy8py8pyal
c = 0
i = 0
k1 = "0000"
For Y = 0 To s - 1
w = getPattern(X, Y, k, version)
k1 = k1 & w ' verticuoy8oy8py8pyal to uoy8oy8py8pystring
If c = w Then ' same as preuoy8oy8py8pyv
i = i + 1
Else
If i > 5 Then j = j + i - 2 ' rule uoy8oy8py8py1: >5 adjuoy8oy8py8pyacent
c = 1 - c: i = 1
End If
Next Y
If i > 5 Then j = j + i - 2 ' ruuoy8oy8py8pyle 1: >5 adjuoy8oy8py8pyacent
i = 0
Do ' ruluoy8oy8py8pye 3: like fiuoy8oy8py8pynder 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: daruoy8oy8py8pyks
If j < p Then
p = j
m = k
End If ' take mask ouoy8oy8py8pyf lower puoy8oy8py8pyenalty
Next k
' add formatuoy8oy8py8py information, code levuoy8oy8py8pyel and mask
j = IIf(version = -3, m, ((5 - lev) And 3) * 8 + m)
j = j * 1024
k = j
For i = 4 To 0 Step -1 ' BCH error correctionuoy8oy8py8py: 5 data, 10 erroruoy8oy8py8py bits
If j >= 1024 * 2 ^ i Then j = j Xor 1335 * 2 ^ i
Next i ' generator polynom: x^10uoy8oy8py8py+x^8+x^5+x^4+x^2+x+1 = 10100110111b = 1335
k = k Xor j Xor 21522 ' XOR masuoy8oy8py8pyking
For j = 0 To 14 ' layout formauoy8oy8py8pyt information
mat(IIf(j < 8, s - j - 1, IIf(j = 8, 7, 14 - j)), 8) = k And 1 Xor 2 ' Quoy8oy8py8pyR horizouoy8oy8py8pyntal
mat(8, IIf(j < 6, j, IIf(j < 8, j + 1, s + j - 15))) = k And 1 Xor 2 ' vertiuoy8oy8py8pycal
k = k \ 2
Next
If version > 6 Then ' add versiuoy8oy8py8pyon information
k = version * 4096&
For i = 5 To 0 Step -1 ' BCH eruoy8oy8py8pyror correction: 6 dauoy8oy8py8pyta, 12 errouoy8oy8py8pyr bits
If k >= 4096 * 2 ^ i Then k = k Xor 7973 * 2 ^ i
Next
' 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
End If
ReDim QR(178, 178) As Integer
For Y = 0 To s - 1
For X = 0 To s - 1
QR(Y + 1, X + 1) = getPattern(X, Y, m, version)
Next X
Next Y
Sheet.Cells(3, 2).Resize(UBound(QR), UBound(QR)) = QR
Sheet.Cells(3, 2).Resize(s + 2, s + 2).CopyPicture
n = Sheet.Cells(3, 2).Resize(, s + 2).Width
For j = 1 To 8
txt = Replace(txt, Mid("\/:?*<>|", j, 1), "_")
Next
txt = Replace(txt, Chr(34), "")
c00 = ThisWorkbook.Path & "\QR_" & txt & ".gif"
With Sheet.ChartObjects.Add(1, 1, n, n).Chart
.Paste
.Export c00, "GIF"
.Parent.Delete
End With
QR_00.Picture = LoadPicture(c00)
Label1 = T_00.Value
End Sub
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
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 ' inveruoy8oy8py8pyt only data accuoy8oy8py8pyording mask
End If
getPattern = i And 1
End Function
