Codigo para generar QR

Os paso código para genear QRs en informes, si alguien quiere un ejemplo que me lo indique, ahí lo lleváis:

Option Compare Binary
Option Explicit

Rem 2020 modificado por Manuel Martínez Baena para Access
Rem mmbaena@gmail.com
Rem codigo original para excell Copyright ? 2013 Madeta a.s. Jiri Gabriel

Const constQR_AlNum$ = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ $%*+-./:"

Dim IsMs As Boolean


'se utiliza en informes en el evento print
'Private Sub Detail_Print(Cancel As Integer, PrintCount As Integer)
'    Call RenderQRCode(Me.Name, Me.rectQR.Name, "https://www.google.es/maps/place/Cortijo+%22El+Pulgar%22/@37.244097,-3.5595208,18z", False)
'End Sub
Public Sub RenderQRCode(strReport As String, strControl As String, textValue As String, Optional s_param As String, Optional addLabel As Boolean)
   Dim s_encoded As String

   s_encoded = qr_gen(textValue, s_param)
   Call DrawQRCode(s_encoded, strReport, strControl)

End Sub



Sub DibujarRectanguloEnInforme(strReport As String, _
        ByVal intPunto1X As Integer, ByVal intPunto1Y As Integer, _
        ByVal intAncho As Integer, ByVal intAlto As Integer, _
        Optional intEscala As Double = 8, Optional lngColor As Long = vbBlack)
'dibuja un cuadrado en un informe en tiempo de ejecucion, se le pasa coordenadas del la esquina sup izq, ancho y alto y color
    Dim rptInforme As Report, intN As Integer
    
On Error GoTo Err_Procedimiento

    Set rptInforme = Reports(strReport)
    rptInforme.ScaleMode = 1
    rptInforme.DrawWidth = 1
    'ajusta la escala
    intAncho = intEscala * intAncho
    intAlto = intEscala * intAlto
    intPunto1X = intEscala * intPunto1X
    intPunto1Y = intEscala * intPunto1Y
    
    'el alto es el numero de lineas y el ancho el largo de la linea, asi no pierde definicion
    For intN = 0 To intAlto
        rptInforme.Line (intPunto1X, intPunto1Y + intN)-((intPunto1X + intAncho), (intPunto1Y + 1)), lngColor, B
    Next intN
    
Exit_Procedimiento:
    On Error GoTo 0
    Exit Sub
   
Err_Procedimiento:
    MsgBox "Error " & err.Number & " en proc. DibujarRectanguloEnInforme:  (" & err.Description & ")"
    GoTo Exit_Procedimiento:
End Sub

Function AscL(s As String) As Long
  If IsMs Then AscL = AscW(s) Else AscL = Asc(s)
End Function

Sub qr_rs(ppoly As Integer, pmemptr As Variant, ByVal psize As Integer, ByVal plen As Integer, ByVal pblocks As Integer)
    Dim v_x%, v_y%, v_z%, v_a%, v_b%, pa%, pb%, rp%, v_last%, v_bs%, v_b2c%, vpo%, vdo%, v_es%
    Dim poly(512) As Byte
    Dim v_ply() As Byte
'    Dim dbg$
    ' generate reed solomon expTable and logTable
    '   QR uses GF256(0x11d) // 0x11d=285 => x^8 + x^4 + x^3 + x^2 + 1
    v_x = 1: v_y = 0
    For v_y = 0 To 255
      poly(v_y) = v_x         ' expTable
      poly(v_x + 256) = v_y   ' logTable
      v_x = v_x * 2
      If v_x > 255 Then v_x = v_x Xor ppoly
    Next
'    poly(257) =    ' pro QR logTable(1) = 0 not50
'Call arr2decstr(poly)
    For v_x = 1 To plen
      pmemptr(v_x + psize) = 0
    Next
    v_b2c = pblocks
    ' qr code has first x blocks shorter than lasts
    v_bs = Int(psize / pblocks) ' shorter block size
    v_es = Int(plen / pblocks) ' ecc block size
    v_x = psize Mod pblocks ' remain bytes
    v_b2c = pblocks - v_x ' on block number v_b2c
    ReDim v_ply(v_es + 1)
    v_z = 0 ' pro QR je v_z=0 pro dmx je v_z=1
    v_ply(1) = 1
    v_x = 2
    Do While v_x <= v_es + 1
      v_ply(v_x) = v_ply(v_x - 1)
      v_y = v_x - 1
      Do While v_y > 1
        pb = poly(v_z)
        pa = v_ply(v_y): GoSub rsprod
        v_ply(v_y) = v_ply(v_y - 1) Xor rp
        v_y = v_y - 1
      Loop
      pa = v_ply(1): pb = poly(v_z): GoSub rsprod
      v_ply(1) = rp
      v_z = v_z + 1
      v_x = v_x + 1
    Loop
'Call arr2hexstr(v_ply)
    For v_b = 0 To (pblocks - 1)
      vpo = v_b * v_es + 1 + psize ' ECC start
      vdo = v_b * v_bs + 1 ' data start
      If v_b > v_b2c Then vdo = vdo + v_b - v_b2c ' x longers before
      ' generate "nc" checkwords in the array
      v_x = 0
      v_z = v_bs
      If v_b >= v_b2c Then v_z = v_z + 1
      Do While v_x < v_z
        pa = pmemptr(vpo) Xor pmemptr(vdo + v_x)
        v_y = vpo
        v_a = v_es
        Do While v_a > 0
          pb = v_ply(v_a): GoSub rsprod
          If v_a = 1 Then
            pmemptr(v_y) = rp
          Else
            pmemptr(v_y) = pmemptr(v_y + 1) Xor rp
          End If
          v_y = v_y + 1
          v_a = v_a - 1
        Loop
        v_x = v_x + 1
'if v_b = 0 and v_x = v_z then call arr2hexstr(pmemptr)
      Loop
    Next
    Exit Sub
rsprod:
    rp = 0
    If pa > 0 And pb > 0 Then rp = poly((0& + poly(256 + pa) + poly(256 + pb)) Mod 255&)
    Return
End Sub ' reed solomon qr_rs

Sub bb_putbits(ByRef parr As Variant, ByRef ppos As Integer, pa As Variant, ByVal plen As Integer)
  Dim i%, b%, w&, l%, j%
  Dim dw As Double
  Dim X(7) As Byte
  Dim Y As Variant
  w = VarType(pa)
  If w = 17 Or w = 2 Or w = 3 Or w = 5 Then ' byte,integer,long, double
    If plen > 56 Then Exit Sub
    dw = pa
    l = plen
    If l < 56 Then dw = dw * 2 ^ (56 - l)
    i = 0
    Do While i < 6 And dw > 0#
      w = Int(dw / 2 ^ 48)
      X(i) = w Mod 256
      dw = dw - 2 ^ 48 * w
      dw = dw * 256
      l = l - 8
      i = i + 1
    Loop
    Y = X
  ElseIf InStr("Integer(),Byte(),Long(),Variant()", TypeName(pa)) > 0 Then
    Y = pa
  Else
    MsgBox TypeName(pa), "Unknown type"
    Exit Sub
  End If
  i = Int(ppos / 8) + 1
  b = ppos Mod 8
  j = LBound(Y)
  l = plen
  Do While l > 0
    If j <= UBound(Y) Then
      w = Y(j)
      j = j + 1
    Else
      w = 0
    End If
    If (l < 8) Then w = w And (256 - 2 ^ (8 - l))
    If b > 0 Then
      w = w * 2 ^ (8 - b)
      parr(i) = parr(i) Or Int(w / 256)
      parr(i + 1) = parr(i + 1) Or (w And 255)
    Else
      parr(i) = parr(i) Or (w And 255)
    End If
    If l < 8 Then
      ppos = ppos + l
      l = 0
    Else
      ppos = ppos + 8
      i = i + 1
      l = l - 8
    End If
  Loop
End Sub

Function qr_numbits(ByVal Num As Long) As Integer
  Dim n%, a&
  a = 1: n = 0
  Do While a <= Num
    a = a * 2
    n = n + 1
  Loop
  qr_numbits = n
End Function

' padding 0xEC,0x11,0xEC,0x11...
' TYPE_INFO_MASK_PATTERN = 0x5412
' TYPE_INFO_POLY = 0x537  [(ecLevel << 3) | maskPattern] : 5 + 10 = 15 bitu
' VERSION_INFO_POLY = 0x1f25 : 5 + 12 = 17 bitu
Sub qr_bch_calc(ByRef data As Long, ByVal poly As Long)
  Dim b%, n%, rv&, X&
  b = qr_numbits(poly) - 1
  If data = 0 Then
'    data = poly
    Exit Sub
  End If
  X = data * 2 ^ b
  rv = X
  Do
    n = qr_numbits(rv)
    If n <= b Then Exit Do
    rv = rv Xor (poly * 2 ^ (n - b - 1))
  Loop
  data = X + rv
End Sub

Sub qr_params(ByVal pcap As Long, ByVal ecl As Integer, ByRef rv As Variant, ByRef ecx_poc As Variant)
  Dim siz%, totby&, s$, i&, syncs%, ccsiz%, ccblks%, j&, ver%
'  Dim rv(15) as Integer ' 1:version,2:size,3:ccs,4:ccb,5:totby,6-12:syncs(7),13-15:versinfo(3)
'  ecl:M=0,L=1,H=2,Q=3
  If ecl < 0 Or ecl > 3 Then Exit Sub
  For i = 1 To UBound(rv): rv(i) = 0: Next i
  j = Int((pcap + 18 * ecx_poc(1) + 17 * ecx_poc(2) + 20 * ecx_poc(3) + 7) / 8)
  If ecl = 0 And j > 2334 Or _
     ecl = 1 And j > 2956 Or _
     ecl = 2 And j > 1276 Or _
     ecl = 3 And j > 1666 Then
    Exit Sub
  End If
  j = Int((pcap + 14 * ecx_poc(1) + 13 * ecx_poc(2) + 12 * ecx_poc(3) + 7) / 8)
  For ver = 1 To 40
    If ver = 10 Then j = Int((pcap + 16 * ecx_poc(1) + 15 * ecx_poc(2) + 20 * ecx_poc(3) + 7) / 8)
    If ver = 27 Then j = Int((pcap + 18 * ecx_poc(1) + 17 * ecx_poc(2) + 20 * ecx_poc(3) + 7) / 8)
    siz = 4 * ver + 17
    i = (ver - 1) * 12 + ecl * 3
    s = Mid("D01A01K01G01J01D01V01P01T01I01P02L02L02N01J04T02R02T01P04L04J04L02V04R04L04N02T05L06P04R02T06P06P05X02R08N08T05L04V08R08X05N04R11V08P08R04V11T10P09T04P16R12R09X04R16N16R10P06R18X12V10R06X16R17V11V06V19V16T13X06V21V18T14V07T25T21T16V08V25X20T17V08X25V23V17V09R34X23V18X09X30X25V20X10X32X27V21T12X35X29V23V12X37V34V25X12X40X34V26X13X42X35V28X14X45X38V29X15X48X40V31X16X51X43V33X17X54X45V35X18X57X48V37X19X60X51V38X19X63X53V40X20X66X56V43X21X70X59V45X22X74X62V47X24X77X65V49X25X81X68" _
            , i + 1, 3)
    ccsiz = AscL(Left(s, 1)) - 65 + 7
    ccblks = Val(Right(s, 2))
    If ver = 1 Then
      syncs = 0
      totby = 26
    Else
      syncs = ((Int(ver / 7) + 2) ^ 2) - 3
      totby = siz - 1
      totby = ((totby ^ 2) / 8) - (3& * syncs) - 24
      If ver > 6 Then totby = totby - 4
      If syncs = 1 Then totby = totby - 1
    End If
'MsgBox "ver:" & ver & " tot: " & totby & " dat:" & (totby - ccsiz * ccblks) & " need:" & j
    If totby - ccsiz * ccblks >= j Then Exit For
  Next
  If ver > 1 Then
    syncs = Int(ver / 7) + 2
    rv(6) = 6
    rv(5 + syncs) = siz - 7
    If syncs > 2 Then
      i = Int((siz - 13) / 2 / (syncs - 1) + 0.7) * 2
      rv(7) = rv(5 + syncs) - i * (syncs - 2)
      If syncs > 3 Then
        For j = 3 To syncs - 1
          rv(5 + j) = rv(4 + j) + i
        Next
      End If
    End If
  End If
  rv(1) = ver
  rv(2) = siz
  rv(3) = ccsiz: rv(4) = ccblks
  rv(5) = totby
  If ver >= 7 Then
    i = ver
    Call qr_bch_calc(i, &H1F25)
    rv(13) = Int(i / 65536)
    rv(14) = Int(i / 256&) Mod 256
    rv(15) = i Mod 256
  End If
End Sub

Function qr_bit(parr As Variant, ByVal psiz As Integer, _
                ByVal prow As Integer, ByVal pcol As Integer, _
                ByVal pbit As Integer) As Boolean
  Dim ix%, va%, r%, c%, s%
  r = prow
  c = pcol
  qr_bit = False
  ix = r * 24 + Int(c / 8) ' 24 bytes per row
  If ix > (UBound(parr, 2)) Or ix < 0 Then Exit Function
  c = 2 ^ (c Mod 8)
  va = parr(0, ix)
  If psiz > 0 Then ' Kontrola masky
    If (va And c) = 0 Then
      If pbit <> 0 Then parr(1, ix) = parr(1, ix) Or c
      qr_bit = True
    Else
      qr_bit = False
    End If
  Else
    qr_bit = True
    parr(1, ix) = parr(1, ix) And (255 - c) ' reset bit for psiz <= 0
    If pbit > 0 Then parr(1, ix) = parr(1, ix) Or c
    If psiz < 0 Then parr(0, ix) = parr(0, ix) Or c ' mask for psiz < 0
  End If
End Function

Sub qr_mask(parr As Variant, pb As Variant, ByVal pbits As Integer, ByVal pr As Integer, ByVal PC As Integer)
' max 8 bites wide
  Dim i%, w&, r%, c%, j%
  Dim X As Boolean
  If pbits > 8 Or pbits < 1 Then Exit Sub
  r = pr: c = PC
  w = VarType(pb)
  If w = 17 Or w = 2 Or w = 3 Or w = 5 Then ' byte,integer,long, double
    w = Int(pb)
    i = 2 ^ (pbits - 1)
    Do While i > 0
      X = qr_bit(parr, -1, r, c, w And i)
      c = c + 1
      i = Int(i / 2)
    Loop
  ElseIf InStr("Integer(),Byte(),Long(),Variant()", TypeName(pb)) > 0 Then
    For j = LBound(pb) To UBound(pb)
      w = Int(pb(j))
      i = 2 ^ (pbits - 1)
      c = PC
      Do While i > 0
        X = qr_bit(parr, -1, r, c, w And i)
        c = c + 1
        i = Int(i / 2)
      Loop
      r = r + 1
    Next
  End If
End Sub

Sub qr_fill(parr As Variant, ByVal psiz%, pb As Variant, ByVal pblocks As Integer, ByVal pdlen As Integer, ByVal ptlen As Integer)
  ' vyplni pole parr (psiz x 24 bytes) z pole pb pdlen = pocet dbytes, pblocks = bloku, ptlen celkem
  ' podle logiky qr_kodu - s prokladem
  Dim vx%, vb%, vy%, vdnlen%, vds%, ves%, c%, r%, wa%, wb%, w%, smer%, vsb%
  ' qr code has first x blocks shorter than lasts but datamatrix has first longer and shorter last
  vds = Int(pdlen / pblocks) ' shorter data block size
  ves = Int((ptlen - pdlen) / pblocks) ' ecc block size
  vdnlen = vds * pblocks ' potud jsou databloky stejne velike
  vsb = pblocks - (pdlen Mod pblocks) ' mensich databloku je ?
  
  c = psiz - 1: r = c ' start position on right lower corner
  smer = 0 ' nahoru :  3 <- 2 10  dolu: 1 <- 0  32
           '           1 <- 0 10        3 <- 2  32
  vb = 1: w = pb(1): vx = 0
  Do While c >= 0 And vb <= ptlen
    If qr_bit(parr, psiz, r, c, (w And 128)) Then
      vx = vx + 1
      If vx = 8 Then
        GoSub qrfnb ' first byte
        vx = 0
      Else
        w = (w * 2) Mod 256
      End If
    End If
    Select Case smer
      Case 0, 2 ' nahoru nebo dolu a jsem vpravo
        c = c - 1
        smer = smer + 1
      Case 1 ' nahoru a jsem vlevo
        If r = 0 Then ' nahoru uz to nejde
          c = c - 1
          If c = 6 And psiz >= 21 Then c = c - 1 ' preskoc sync na sloupci 6
          smer = 2 ' a jedeme dolu
        Else
          c = c + 1
          r = r - 1
          smer = 0 ' furt nahoru
        End If
      Case 3 ' dolu a jsem vlevo
        If r = (psiz - 1) Then ' dolu uz to nepude
          c = c - 1
          If c = 6 And psiz >= 21 Then c = c - 1 ' preskoc sync na sloupci 6
          smer = 0
        Else
          c = c + 1
          r = r + 1
          smer = 2
        End If
    End Select
  Loop
  Exit Sub
qrfnb:
  ' next byte
        ' plen = 14 pbl = 3   => 1x4 + 2x5 (v_b2c = 3 - 2 = 1; v_bs1 = 4)
        '     v_b = 0 => v_last = 0 + 4 * 3 - 2 = 10 => 1..12 by 3   1,4,7,10
        '     v_b = 1 => v_last = 1 + 4 * 3     = 13 => 2..13 by 3   2,5,8,11,13
        '     v_b = 2 => v_last = 2 + 4 * 3     = 14 => 3..14 by 3   3,6,9,12,14
        ' plen = 15 pbl = 3   => 3x5 (v_b2c = 3; v_bs1 = 5)
        '     v_b = 0 => v_last = 0 + 5 * 3 - 2 = 13 => 1..13 by 3   1,4,7,10,13
        '     v_b = 1 => v_last = 1 + 5 * 3 - 2 = 14 => 2..14 by 3   2,5,8,11,14
        '     v_b = 2 => v_last = 2 + 5 * 3 - 2 = 15 => 3..15 by 3   3,6,9,12,15
  If vb < pdlen Then ' Datovy byte
    wa = vb
    If vb >= vdnlen Then
      wa = wa + vsb
    End If
    wb = wa Mod pblocks
    wa = Int(wa / pblocks)
    If wb > vsb Then wa = wa + wb - vsb
'    If vb >= vdnlen Then MsgBox "D:" & (1 + vds * wb + wa)
    w = pb(1 + vds * wb + wa)
  ElseIf vb < ptlen Then ' ecc byte
    wa = vb - pdlen ' kolikaty ecc 0..x
    wb = wa Mod pblocks ' z bloku
    wa = Int(wa / pblocks) ' kolikaty
'    MsgBox "E:" & (1 + pdlen + ves * wb + wa)
    w = pb(1 + pdlen + ves * wb + wa)
  End If
  vb = vb + 1
  Return
End Sub

' Black If 0: (c+r) mod 2 = 0    4: ((r div 2) + (c div 3)) mod 2 = 0
'          1: r mod 2 = 0        5: (c*r) mod 2 + (c*r) mod 3 = 0
'          2: c mod 3 = 0        6: ((c*r) mod 2 + (c*r) mod 3) mod 2 = 0
'          3: (c+r) mod 3 = 0    7: ((c+r) mod 2 + (c*r) mod 3) mod 2 = 0
Function qr_xormask(parr As Variant, ByVal siz As Integer, ByVal pmod As Integer, ByVal final As Boolean) As Long
  Dim score&, bl&, rp&, rc&, c%, r%, m%, ix%, i%, w%
  Dim warr() As Byte
  Dim cols() As Long
  
  ReDim warr(siz * 24)
  For r = 0 To siz - 1
    m = 1
    ix = 24 * r
    warr(ix) = parr(1, ix)
    For c = 0 To siz - 1
      If (parr(0, ix) And m) = 0 Then ' nemaskovany
        Select Case pmod
         Case 0: i = (c + r) Mod 2
         Case 1: i = r Mod 2
         Case 2: i = c Mod 3
         Case 3: i = (c + r) Mod 3
         Case 4: i = (Int(r / 2) + Int(c / 3)) Mod 2
         Case 5: i = (c * r) Mod 2 + (c * r) Mod 3
         Case 6: i = ((c * r) Mod 2 + (c * r) Mod 3) Mod 2
         Case 7: i = ((c + r) Mod 2 + (c * r) Mod 3) Mod 2
        End Select
        If i = 0 Then warr(ix) = warr(ix) Xor m
      End If
      If m = 128 Then
        m = 1
        If final Then parr(1, ix) = warr(ix)
        ix = ix + 1
        warr(ix) = parr(1, ix)
      Else
        m = m * 2
      End If
    Next c
    If m <> 128 And final Then parr(1, ix) = warr(ix)
  Next r
  If final Then
    qr_xormask = 0
    Exit Function
  End If
 ' score computing
 ' a) adjacent modules colors in row or column 5+i mods = 3 + i penatly
 ' b) block same color MxN = 3*(M-1)*(N-1) penalty OR every 2x2 block penalty + 3
 ' c) 4:1:1:3:1:1 or 1:1:3:1:1:4 in row or column = 40 penalty rmks: 00001011101 or 10111010000 = &H05D or &H5D0
 ' d) black/light ratio : k=(abs(ratio% - 50) DIV 5) means 10*k penalty
  score = 0: bl = 0
'Dim s(4) as Integer
  ReDim cols(1, siz)
  rp = 0: rc = 0
  For r = 0 To siz - 1
    m = 1
    ix = 24 * r
    rp = 0: rc = 0
    For c = 0 To siz - 1
      rp = (rp And &H3FF) * 2 ' only last 12 bits
      cols(1, c) = (cols(1, c) And &H3FF) * 2
      If (warr(ix) And m) <> 0 Then
        If rc < 0 Then ' in row x whites
          If rc <= -5 Then score = score - 2 - rc  ': s(0) = s(0) - 2 - rc
          rc = 0
        End If
        rc = rc + 1 ' one more black
        If cols(0, c) < 0 Then ' color changed
          If cols(0, c) <= -5 Then score = score - 2 - cols(0, c) ': s(1) = s(1) - 2 - cols(0,c)
          cols(0, c) = 0
        End If
        cols(0, c) = cols(0, c) + 1 ' one more black
        rp = rp Or 1
        cols(1, c) = cols(1, c) Or 1
        bl = bl + 1 ' balck modules count
      Else
        If rc > 0 Then ' in row x black
          If rc >= 5 Then score = score - 2 + rc ': s(0) = s(0) - 2 + rc
          rc = 0
        End If
        rc = rc - 1 ' one more white
        If cols(0, c) > 0 Then ' color changed
          If cols(0, c) >= 5 Then score = score - 2 + cols(0, c) ': s(1) = s(1) - 2 + cols(0,c)
          cols(0, c) = 0
        End If
        cols(0, c) = cols(0, c) - 1 ' one more white
      End If
      If c > 0 And r > 0 Then ' penalty block 2x2
        i = rp And 3 ' current row pair
        If (cols(1, c - 1) And 3) >= 2 Then i = i + 8
        If (cols(1, c) And 3) >= 2 Then i = i + 4
        If i = 0 Or i = 15 Then
          score = score + 3 ': s(2) = s(2) + 3
          ' b) penalty na 2x2 block same color
        End If
      End If
      If c >= 10 And (rp = &H5D Or rp = &H5D0) Then  ' penalty pattern c in row
        score = score + 40 ': s(3) = s(3) + 40
      End If
      If r >= 10 And (cols(1, c) = &H5D Or cols(1, c) = &H5D0) Then ' penalty pattern c in column
        score = score + 40 ': s(3) = s(3) + 40
      End If
      ' next mask / byte
      If m = 128 Then
        m = 1
        ix = ix + 1
      Else
        m = m * 2
      End If
    Next
    If rc <= -5 Then score = score - 2 - rc ': s(0) = s(0) - 2 - rc
    If rc >= 5 Then score = score - 2 + rc ': s(0) = s(0) - 2 + rc
  Next
  For c = 0 To siz - 1 ' after last row count column blocks
    If cols(0, c) <= -5 Then score = score - 2 - cols(0, c) ': s(1) = s(1) - 2 - cols(0,c)
    If cols(0, c) >= 5 Then score = score - 2 + cols(0, c) ': s(1) = s(1) - 2 + cols(0,c)
  Next
  bl = Int(Abs((bl * 100&) / (siz * siz) - 50&) / 5) * 10
'MsgBox "mask:" + pmod + " " + s(0) + "+" + s(1) + "+" + s(2) + "+" + s(3) + "+" + bl
  qr_xormask = score + bl
End Function

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 ' somehow counts number of characters that could be encoded in a particular mode. Careful  -not overlap-free as long as several options to encode certain bytes are not ruled out!
  Dim ecx_pos(3) As Integer ' stores position where the characters that could be encoded in a particular mode start.
  Dim ecx_poc(3) As Integer ' seems to store how many substrings will be encoded in a given mode (1=numeric, 2=alnum, 3=byte)
  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) - first character in THIS row (somehow I used to think this contained "last character in previous row", but I think now that this was a mistake
  ' 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 wasfixed 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
  Dim current_mode ' ECI mode that current substring will be encoded in
  
  
  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 = 3
  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 constQR_AlNum)
        m = 1
        k = InStr(constQR_AlNum, 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) ' starting position where the string to be encoded as alnum starts
          eb(ebcnt, 3) = ecx_cnt(2) - ecx_cnt(1) ' number of characters to be encoded as alnum (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
  ' **** Since the code above is known to be buggy, but difficult
  ' **** to understand, add a "safety net" here doing some
  ' **** plausibility checks and trying to fix known error that
  ' **** might have been made above
  ' **1) Check that eb() rows cover the full string (i.e. last eb row is not missing)
  If (eb(ebcnt, 2) + eb(ebcnt, 3) < (Len(ptext) + 1)) Then
    ' oops, eb() does not cover full text. Lets hope the code above just forgot to add the last row
    If (ecx_pos(1) = eb(ebcnt, 2) + eb(ebcnt, 3)) Then ' This is a quick fix. Not well tested.
        current_mode = 1
    Else
        If (ecx_pos(2) = eb(ebcnt, 2) + eb(ebcnt, 3)) Then ' This is only a guess. Not tested at all. Sorry ;-)
            current_mode = 2
        Else
            current_mode = 3
        End If
    End If
    ebcnt = ebcnt + 1
    eb(ebcnt, 1) = current_mode
    eb(ebcnt, 2) = ecx_pos(current_mode)
    eb(ebcnt, 3) = ecx_cnt(current_mode)
    ecx_poc(current_mode) = ecx_poc(current_mode) + 1
  End If
  ' **2) Check that eb() rows are non-overlapping
  For j = 1 To ebcnt
  
     Debug.Print (j & ". (" & Mid("NAB", eb(j, 1), 1) & "): '" & Replace(Mid(ptext, eb(j, 2), eb(j, 3)), Chr(10), "\n") & "'")
  Next j
  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:")
        For j = 1 To ebcnt
            If i = j Then
                Debug.Print (eb(j, 1) & ": " & eb(j, 2) & " ... " & eb(j, 2) + eb(j, 3)) & " :-("
            Else
                Debug.Print (eb(j, 1) & ": " & eb(j, 2) & " ... " & eb(j, 2) + eb(j, 3))
            End If
        Next j
        ' 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
                Debug.Print ("... this should be fixed now::")
                For j = 1 To ebcnt
                    Debug.Print (j & ". (" & eb(j, 1) & "): " & eb(j, 2) & " ... " & eb(j, 2) + eb(j, 3))
                Next j
                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
  'Debug.Print ("ebcnt=" & ebcnt) ' ebcnt now has its final value
  ' Calculate how many bits the message has in total?
  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(constQR_AlNum, 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




Sub Test_RenderQRCode()
    'Call RenderQRCode(Application.ActiveSheet.Name, "A2", "Hello World", "mode=M", False)
End Sub




Sub DrawQRCode(strTexto As String, strReport As String, strControl As String, Optional xNam As String)

 Dim repReport As Report, ctlControl As Control
 Dim OffSetX As Integer, OffSetY As Integer, intAncho As Integer
 Dim Y As Integer, m As Integer, dm As Integer, a As Integer, xAddr As String
 Dim b%, n%, w%, p$, s$, h%, g%, X%

Set repReport = Reports(strReport)
Set ctlControl = repReport(strControl)

OffSetX = ctlControl.Left / 8
OffSetY = ctlControl.Top / 8
intAncho = ctlControl.Width / 180


 s = "BC" & xAddr & "#GR"
' m = intAncho  '2.5
 p = Trim(strTexto)
 b = Len(p)
Select Case b
    Case 399
        intAncho = ctlControl.Width / 300
    Case 143
        intAncho = ctlControl.Width / 180
    Case Else
        intAncho = ctlControl.Width / 300
End Select
m = intAncho
 dm = m * 2#
 a = 0#

 
 On Error Resume Next

 X = 0# + OffSetX
 Y = 0# + OffSetY

 g = 0
 For n = 1 To b
   w = AscL(Mid(p, n, 1)) Mod 256
   If w = 10 Then
     Y = Y + dm
     X = 0# + OffSetX
   ElseIf (w >= 97 And w <= 112) Then
     w = w - 97

     Select Case w
       Case 1: Call DibujarRectanguloEnInforme(strReport, X, Y, m, m): GoSub fmtxshape
       Case 2: Call DibujarRectanguloEnInforme(strReport, X + m, Y, m, m): GoSub fmtxshape
       Case 3: Call DibujarRectanguloEnInforme(strReport, X, Y, dm, m): GoSub fmtxshape
       Case 4: Call DibujarRectanguloEnInforme(strReport, X, Y + m, m, m): GoSub fmtxshape
       Case 5: Call DibujarRectanguloEnInforme(strReport, X, Y, m, dm): GoSub fmtxshape
       Case 6: Call DibujarRectanguloEnInforme(strReport, X + m, Y, m, m): GoSub fmtxshape
               Call DibujarRectanguloEnInforme(strReport, X, Y + m, m, m): GoSub fmtxshape
       Case 7: Call DibujarRectanguloEnInforme(strReport, X, Y, dm, m): GoSub fmtxshape
               Call DibujarRectanguloEnInforme(strReport, X, Y + m, m, m): GoSub fmtxshape
       Case 8: Call DibujarRectanguloEnInforme(strReport, X + m, Y + m, m, m): GoSub fmtxshape
       Case 9: Call DibujarRectanguloEnInforme(strReport, X, Y, m, m): GoSub fmtxshape
               Call DibujarRectanguloEnInforme(strReport, X + m, Y + m, m, m): GoSub fmtxshape
       Case 10: Call DibujarRectanguloEnInforme(strReport, X + m, Y, m, dm): GoSub fmtxshape
       Case 11: Call DibujarRectanguloEnInforme(strReport, X, Y, dm, m): GoSub fmtxshape
                Call DibujarRectanguloEnInforme(strReport, X + m, Y + m, m, m): GoSub fmtxshape
       Case 12: Call DibujarRectanguloEnInforme(strReport, X, Y + m, dm, m): GoSub fmtxshape
       Case 13: Call DibujarRectanguloEnInforme(strReport, X, Y, m, m): GoSub fmtxshape
                Call DibujarRectanguloEnInforme(strReport, X, Y + m, dm, m): GoSub fmtxshape
       Case 14: Call DibujarRectanguloEnInforme(strReport, X + m, Y, m, m): GoSub fmtxshape
                Call DibujarRectanguloEnInforme(strReport, X, Y + m, dm, m): GoSub fmtxshape
       Case 15: Call DibujarRectanguloEnInforme(strReport, X, Y, dm, dm): GoSub fmtxshape
     End Select

     X = X + dm
   End If
 Next n
 On Error Resume Next
 'Set xShape = xSheet.Shapes(s)
 On Error GoTo 0

 Exit Sub
 
fmtxshape:
  g = g + 1
  Return

End Sub