Hallo
ich hab das hier mal irgendwo aufgeschnappt, aber nicht wirklich benutzt. Deshalb ohne Gewähr
Kopiere es in ein Modul in deine Mappe
Aufrufen dann im Tabellenblatt =QRCode(A1)
In der Zelle wird eine Grafik erzeugt, die du größer ziehen kannst.
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
Function QRCode(text As String, Optional level As String, Optional version As Integer = 1) As String
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 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 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 = text
'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 UBound(ecb(0)) Then Err.Raise 515, "QRCode", "Message too long"
s = version * IIf(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 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 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 1 Or x + y = 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 0 Then y = y - 1: x = x + 2 ' up, top turn
Else
If y 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 2x2
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 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 = 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 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 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