Context
I use barcode-vba-macro-only (mentioned in this SO post ) in MS Excel 2010 to generate a QR code.
(The barcode will be used to facilitate bill payment using Girocode , but it doesn’t matter here, except to say I need to structure the input as shown below.)
Problem
The VBA macro creates large QR codes, but somehow, when it is given a specific input, the output (encoded in the QR code) “stutters”, i.e. repeats part of the text.
For example, when specifying this input:
BCD 001 1 SCT SOLADES1HDB Recipient First and Last Name DE86672500200000123456 EUR123.45
he produces this conclusion:
which weirdly repeats part of the content:
BCD 001 1 SCT SOLADES1HDB Recipient First and Last Name DE Recipient First and Last Name DE86672500200000123456 EUR123.45
(Note the DE and the recipient's first name and last name line that appear twice.)
What I want
A working, free / GPL solution in Excel for generating such codes ;-) ... for example, understanding why this is happening, and fixing the VBA code.
What I tried (Update 1)
I played with different inputs and found that just adding an extra “AAA” to the end of the long number decides to stutter ... so I'm intrigued about what causes this.
I searched the code on GitHub, added some comments to the code and translated some of the existing (Czech) comments
After some debugging, I found that the implementation is confused with the original position of the different encodings (which it stores in the eb array): after encoding the "Recipient name of the first and last name" "including newline and" DE "as" Byte ", probably he tries to switch to the Decimal or Alphanum encoding (only 3.33 or 5.5 bits per character instead of 8) ... but then he returns to the encoding in Byte and thereby assigns the original position incorrectly.
Code
You can download my test XLSM file here and access the improved code file on GitHub .
I think the problem is probably related to the main function shown below in the section where the eb() array is populated.
Function qr_gen(ptext As String, poptions As String) As String Dim encoded1() As Byte ' byte mode (ASCII) all max 3200 bytes Dim encix1% Dim ecx_cnt(3) As Integer Dim ecx_pos(3) As Integer Dim ecx_poc(3) As Integer Dim eb(1 To 20, 1 To 4) As Integer 'store how many characters should be in which ECI mode. This is a list of rows, each row corresponding a the next batch of characters with a different ECI mode. ' eb(i, 1) - ECI mode (1 = numeric, 2 = alphanumeric, 3 = byte) ' eb(i, 2) - last character in previous row ' eb(i, 3) - number of characters in THIS row ' eb(i, 4) - number of bits for THIS row Dim ascimatrix$, mode$, err$ Dim ecl%, r%, c%, mask%, utf8%, ebcnt% Dim i&, j&, k&, m& Dim ch%, s%, siz% Dim x As Boolean Dim qrarr() As Byte ' final matrix Dim qrpos As Integer Dim qrp(15) As Integer ' 1:version,2:size,3:ccs,4:ccb,5:totby,6-12:syncs(7),13-15:versinfo(3) Dim qrsync1(1 To 8) As Byte Dim qrsync2(1 To 5) As Byte ascimatrix = "" err = "" mode = "M" i = InStr(poptions, "mode=") If i > 0 Then mode = Mid(poptions, i + 5, 1) ' M=0,L=1,H=2,Q=3 ecl = InStr("MLHQ", mode) - 1 If ecl < 0 Then mode = "M": ecl = 0 If ptext = "" Then err = "Not data" Exit Function End If For i = 1 To 3 ecx_pos(i) = 0 ecx_cnt(i) = 0 ecx_poc(i) = 0 Next i ebcnt = 1 utf8 = 0 For i = 1 To Len(ptext) + 1 ' Decide how many bytes this character has If i > Len(ptext) Then k = -5 ' End of text --> skip several code sections Else ' need to parse character i of ptext and decide how many bytes it has k = AscL(Mid(ptext, i, 1)) If k >= &H1FFFFF Then ' FFFF - 1FFFFFFF m = 4 k = -1 ElseIf k >= &H7FF Then ' 7FF-FFFF 3 bytes m = 3 k = -1 ElseIf k >= 128 Then m = 2 k = -1 Else ' normal 7bit ASCII character, so it is worth it to check if it belong to the Numeric or Alphanumeric subsets defined in ECI (array qralnum) m = 1 k = InStr(qralnum, Mid(ptext, i, 1)) - 1 End If End If ' Depending on k and a lot of other things, increase ebcnt If (k < 0) Then ' Treat mult-byte case or exit? (bude byte nebo konec) If ecx_cnt(1) >= 9 Or (k = -5 And ecx_cnt(1) = ecx_cnt(3)) Then ' Until now it was possible numeric??? (Az dosud bylo mozno pouzitelne numeric) If (ecx_cnt(2) - ecx_cnt(1)) >= 8 Or (ecx_cnt(3) = ecx_cnt(2)) Then ' pred num je i pouzitelny alnum If (ecx_cnt(3) > ecx_cnt(2)) Then ' Jeste pred alnum bylo byte eb(ebcnt, 1) = 3 ' Typ byte eb(ebcnt, 2) = ecx_pos(3) ' Position pozice eb(ebcnt, 3) = ecx_cnt(3) - ecx_cnt(2) ' delka ebcnt = ebcnt + 1 ecx_poc(3) = ecx_poc(3) + 1 End If eb(ebcnt, 1) = 2 ' Typ alnum eb(ebcnt, 2) = ecx_pos(2) eb(ebcnt, 3) = ecx_cnt(2) - ecx_cnt(1) ' delka ebcnt = ebcnt + 1 ecx_poc(2) = ecx_poc(2) + 1 ecx_cnt(2) = 0 ElseIf ecx_cnt(3) > ecx_cnt(1) Then ' byly bytes pred numeric eb(ebcnt, 1) = 3 ' Typ byte eb(ebcnt, 2) = ecx_pos(3) ' Position pozice eb(ebcnt, 3) = ecx_cnt(3) - ecx_cnt(1) ' delka ebcnt = ebcnt + 1 ecx_poc(3) = ecx_poc(3) + 1 End If ElseIf (ecx_cnt(2) >= 8) Or (k = -5 And ecx_cnt(2) = ecx_cnt(3)) Then ' Az dosud bylo mozno pouzitelne alnum If (ecx_cnt(3) > ecx_cnt(2)) Then ' Jeste pred alnum bylo byte eb(ebcnt, 1) = 3 ' Typ byte eb(ebcnt, 2) = ecx_pos(3) ' Position pozice eb(ebcnt, 3) = ecx_cnt(3) - ecx_cnt(2) ' delka ebcnt = ebcnt + 1 ecx_poc(3) = ecx_poc(3) + 1 End If eb(ebcnt, 1) = 2 ' Typ alnum eb(ebcnt, 2) = ecx_pos(2) eb(ebcnt, 3) = ecx_cnt(2) ' delka ebcnt = ebcnt + 1 ecx_poc(2) = ecx_poc(2) + 1 ecx_cnt(3) = 0 ecx_cnt(2) = 0 ' vse zpracovano ElseIf (k = -5 And ecx_cnt(3) > 0) Then ' konec ale mam co ulozit eb(ebcnt, 1) = 3 ' Typ byte eb(ebcnt, 2) = ecx_pos(3) ' Position pozice eb(ebcnt, 3) = ecx_cnt(3) ' delka ebcnt = ebcnt + 1 ecx_poc(3) = ecx_poc(3) + 1 End If End If If k = -5 Then Exit For If (k >= 0) Then ' We can alphanumeric? (Muzeme alnum) If (k >= 10 And ecx_cnt(1) >= 12) Then ' Until now it was perhaps numeric (Az dosud bylo mozno num) If (ecx_cnt(2) - ecx_cnt(1)) >= 8 Or (ecx_cnt(3) = ecx_cnt(2)) Then ' There is also an alphanumeric which is worth it(Je tam i alnum ktery stoji za to) If (ecx_cnt(3) > ecx_cnt(2)) Then ' Even before it was alnum byte (Jeste pred alnum bylo byte) eb(ebcnt, 1) = 3 ' Typ byte eb(ebcnt, 2) = ecx_pos(3) ' Position (pozice) eb(ebcnt, 3) = ecx_cnt(3) - ecx_cnt(2) ' length (delka) ebcnt = ebcnt + 1 ecx_poc(3) = ecx_poc(3) + 1 End If eb(ebcnt, 1) = 2 ' Typ alnum eb(ebcnt, 2) = ecx_pos(2) eb(ebcnt, 3) = ecx_cnt(2) - ecx_cnt(1) ' length (delka) ebcnt = ebcnt + 1 ecx_poc(2) = ecx_poc(2) + 1 ecx_cnt(2) = 0 ' processed everything (vse zpracovano) ElseIf (ecx_cnt(3) > ecx_cnt(1)) Then ' Previous Num is byte (Pred Num je byte) eb(ebcnt, 1) = 3 ' Typ byte eb(ebcnt, 2) = ecx_pos(3) ' Position (pozice) eb(ebcnt, 3) = ecx_cnt(3) - ecx_cnt(1) ' length (delka) ebcnt = ebcnt + 1 ecx_poc(3) = ecx_poc(3) + 1 End If eb(ebcnt, 1) = 1 ' Typ numerix eb(ebcnt, 2) = ecx_pos(1) eb(ebcnt, 3) = ecx_cnt(1) ' length (delka) ebcnt = ebcnt + 1 ecx_poc(1) = ecx_poc(1) + 1 ecx_cnt(1) = 0 ecx_cnt(2) = 0 ecx_cnt(3) = 0 ' processed everything (vse zpracovano) End If If ecx_cnt(2) = 0 Then ecx_pos(2) = i ecx_cnt(2) = ecx_cnt(2) + 1 Else ' possible alnum (mozno alnum) ecx_cnt(2) = 0 End If If k >= 0 And k < 10 Then ' Can be numeric (muze byt numeric) If ecx_cnt(1) = 0 Then ecx_pos(1) = i ecx_cnt(1) = ecx_cnt(1) + 1 Else ecx_cnt(1) = 0 End If If ecx_cnt(3) = 0 Then ecx_pos(3) = i ecx_cnt(3) = ecx_cnt(3) + m utf8 = utf8 + m If ebcnt >= 16 Then ' We have already taken 3 other blocks of bits (Uz by se mi tri dalsi bloky stejne nevesli) ecx_cnt(1) = 0 ecx_cnt(2) = 0 End If Debug.Print "Character:'" & Mid(ptext, i, 1) & "'(" & k & _ ") ebn=" & ecx_pos(1) & "." & ecx_cnt(1) & _ " eba=" & ecx_pos(2) & "." & ecx_cnt(2) & _ " ebb=" & ecx_pos(3) & "." & ecx_cnt(3) Next ebcnt = ebcnt - 1 ' ebcnt now has its final value Debug.Print ("ebcnt=" & ebcnt) c = 0 For i = 1 To ebcnt Select Case eb(i, 1) Case 1: eb(i, 4) = Int(eb(i, 3) / 3) * 10 + (eb(i, 3) Mod 3) * 3 + IIf((eb(i, 3) Mod 3) > 0, 1, 0) Case 2: eb(i, 4) = Int(eb(i, 3) / 2) * 11 + (eb(i, 3) Mod 2) * 6 Case 3: eb(i, 4) = eb(i, 3) * 8 End Select c = c + eb(i, 4) Next i Debug.Print ("c=" & c) ' UTF-8 is default not need ECI value - zxing cannot recognize ' Call qr_params(i * 8 + utf8,mode,qrp) Call qr_params(c, ecl, qrp, ecx_poc) If qrp(1) <= 0 Then err = "Too long" Exit Function End If siz = qrp(2) Debug.Print "ver:" & qrp(1) & mode & " size " & siz & " ecc:" & qrp(3) & "x" & qrp(4) & " d:" & (qrp(5) - qrp(3) * qrp(4)) 'MsgBox "ver:" & qrp(1) & mode & " size " & siz & " ecc:" & qrp(3) & "x" & qrp(4) & " d:" & (qrp(5) - qrp(3) * qrp(4)) ReDim encoded1(qrp(5) + 2) ' Table 3 — Number of bits in character count indicator for QR Code 2005: ' mode indicator (1=num,2=AlNum,4=Byte,8=kanji,ECI=7) ' mode: Byte Alphanum Numeric Kanji ' ver 1..9 : 8 9 10 8 ' 10..26 : 16 11 12 10 ' 27..40 : 16 13 14 12 ' UTF-8 is default not need ECI value - zxing cannot recognize ' if utf8 > 0 Then ' k = &H700 + 26 ' UTF-8=26 ; Win1250 = 21; 8859-2 = 4 viz http://strokescribe.com/en/ECI.html ' bb_putbits(encoded1,encix1,k,12) ' End If encix1 = 0 For i = 1 To ebcnt Select Case eb(i, 1) Case 1: c = IIf(qrp(1) < 10, 10, IIf(qrp(1) < 27, 12, 14)): k = 2 ^ c + eb(i, 3) ' encoding mode "Numeric" Case 2: c = IIf(qrp(1) < 10, 9, IIf(qrp(1) < 27, 11, 13)): k = 2 * (2 ^ c) + eb(i, 3) ' encoding mode "alphanum Case 3: c = IIf(qrp(1) < 10, 8, 16): k = 4 * (2 ^ c) + eb(i, 3) ' encoding mode "Byte" End Select Call bb_putbits(encoded1, encix1, k, c + 4) Debug.Print "ver:" & qrp(1) & mode & " size " & siz & " ecc:" & qrp(3) & "x" & qrp(4) & " d:" & (qrp(5) - qrp(3) * qrp(4)) j = 0 ' count characters that have been output in THIS row eb(i,...) m = eb(i, 2) 'Start (after) last character of input from previous row r = 0 While j < eb(i, 3) k = AscL(Mid(ptext, m, 1)) m = m + 1 If eb(i, 1) = 1 Then ' parse numeric input - output 3 decimal digits into 10 bit r = (r * 10) + ((k - &H30) Mod 10) If (j Mod 3) = 2 Then Call bb_putbits(encoded1, encix1, r, 10) r = 0 End If j = j + 1 ElseIf eb(i, 1) = 2 Then ' parse alphanumeric input - output 2 alphanumeric characters into 11 bit r = (r * 45) + ((InStr(qralnum, Chr(k)) - 1) Mod 45) If (j Mod 2) = 1 Then Call bb_putbits(encoded1, encix1, r, 11) r = 0 End If j = j + 1 Else ' Okay, byte mode: coding according to Chapter "6.4.2 Extended Channel Interpretation (ECI) mode" of ISOIEC 18004_2006Cor 1_2009.pdf If k > &H1FFFFF Then ' FFFF - 1FFFFFFF ch = &HF0 + Int(k / &H40000) Mod 8 Call bb_putbits(encoded1, encix1, ch, 8) ch = 128 + Int(k / &H1000) Mod 64 Call bb_putbits(encoded1, encix1, ch, 8) ch = 128 + Int(k / 64) Mod 64 Call bb_putbits(encoded1, encix1, ch, 8) ch = 128 + k Mod 64 Call bb_putbits(encoded1, encix1, ch, 8) j = j + 4 ElseIf k > &H7FF Then ' 7FF-FFFF 3 bytes ch = &HE0 + Int(k / &H1000) Mod 16 Call bb_putbits(encoded1, encix1, ch, 8) ch = 128 + Int(k / 64) Mod 64 Call bb_putbits(encoded1, encix1, ch, 8) ch = 128 + k Mod 64 Call bb_putbits(encoded1, encix1, ch, 8) j = j + 3 ElseIf k > &H7F Then ' 2 bytes ch = &HC0 + Int(k / 64) Mod 32 Call bb_putbits(encoded1, encix1, ch, 8) ch = 128 + k Mod 64 Call bb_putbits(encoded1, encix1, ch, 8) j = j + 2 Else ch = k Mod 256 Call bb_putbits(encoded1, encix1, ch, 8) j = j + 1 End If End If Wend Select Case eb(i, 1) Case 1: If (j Mod 3) = 1 Then Call bb_putbits(encoded1, encix1, r, 4) ElseIf (j Mod 3) = 2 Then Call bb_putbits(encoded1, encix1, r, 7) End If Case 2: If (j Mod 2) = 1 Then Call bb_putbits(encoded1, encix1, r, 6) End Select 'MsgBox "blk[" & i & "] t:" & eb(i,1) & "from " & eb(i,2) & " to " & eb(i,3) + eb(i,2) & " bits=" & encix1 Next i Call bb_putbits(encoded1, encix1, 0, 4) ' end of chain If (encix1 Mod 8) <> 0 Then ' round to byte Call bb_putbits(encoded1, encix1, 0, 8 - (encix1 Mod 8)) End If ' padding i = (qrp(5) - qrp(3) * qrp(4)) * 8 If encix1 > i Then err = "Encode length error" Exit Function End If ' padding 0xEC,0x11,0xEC,0x11... Do While encix1 < i Call bb_putbits(encoded1, encix1, &HEC11, 16) Loop ' doplnime ECC i = qrp(3) * qrp(4) 'ppoly, pmemptr , psize , plen , pblocks Call qr_rs(&H11D, encoded1, qrp(5) - i, i, qrp(4)) 'Call arr2hexstr(encoded1) encix1 = qrp(5) ' Pole pro vystup ReDim qrarr(0) ReDim qrarr(1, qrp(2) * 24& + 24&) ' 24 bytes per row qrarr(0, 0) = 0 ch = 0 Call bb_putbits(qrsync1, ch, Array(&HFE, &H82, &HBA, &HBA, &HBA, &H82, &HFE, 0), 64) Call qr_mask(qrarr, qrsync1, 8, 0, 0) ' sync UL Call qr_mask(qrarr, 0, 8, 8, 0) ' fmtinfo UL under - bity 14..9 SYNC 8 Call qr_mask(qrarr, qrsync1, 8, 0, siz - 7) ' sync UR ( o bit vlevo ) Call qr_mask(qrarr, 0, 8, 8, siz - 8) ' fmtinfo UR - bity 7..0 Call qr_mask(qrarr, qrsync1, 8, siz - 7, 0) ' sync DL (zasahuje i do quiet zony) Call qr_mask(qrarr, 0, 8, siz - 8, 0) ' blank nad DL For i = 0 To 6 x = qr_bit(qrarr, -1, i, 8, 0) ' svisle fmtinfo UL - bity 0..5 SYNC 6,7 x = qr_bit(qrarr, -1, i, siz - 8, 0) ' svisly blank pred UR x = qr_bit(qrarr, -1, siz - 1 - i, 8, 0) ' svisle fmtinfo DL - bity 14..8 Next x = qr_bit(qrarr, -1, 7, 8, 0) ' svisle fmtinfo UL - bity 0..5 SYNC 6,7 x = qr_bit(qrarr, -1, 7, siz - 8, 0) ' svisly blank pred UR x = qr_bit(qrarr, -1, 8, 8, 0) ' svisle fmtinfo UL - bity 0..5 SYNC 6,7 x = qr_bit(qrarr, -1, siz - 8, 8, 1) ' black dot DL If qrp(13) <> 0 Or qrp(14) <> 0 Then ' versioninfo ' UR ver 0 1 2;3 4 5;...;15 16 17 ' LL ver 0 3 6 9 12 15;1 4 7 10 13 16; 2 5 8 11 14 17 k = 65536 * qrp(13) + 256& * qrp(14) + 1& * qrp(15) c = 0: r = 0 For i = 0 To 17 ch = k Mod 2 x = qr_bit(qrarr, -1, r, siz - 11 + c, ch) ' UR ver x = qr_bit(qrarr, -1, siz - 11 + c, r, ch) ' DL ver c = c + 1 If c > 2 Then c = 0: r = r + 1 k = Int(k / 2&) Next End If c = 1 For i = 8 To siz - 9 ' sync lines x = qr_bit(qrarr, -1, i, 6, c) ' vertical on column 6 x = qr_bit(qrarr, -1, 6, i, c) ' horizontal on row 6 c = (c + 1) Mod 2 Next ' other syncs ch = 0 Call bb_putbits(qrsync2, ch, Array(&H1F, &H11, &H15, &H11, &H1F), 40) ch = 6 Do While ch > 0 And qrp(6 + ch) = 0 ch = ch - 1 Loop If ch > 0 Then For c = 0 To ch For r = 0 To ch ' corners If (c <> 0 Or r <> 0) And _ (c <> ch Or r <> 0) And _ (c <> 0 Or r <> ch) Then Call qr_mask(qrarr, qrsync2, 5, qrp(r + 6) - 2, qrp(c + 6) - 2) End If Next r Next c End If ' qr_fill(parr as Variant, psiz%, pb as Variant, pblocks%, pdlen%, ptlen%) ' vyplni pole parr (psiz x 24 bytes) z pole pb pdlen = pocet dbytes, pblocks = bloku, ptlen celkem Call qr_fill(qrarr, siz, encoded1, qrp(4), qrp(5) - qrp(3) * qrp(4), qrp(5)) mask = 8 ' auto i = InStr(poptions, "mask=") If i > 0 Then mask = val(Mid(poptions, i + 5, 1)) If mask < 0 Or mask > 7 Then j = -1 For mask = 0 To 7 GoSub addmm i = qr_xormask(qrarr, siz, mask, False) ' MsgBox "score mask " & mask & " is " & i If i < j Or j = -1 Then j = i: s = mask Next mask mask = s ' MsgBox "best is " & mask & " with score " & j End If GoSub addmm i = qr_xormask(qrarr, siz, mask, True) ascimatrix = "" For r = 0 To siz Step 2 s = 0 For c = 0 To siz Step 2 If (c Mod 8) = 0 Then ch = qrarr(1, s + 24 * r) If r < siz Then i = qrarr(1, s + 24 * (r + 1)) Else i = 0 s = s + 1 End If ascimatrix = ascimatrix _ & Chr(97 + (ch Mod 4) + 4 * (i Mod 4)) ch = Int(ch / 4) i = Int(i / 4) Next ascimatrix = ascimatrix & vbNewLine Next r ReDim qrarr(0) qr_gen = ascimatrix Exit Function addmm: k = ecl * 8 + mask ' poly: 101 0011 0111 Call qr_bch_calc(k, &H537) 'MsgBox "mask :" & hex(k,3) & " " & hex(k xor &H5412,3) k = k Xor &H5412 ' micro xor &H4445 r = 0 c = siz - 1 For i = 0 To 14 ch = k Mod 2 k = Int(k / 2) x = qr_bit(qrarr, -1, r, 8, ch) ' svisle fmtinfo UL - bity 0..5 SYNC 6,7 .... 8..14 dole x = qr_bit(qrarr, -1, 8, c, ch) ' vodorovne odzadu 0..7 ............ 8,SYNC,9..14 c = c - 1 r = r + 1 If i = 7 Then c = 7: r = siz - 7 If i = 5 Then r = r + 1 ' preskoc sync vodorvny If i = 8 Then c = c - 1 ' preskoc sync svisly Next Return End Function ' qr_gen