为什么这个VBA生成的QR码呢？ （条形码VBA-只有宏）

本文介绍了为什么这个VBA生成的QR码呢？ （条形码VBA-只有宏）的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！ 问题描述 限时删除！！ 上下文 我正在使用 奇怪地重复部分内容： BCD 001 1 SCT SOLADES1HDB 收件人姓名 DE 收件人姓名 DE86672500200000123456 EUR123.45 （注意 DE 和行 我想要什么 A工作，免费/ GPL解决方案在Excel中生成这样的代码;-) ...例如通过了解为什么这个愉快呃，修正VBA代码。 我试过了（更新1） 我已经玩过不同的输入，发现只要在长号码的末尾添加一些额外的AAA即可解决口吃...所以我很感兴趣的原因是什么。 我在GitHub上打了代码，添加了一些代码注释，并翻译了一些现有的（捷克语）评论 通过一些调试，我发现这个实现使得不同编码的起始位置（它存储在数组 eb 代码 您可以下载我的测试XLSM文件这里，并访问我的改进的代码文件在GitHub上。 我认为这个问题可能在下面的核心函数中，数组 eb（）已经被填写了。 函数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到4）As Integer'存储ECI模式中应该有多少个字符。这是行列表，每行对应一个不同ECI模式的下一批字符。 'eb（i，1） - ECI模式（1 =数字，2 =字母数字，3 =字节）'eb（i，2） - 上一行中的最后一个字符'eb （i，3） - 该行中的字符数'eb（i，4） - 该行的位数 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 =Mi = InStr（poptions，mode =）如果i> 0 Then mode = Mid（poptions，i + 5，1）'M = 0，L = 1，H = 2，Q = 3 ecl = InStr（MLHQ，mode） 如果ecl 如果ptext =然后 err =不是数据退出函数结束如果对于i = 1到3 ecx_pos（i）= 0 ecx_cnt（i）= 0 ecx_poc（i）= 0 下一个i ebcnt = 1 utf8 = 0 对于i = 1 To Len（ptext）+ 1 '确定这个字符有多少个字节如果i> Len（ptext）然后 k = -5'文本结束 - >跳过几个代码段否则需要解析ptext的字符i并确定它有多少个字节k = AscL（Mid（ptext，i，1））如果k> =& ; H1FFFFF然后'FFFF - 1FFFFFFF m = 4 k = -1 ElseIf k> =& H7FF然后'7FF-FFFF 3个字节m = 3 k = -1 ElseIf k> = 128然后m = 2 k = -1 Else'正常的7位ASCII字符，所以值得检查它是否属于数字或ECI（数组qralnum）中定义的字母数字子集m = 1 k = InStr（qralnum，Mid（ptext，i，1）） - 1 End If End If '根据k和很多其他的东西，增加ebcnt 如果（k 如果ecx_cnt（1）> = 9或（k = -5和ecx_cnt（1）= ecx_cnt（3））然后'直到现在可能数字？ （Az dos ud lo lo ne ne ne ne ne ne） If（ecx_cnt（2） - ecx_cnt（1））> = 8 Or（ecx_cnt（3）= ecx_cnt（2））然后' $ b 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）'位置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）然后'byly bytes pred numeric eb（ebcnt，1）= 3'Typ byte eb（ebcnt，2）= ecx_pos（3）'位置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）或（k = -5和ecx_cnt（2）= ecx_cnt（3））然后'Az dosud bylo mozno pouzitelne alnum If（ecx_cnt（3）> ecx_cnt ））然后'Jeste pred alnum bylo byte eb（ebcnt，1）= 3'Typ byte eb（ebcnt，2）= ecx_pos（3）'位置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_p oc（2）+ 1 ecx_cnt（3）= 0 ecx_cnt（2）= 0'vse zpracovano ElseIf（k = -5 And ecx_cnt（3） 0）然后'konec ale mam co ulozit eb（ebcnt，1）= 3'Typ byte eb（ebcnt，2）= ecx_pos（3）'位置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然后退出如果（k> = 0）那么'我们可以字母数字吗？ （Muzeme alnum） If（k> = 10 And ecx_cnt（1）> = 12）然后'直到现在它可能是数字（Az dosud bylo mozno num）如果（ecx_cnt（2） - ecx_cnt（1））> = 8 Or（ecx_cnt（3）= ecx_cnt（2））然后'还有一个值得的字母数字（Je tam i alnum ktery stoji za to） If（ecx_cnt （3）> ecx_cnt（2））Then'甚至在它是alnum字节（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' （vse zpracovano） ElseIf（ecx_cnt（3）> ecx_cnt（1））然后'上一个Num是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'处理所有内容（vse zpracovano） End If 如果ecx_cnt（2）= 0，那么ecx_pos（2）= i ecx_cnt（2） = ecx_cnt（2）+ 1 否则可能的alnum（mozno alnum） ecx_cnt（2）= 0 End If 如果k> = 0，k 如果ecx_cnt（1）= 0那么ecx_pos（1）= i ecx_cnt（1）= ecx_cnt（1）+ 1 Else ecx_cnt（1）= 0 如果如果ecx_cnt（3）= 0则ecx_pos（3）= i ecx_cnt（3）= ecx_cnt（3）+ m utf8 = utf8 + m 如果ebcnt> = 16那么'我们已经采取了3个其他的位块（Uz by se mi tri dalsi bloky stejne nevesli） ecx_cnt（1）= 0 ecx_cnt（2）= 0 End If Debug.PrintCharacter：'&中（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）下一个 ebcnt = ebcnt - 1'ebcnt现在有其最终值 Debug.Print（ebcnt =& ebcnt）c = 0 对于i = 1到ebcnt 选择案例eb（i，1）案例1：eb（i，4）= Int（eb（i，3）/ 3）* 10 +（eb i，3）mod 3）* 3 + IIf（（eb（i，3）Mod 3）> 0,0,0,1,0）情况2：eb（i，4）= Int（eb（i， 3）/ 2）* 11 +（eb（i，3）Mod 2）* 6 情况3：eb（i，4）= eb（i，3）* 8 结束选择c = c + eb（i，4） Next i Debug.Print（c =& c）'UTF-8默认不需要ECI值 - zxing不能识别'调用qr_params（i * 8 + utf8，mode，qrp）调用qr_params（c，ecl，qrp，ecx_poc）如果qrp（1）< = 0然后 err =Too long退出函数如果 siz = qrp（2） Debug.Printver：& qrp（1）&模式& size& siz& ecc：& qrp（3）& x& qrp（4）& d：& （qrp（5） - qrp（3）* qrp（4））'MsgBoxver：& qrp（1）&模式& size& siz& ecc：& qrp（3）& x& qrp（4）& d：& （qrp（5） - qrp（3）* qrp（4）） ReDim encoded1（qrp（5）+ 2）'表3 - QR码字符计数指示符中的位数2005： '模式指示符（1 = num，2 = AlNum，4 =字节，8 =汉字，ECI = 7）'模式：字节字母数字汉字'ver 1..9： 8 9 10 8 '10..26：16 11 12 10 '27..40：16 13 14 12 'UTF-8默认不需要ECI值 - zxing无法识别'如果utf8> 0然后'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 对于i = 1至ebcnt 选择案例eb（i，1）案例1：c = IIf（qrp（1）情况2：c = IIf（qrp（1））< 10,9，IIf（qrp 1）< 27,11,13））：k = 2 *（2 ^ c）+ eb（i，3）'编码模式alphanum 情况3：c = IIf（qrp（1）编码模式字节结束选择调用bb_putbits（encoded1，encix1，k，c + 4） Debug.Printver：& qrp（1）& mode&size& siz&ecc：& qrp（3）&x&qrp （4）&d：&（qrp（5） - qrp（3）* qrp（4））j = 0'在这行输出的计数字符eb（i，... ）m = eb（i，2）'从上一行输入的最后一个字符开始（之后）r = 0 虽然j k = AscL（Mid（ptext，m，1））m = m + 1 如果eb（i，1）= 1然后'解析数字输入 - 输出3个十进制数字进入10位r =（r * 10）+（（k - & H30）Mod 10） If（j Mod 3）= 2然后调用bb_putbits（encoded1，encix1，r ，10）r = 0 End If j = j + 1 ElseIf eb（i，1）= 2然后'解析字母数字输入 - 输出2个字母数字字符变成11位r =（r * 45）+（（InStr（qralnum，Chr（k）） - 1）Mod 45） If（j Mod 2）= 1然后调用bb_putbits （编码1，encix1，r，11）r = 0 结束如果j = j + 1 Else '好的，字节模式：根据第6.4节.2 ISOIEC 18004_2006Cor 1_2009.pdf 的扩展通道解释（ECI）模式如果k> & H1FFFFF然后'FFFF - 1FFFFFFF ch =& HF0 + Int（k /& H40000）Mod 8 调用bb_putbits（encoded1，encix1，ch，8） ch = 128 + Int（k /& H1000）Mod 64 调用bb_putbits（encoded1，encix1，ch，8） ch = 128 + Int（k / 64）Mod 64 调用bb_putbits ，encix1，ch，8） ch = 128 + k Mod 64 调用bb_putbits（encoded1，encix1，ch，8）j = j + 4 ElseIf k& & H7FF然后'7FF-FFFF 3字节 ch =& HE0 + Int（k /& H1000）Mod 16 调用bb_putbits（encoded1，encix1，ch，8） ch = 128 + Int（k / 64）Mod 64 调用bb_putbits（encoded1，encix1，ch，8） ch = 128 + k Mod 64 调用bb_putbits（encoded1，encix1，ch， 8）j = j + 3 ElseIf k> & H7F然后'2字节 ch =& HC0 + Int（k / 64）Mod 32 调用bb_putbits（encoded1，encix1，ch，8） ch = 128 + k Mod 64 调用bb_putbits（encoded1，encix1，ch，8）j = j + 2 Else ch = k Mod 256 调用bb_putbits（encoded1，encix1，ch ，8）j = j + 1 如果结束If Wend 选择案例eb（i，1）案例1： if（j Mod 3）= 1然后调用bb_putbits（encoded1，encix1，r，4） ElseIf（j Mod 3）= 2然后调用bb_putbits（encoded1，encix1，r ，7）结束If 案例2：如果（j Mod 2）= 1然后调用bb_putbits（encoded1，encix1，r，6）结束选择 'MsgBox'blk [&我& ] t：& eb（i，1）& from& eb（i，2）& 到& eb（i，3）+ eb（i，2）& bits =& encix1 Next i 调用bb_putbits（encoded1，encix1，0，4）'end of chain 如果（encix1 Mod 8） 0然后'round to byte 调用bb_putbits（encoded1，encix1，0，8 - （encix1 Mod 8）） End If 'padding i =（qrp（5） - qrp（3）* qrp（4））* 8 如果encix1>我然后 err =编码长度错误退出函数结束如果'padding 0xEC，0x11,0xEC，0x11 ... Do While encix1& i 调用bb_putbits（encoded1，encix1，& HEC11,16）循环'doplnime ECC i = qrp（3）* qrp（4）'ppoly，pmemptr，psize ，全部，pblocks 调用qr_rs（& H11D，encoded1，qrp（5） - i，i，qrp（4））'调用arr2hexstr（encoded1） encix1 = qrp ）'Pole pro vystup ReDim qrarr（0） ReDim qrarr（1，qrp（2）* 24& + 24&）'每行24个字节 qrarr（0 ，0）= 0 ch = 0 调用bb_putbits（qrsync1，ch，Array（& HFE，& H82，& HBA，& HBA，& HBA，& H82，& ; HFE，0），64）调用qr_mask（qrarr，qrsync1,8,0,0）'sync UL 调用qr_mask（qrarr，0，8，8，0）'fmtinfo UL - bity 14..9 SYNC 8 调用qr_mask（qrarr，qrsync1,8,0，siz-7）'sync UR（o bit vlevo）调用qr_mask（qrarr，0，8，8，siz - 8）'fmtinfo UR - bity 7..0 调用qr_mask（qrarr，qrsync1,8，siz - 7，0）'sync DL（zasahuje我做安静的zony）调用qr_mask（qrarr， 0，8，siz - 8，0）'blan k nad DL 对于i = 0到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空白pred UR x = qr_bit（qrarr，-1，siz - 1 - i，8，0）'svisle fmtinfo DL - bity 14。 .8 下一个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 如果qrp（13） 0或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 对于i = 0到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 如果c> 2然后c = 0：r = r + 1 k = Int（k / 2&）下一个结束如果c = 1 对于i = 8 To siz - 9'同步线x = qr_bit（qrarr，-1，i，6，c）'垂直列6 x = qr_bit（qrarr，-1,6，i，c） 6 c =（c + 1）Mod 2 下一个'其他同步 ch = 0 调用bb_putbits（qrsync2，ch，Array（& H1F，& ; H11，&H15，& H11，&H1F），40） ch = 6 Do While ch> 0和qrp（6 + ch）= 0 ch = ch - 1 循环如果ch> 0然后对于c = 0对于ch 对于r = 0对于ch 'corner 如果（c （c-ch或r 0）和_ （c - 0或r - ch）然后调用qr_mask（qrarr， qrsync2，5，qrp（r + 6） - 2，qrp（c + 6） - 2）结束如果下一步r 下一步c 结束如果 '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 调用qr_fill（qrarr，siz，encoded1，qrp（4），qrp（5） - qrp（3）* qrp（4），qrp（5）） mask = 8'auto i = InStr（poptions，mask =）如果i> 0 Then mask = val（Mid（poptions，i + 5，1））如果mask< 0或掩码> 7然后j = -1 对于mask = 0到7 GoSub addmm i = qr_xormask（qrarr，siz，mask，False）'MsgBoxscore mask &安培;面具& 是& i 如果i< j或j = -1然后j = i：s = mask 下一个掩码 mask = s 'MsgBoxbest is&面具& 得分& j 如果 GoSub addmm i = qr_xormask（qrarr，siz，mask，True） ascimatrix =对于r = 0到siz步骤2 s = 0 对于c = 0对于siz步骤2 如果（c Mod 8）= 0则 ch = qrarr（1，s + 24 * r）如果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）下一个 ascimatrix = ascimatrix& vbNewLine 下一个r ReDim qrarr（0） qr_gen = ascimatrix 退出函数 addmm：k = ecl * 8 + mask ' poly：101 0011 0111 调用qr_bch_calc（k，& H537）'MsgBoxmask：& hex（k，3）& & hex（k xor& H5412,3）k = k Xor& H5412'micro xor& H4445 r = 0 c = siz - 1 对于i = 0到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 如果i = 7则c = 7：r = siz - 7 如果i = 5则r = r + 1'preskoc sync vodorvny 如果i = 8则c = c - 1'preskoc sync svisly 下一个返回结束函数'qr_gen 解决方案 为什么会这样 通过一些调试，我发现原始的实现混淆了不同编码（它存储在数组 eb ）中的起始位置：编码后包括换行符和DE作为字节的收件人姓氏，第p页可靠地尝试切换到十进制或字母编码（每个字符仅为3.33或5.5位，而不是8）...但是后退到字节格式的编码，从而使起始位置错误。 > 解决方案 我现在已经将一些错误检查添加到手动删除口吃。 您可以在 Github ，特别参见 barcody .bas 。 关键的补充是这部分： i = 1 虽然i< （ebcnt-1）如果eb（i，2）+ eb（i，3） eb（i + 1，2）然后'oops，这不应该发生。第一个文件： Debug.Print（eb（）rows& i&和& i + 1&重叠！）'现在让我们看看修复它： wasfixed = False 对于k = i到1步骤-1 如果eb（k，2）= eb（i + 1，2）然后' ，我的行k似乎包含在i + 1和以下。删除k到我... 对于j = k到ebcnt - （i - k + 1）'...通过向上复制所有后续的行... eb（j，1）= eb （j +（i-k + 1），1） eb（j，2）= eb（j +（i-k + 1），2） eb（j，3）= eb （j +（i-k + 1），3） eb（j，4）= eb（j +（i-k + 1），4）下一步j ebcnt = ebcnt - （i-k + 1）'并纠正总行数 wasfixed = True 退出结束如果下一个k 如果没有（已固定）则 MsgBox（输入文本分析失败 - 进入调试模式...） Debug.Assert False End If End If i = i + 1 Wend ContextI am using barcode-vba-macro-only (mentioned in this SO post) in MS Excel 2010 to generate a QR code.(The bar code will be used to facilitate paying a bill using Girocode, but that is not important here, except to say I need to structure the input exactly the way shown below.)The problemThe VBA macro creates great QR-Codes, but somehow, when given certain input, the output (encoded in the QR code) "stutters", i.e. repeats part of the text.E.g., when given this input:BCD0011SCTSOLADES1HDBRecipient First and Last NameDE86672500200000123456EUR123.45it produces this output:which oddly repeats part of the content:BCD0011SCTSOLADES1HDBRecipient First and Last NameDERecipient First and Last NameDE86672500200000123456EUR123.45(Note the DE and the line Recipient First and Last Name which appear twice.)What I wantA working, free/GPL solution in Excel to generate such codes ;-) ... for example by understanding why this happens, and fixing the VBA code.What I have tried (Update 1)I have played around with different inputs and found that just adding some extra "AAA" to the end of the long number solves the stuttering... so I am intrigued what causes this.I forked to code on GitHub, added some code comments and translated a few of the existing (Czech) commentsThrough some debugging, I found that the implementation messes up the starting position of different encodings (which it stores in array eb): after encoding the "Recipient First and Last Name" including newline and "DE" as "Byte", it probably tries to switch to "Decimal" or "Alphanum" encoding (only 3.33 or 5.5 bit per character instead of 8)... but then falls back to encoding in "Byte" format and thereby gets the starting position wrong.The codeYou can download my test XLSM file here, and access my improved code file on GitHub.I think the issue is probably in the core function shown below, in the section where the array eb() is filled.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 Functionaddmm: 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 ReturnEnd Function ' qr_gen 解决方案 Why this happensThrough some debugging, I found that the original implementation messes up the starting position of different encodings (which it stores in array eb): after encoding the "Recipient First and Last Name" including newline and "DE" as "Byte", it probably tries to switch to "Decimal" or "Alphanum" encoding (only 3.33 or 5.5 bit per character instead of 8)... but then falls back to encoding in "Byte" format and thereby gets the starting position wrong.The solutionI have now added some error checking to the code which manually removes the stuttering.You can find my improved code on Github, see in particular barcody.bas.The key addition is this part: i = 1 While i < (ebcnt - 1) If eb(i, 2) + eb(i, 3) <> eb(i + 1, 2) Then ' oops, this should not happen. First document it: Debug.Print ("eb() rows " & i & " and " & i + 1 & " are overlapping!") ' Now Lets see if we can fix it: wasfixed = False For k = i To 1 Step -1 If eb(k, 2) = eb(i + 1, 2) Then ' okay, the row k to i seem to be contained in i+1 and following. Delete k to i ... For j = k To ebcnt - (i - k + 1) ' ... by copying upwards all later rows... eb(j, 1) = eb(j + (i - k + 1), 1) eb(j, 2) = eb(j + (i - k + 1), 2) eb(j, 3) = eb(j + (i - k + 1), 3) eb(j, 4) = eb(j + (i - k + 1), 4) Next j ebcnt = ebcnt - (i - k + 1) ' and correcting the total rowcount wasfixed = True Exit For End If Next k If Not (wasfixed) Then MsgBox ("The input text analysis failed - entering debug mode...") Debug.Assert False End If End If i = i + 1 Wend 这篇关于为什么这个VBA生成的QR码呢？ （条形码VBA-只有宏）的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！ 1403页，肝出来的..