为什么VBA会生成二维码口吃?(仅条形码vba宏) 上下文

为什么VBA会生成二维码口吃?(仅条形码vba宏) 上下文,vba,excel,qr-code,Vba,Excel,Qr Code,我正在使用MS Excel 2010中的(中提到)生成二维码 (条形码将用于方便使用支付账单,但这在这里并不重要,只是说我需要按照如下所示的方式构造输入。) 问题 VBA宏可以创建出色的二维码,但在给定特定输入时,输出(编码在二维码中)会“结巴”,即重复部分文本 例如,当给出该输入时: BCD 001 1 SCT SOLADES1HDB Recipient First and Last Name DE86672500200000123456 EUR123.45 它产生以下输出: 奇怪地重复了

我正在使用MS Excel 2010中的(中提到)生成二维码

(条形码将用于方便使用支付账单,但这在这里并不重要,只是说我需要按照如下所示的方式构造输入。)

问题 VBA宏可以创建出色的二维码,但在给定特定输入时,输出(编码在二维码中)会“结巴”,即重复部分文本

例如,当给出该输入时:

BCD
001
1
SCT
SOLADES1HDB
Recipient First and Last Name
DE86672500200000123456
EUR123.45
它产生以下输出:

奇怪地重复了部分内容:

BCD
001
1
SCT
SOLADES1HDB
Recipient First and Last Name
DE
Recipient First and Last Name
DE86672500200000123456
EUR123.45
(注意出现两次的DE收件人姓名行。)

我想要什么 Excel中用于生成此类代码的工作、免费/GPL解决方案;-)。。。例如,了解为什么会发生这种情况,并修复VBA代码

我尝试过的内容(更新1)
  • 我尝试了不同的输入,发现在长数字的末尾添加一些额外的“AAA”可以解决口吃问题。。。所以我很好奇这是什么原因造成的

  • 我转向GitHub上的代码,添加了一些代码注释,并翻译了一些现有的(捷克语)注释

  • 通过一些调试,我发现实现打乱了不同编码的起始位置(它存储在数组
    eb
    ):在将“收件人姓名”包括换行符和“DE”编码为“Byte”后,它可能试图切换到“Decimal”或“Alphanum”编码(每个字符只有3.33位或5.5位,而不是8位)…但随后又返回到“字节”格式编码,从而导致起始位置错误

  • 代码 您可以下载我的测试XLSM文件,并访问我的

    我认为问题可能出在下面显示的核心函数中,在数组
    eb()
    填充的部分

    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
    
    函数qr_gen(ptext作为字符串,poptions作为字符串)作为字符串
    Dim encoded1()作为字节模式(ASCII)所有最大值为3200字节
    Dim encix1%
    Dim ecx_cnt(3)作为整数
    尺寸ecx_位置(3)为整数
    Dim ecx_poc(3)为整数
    Dim eb(1到20,1到4)作为整数'存储在哪个ECI模式下应该有多少个字符。这是一个行列表,每行对应一个具有不同ECI模式的下一批字符。
    'eb(i,1)-ECI模式(1=数字,2=字母数字,3=字节)
    'eb(i,2)-上一行的最后一个字符
    'eb(i,3)-此行中的字符数
    'eb(i,4)-此行的位数
    矩阵$,模式$,错误$
    暗ecl%、r%、c%、遮罩%、utf8%、ebcnt%
    尺寸i&,j&,k&,m&
    尺寸百分比,s%,尺寸百分比
    将x作为布尔值
    Dim qrarr()作为字节的最终矩阵
    将qrpos设置为整数
    将qrp(15)调整为整数'1:版本,2:大小,3:ccs,4:ccb,5:totby,6-12:同步(7),13-15:版本信息(3)
    Dim qrsync1(1到8)作为字节
    Dim qrsync2(1到5)作为字节
    ascimatrix=“”
    err=“”
    mode=“M”
    i=仪表(选项,“模式=”)
    如果i>0,则模式=中间(poptions,i+5,1)
    'M=0,L=1,H=2,Q=3
    ecl=仪表(“MLHQ”,模式)-1
    如果ecl<0,则mode=“M”:ecl=0
    如果ptext=“”,则
    err=“非数据”
    退出功能
    如果结束
    对于i=1到3
    ecx_位置(i)=0
    ecx_cnt(i)=0
    ecx_poc(i)=0
    接下来我
    ebcnt=1
    utf8=0
    对于i=1到Len(ptext)+1
    '决定此字符有多少字节
    如果i>Len(ptext),则
    k=-5'文本结尾-->跳过几个代码段
    Else’需要解析ptext的字符i并决定它有多少字节
    k=AscL(Mid(ptext,i,1))
    如果k>=&H1FFFFF,则“FFFF-1FFFFFF”
    m=4
    k=-1
    ElseIf k>=&H7FF然后是'7FF-FFFF 3字节
    m=3
    k=-1
    如果k>=128,则
    m=2
    k=-1
    Else的标准7位ASCII字符,因此值得检查它是否属于ECI(数组qralnum)中定义的数字或字母数字子集
    m=1
    k=仪表(qralnum,Mid(ptext,i,1))-1
    如果结束
    如果结束
    根据k和许多其他因素,增加ebcnt
    如果(k<0),则“处理多字节情况或退出”(bude byte nebo konec)
    如果ecx_cnt(1)>=9或(k=-5且ecx_cnt(1)=ecx_cnt(3)),则“到目前为止,它可能是数值的?”(Az dosud bylo mozno pouzitelne数值)
    如果(ecx_cnt(2)-ecx_cnt(1))>=8或(ecx_cnt(3)=ecx_cnt(2)),则“pred num je i pouzitelny alnum
    如果(ecx_cnt(3)>ecx_cnt(2)),则“Jeste pred alnum bylo字节
    eb(ebcnt,1)=3'典型字节
    eb(ebcnt,2)=ecx_位置(3)'位置坐标
    eb(ebcnt,3)=ecx_cnt(3)-ecx_cnt(2)'delka
    ebcnt=ebcnt+1
    ecx_poc(3)=ecx_poc(3)+1
    如果结束
    eb(ebcnt,1)=2'典型铝数
    eb(ebcnt,2)=ecx_位置(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'典型字节
    eb(ebcnt,2)=ecx_位置(3)'位置坐标
    eb(ebcnt,3)=ecx_cnt(3)-ecx_cnt(1)'delka
    ebcnt=ebcnt+1
    ecx_poc(3)=ecx_poc(3)+1
    如果结束
    如果(ecx_cnt(2)>=8)或(k=-5且ecx_cnt(2)=ecx_cnt(3)),则由mozno pouzitelne alnum提供
    如果(ecx_cnt(3)>ecx_cnt(2)),则“Jeste pred alnum bylo字节
    eb(ebcnt,1)=3'典型字节
    eb(ebcnt,2)=ecx_位置(3)'位置坐标
    eb(ebcnt,3)=ecx_cnt(3)-ecx_cnt(2)'delka
    ebcnt=ebcnt+1
    ecx_poc(3)=ecx_poc(3)+1
    如果结束
    eb(ebcnt,1)=2'典型铝数
    eb(ebcnt,2)=ecx_位置(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和ecx_cnt(3)>0
    
    BCD
    001
    1
    SCT
    SOLADES1HDB
    Recipient First and Last Name
     DE86672500200000123456 
    EUR123.45
    
      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