VBE stops with no error working with shapes QR codes

[HotRhodium]

Hey guys I have a problem I was hoping one of you might be able to add some insight to. I wanted to make QR codes through VBA (able to work with all versions of excel) and I figured it would be a lot of work learning Reed Solomon and all the rest but I was determined to do it. While researching how to do this I found out that it had already been done and downloaded the code to Barcody PS works very well.

I am an advanced VBA programmer but this stuff is on another level. The main problem I am having is that this program makes a shape for every pixel in the QR code (WOW). The box itself lags moving it around. Now I need to put 20 + QR codes in a sheet so no good. If the box is copied and pasted as a single picture no problems and no lag. Processing the data including choosing the optimal mask and applying it and all of the Reed Solomon stuff happens in an instant not surprising as QR was designed to be fast to make and read.

My solution is to make a sheet and color cells and copy the range then paste as picture. I believe this would be much faster as you can see all the work that will be avoided when you look through the code not to mention I will only have one shape per QR as a result.

So now I am trying to color the cells but as soon as I try to do anything to any cells in the code the VBA editor stops. No error message or even the dreaded cannot enter break mode message. The code was written to use errors to perform some checks and I have removed them all and replaced them with Boolean functions that check for shapes sheets etc. and perform the same functions without the intentional errors. I have tried both break on all errors and break on unhandled errors to no avail.

The code stops with a partly drawn QR code and even functions like MyQRSheet.Cells(1,1) = "a" will not work! Is this an Option setting or something to do with the fact that vba is working with shapes and I am asking it to work with cells in between working with shapes? I haven't really seen this before sorry for the long question. Here is the Sub that is causing this problem and the lines are commented out that cause the problem. They are these lines and yes I know they are not done im just trying to get anything on paper.

MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)

I will post the rest of the code if anyone wants to see.

Sub bc_2Dms(xBC As String, Optional xNam As String)
 Dim xShape As Shape, xBkgr As Shape
 Dim xSheet As Worksheet
 Dim xRange As Range, xCell As Range
 Dim xAddr As String
 Dim xPosOldX As Double, xPosOldY As Double
 Dim xSizeOldW As Double, xSizeOldH As Double
 Dim x, y, m, dm, a As Double
 Dim b%, n%, w%, p$, s$, h%, g%
 Dim XOff As Integer, YOff As Integer
 Dim MyQRSheet As Worksheet
 Set MyQRSheet = ThisWorkbook.Worksheets("QRSheet")
 If TypeName(Application.Caller) = "Range" Then
   Set xSheet = Application.Caller.Worksheet
   Set xRange = Application.Caller
   xAddr = xRange.Address
   xPosOldX = xRange.Left
   xPosOldY = xRange.Top
 Else
   Set xSheet = Worksheets(1)
   If IsMissing(xNam) Then
     xAddr = "QR"
   Else
     xAddr = xNam
   End If
 End If
 xSizeOldW = 0
 xSizeOldH = 0
 s = "BC" & xAddr & "#GR"
 x = 0#
 y = 0#
 m = 2.5
 dm = m * 2#
 a = 0#
 p = Trim(xBC)
 b = Len(p)
 For n = 1 To b
   w = AscL(Mid(p, n, 1)) Mod 256
   If (w >= 97 And w <= 112) Then
     a = a + dm
   ElseIf w = 10 Or n = b Then
     If x < a Then x = a
     y = y + dm
     a = 0#
   End If
 Next n
 If x <= 0# Then GoTo 1 '''Here are problems!!
 If CheckForShape(xSheet, s) Then
  Set xShape = xSheet.Shapes(s)
 Else
  Set xShape = Nothing
 End If
 If Not (xShape Is Nothing) Then
   xPosOldX = xShape.Left
   xPosOldY = xShape.Top
   xSizeOldW = xShape.Width
   xSizeOldH = xShape.Height
   xShape.Delete
 End If
  If CheckForShape(xSheet, "BC" & xAddr & "#BK") Then
  Set xShape = xSheet.Shapes("BC" & xAddr & "#BK")
 Else
  Set xShape = Nothing
 End If
 Set xBkgr = xSheet.Shapes.AddShape(msoShapeRectangle, 0, 0, x, y)
 xBkgr.Line.Visible = msoFalse
 xBkgr.Line.Weight = 0#
 xBkgr.Line.ForeColor.RGB = RGB(255, 255, 255)
 xBkgr.Fill.Solid
 xBkgr.Fill.ForeColor.RGB = RGB(255, 255, 255)
 xBkgr.Name = "BC" & xAddr & "#BK"
 Set xShape = Nothing
 x = 0#
 y = 0#
 g = 0
 XOff = 2
 YOff = 2
 For n = 1 To b
   w = AscL(Mid(p, n, 1)) Mod 256
   If w = 10 Then
     y = y + dm
     x = 0#
   ElseIf (w >= 97 And w <= 112) Then
     w = w - 97
     With xSheet.Shapes
       Select Case w
         Case 1: Set xShape = .AddShape(msoShapeRectangle, x, y, m, m): GoSub fmtxshape
                 'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 2: Set xShape = .AddShape(msoShapeRectangle, x + m, y, m, m): GoSub fmtxshape
                 'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 3: Set xShape = .AddShape(msoShapeRectangle, x, y, dm, m): GoSub fmtxshape
                 'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 4: Set xShape = .AddShape(msoShapeRectangle, x, y + m, m, m): GoSub fmtxshape
                 'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 5: Set xShape = .AddShape(msoShapeRectangle, x, y, m, dm): GoSub fmtxshape
                 'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 6: Set xShape = .AddShape(msoShapeRectangle, x + m, y, m, m): GoSub fmtxshape
                 'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
                 Set xShape = .AddShape(msoShapeRectangle, x, y + m, m, m): GoSub fmtxshape
                 'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 7: Set xShape = .AddShape(msoShapeRectangle, x, y, dm, m): GoSub fmtxshape
                 'MyQRSheet.Cells(x + XOff, y + YOff).Interior.ColorIndex = 1
                 Set xShape = .AddShape(msoShapeRectangle, x, y + m, m, m): GoSub fmtxshape
                 'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 8: Set xShape = .AddShape(msoShapeRectangle, x + m, y + m, m, m): GoSub fmtxshape
                 'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 9: Set xShape = .AddShape(msoShapeRectangle, x, y, m, m): GoSub fmtxshape
                 'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
                 Set xShape = .AddShape(msoShapeRectangle, x + m, y + m, m, m): GoSub fmtxshape
                 'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 10: Set xShape = .AddShape(msoShapeRectangle, x + m, y, m, dm): GoSub fmtxshape
                  'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 11: Set xShape = .AddShape(msoShapeRectangle, x, y, dm, m): GoSub fmtxshape
                  'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
                  Set xShape = .AddShape(msoShapeRectangle, x + m, y + m, m, m): GoSub fmtxshape
                  'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 12: Set xShape = .AddShape(msoShapeRectangle, x, y + m, dm, m): GoSub fmtxshape
                  'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 13: Set xShape = .AddShape(msoShapeRectangle, x, y, m, m): GoSub fmtxshape
                  'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
                  Set xShape = .AddShape(msoShapeRectangle, x, y + m, dm, m): GoSub fmtxshape
                  'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 14: Set xShape = .AddShape(msoShapeRectangle, x + m, y, m, m): GoSub fmtxshape
                  'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
                  Set xShape = .AddShape(msoShapeRectangle, x, y + m, dm, m): GoSub fmtxshape
                  'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 15: Set xShape = .AddShape(msoShapeRectangle, x, y, dm, dm): GoSub fmtxshape
                  'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
       End Select
     End With
     x = x + dm
   End If
 Next n
 If CheckForShape(xSheet, s) Then
  Set xShape = xSheet.Shapes(s)
 Else
  Set xShape = Nothing
 End If
 If Not (xShape Is Nothing) Then
   xShape.Left = xPosOldX
   xShape.Top = xPosOldY
   If xSizeOldW > 0 Then
     xShape.Width = xSizeOldW
     xShape.Height = xSizeOldH
   End If
 Else
   If Not (xBkgr Is Nothing) Then xBkgr.Delete
 End If
 GoTo 1
fmtxshape:
  xShape.Line.Visible = msoFalse 'msoFalse'Changed
  xShape.Line.Weight = 0#
  xShape.Fill.Solid
  xShape.Fill.ForeColor.RGB = RGB(0, 0, 0)
  g = g + 1
  xShape.Name = "BC" & xAddr & "#BR" & g
  If g = 1 Then
    xSheet.Shapes.Range(Array(xBkgr.Name, xShape.Name)).Group.Name = s
  Else
    xSheet.Shapes.Range(Array(s, xShape.Name)).Group.Name = s
  End If
  Return
1
End Sub

 

[MARK858]

On my phone at the moment so can't work though the rest of the code (and I can't imagine it is causing your issues) but in VBA only a in the line below is a double (if that is what is intended), the others are all Variants as they have to be explicitly declared in VBA.

  Dim x, y, m, dm, a As Double

 

[HotRhodium]

Thank you for the note. I have not even started optimizing this sub yet and because I will not be working with shapes in the same way I believe most of it will go in the trash. All I want to do now is figure out how it works. I believe w is representing one of 15 common shapes combining pixels together (apparently the author recognized the large number of shapes as a problem before I did and tried to minimize it hence the w and case situation). I actually spent an hour or so on Google translating the notes from Russian to get this far very clever code.

These are kind of side issues I can't figure out why the code ends without raising an error. This is the entire (heavily modified) module. I just want to give some context also give credit to the author. If anyone wants a link to it unmodified just let me know ill post it as well

Option Explicit

Rem  *****  BASIC  *****
Rem This software is distributd under The MIT License (MIT)
Rem Copyright © 2013 Madeta a.s. Jiri Gabriel
Rem Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
Rem The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
Rem THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

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

Dim IsMs As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'     MS: EncodeBarcode(shelf("SHEET");shelf("ADDRESS");A2;0)                                      '
'      Use: EncodeBarcode(CELL("SHEET");CELL("ADDRESS");A2;0)                                      '
'                                                       /  |                                       '
'                               Content code (string) -'    `--- Parameters (depending on the code)'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function EncodeBarcode(code As String, params%) As String
  Dim s As String
  Dim MyShape As Shape

  If VarType(Asc("A")) = 2 Then
   IsMs = True
  Else
   IsMs = False
  End If
  s = "mode=" & Mid("MLQH", (params Mod 4) + 1, 1)
  s = qr_gen(code, s)
  If IsMs Then
    Call bc_2Dms(s)
  Else
    'Call bc_2D(ShIx, xAddr, s)
  End If
End Function
Function AscL(s As String) As Long
  If IsMs Then AscL = VBA.AscW(s) Else AscL = VBA.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
    ' 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
      Loop
    Next
GoTo 1
rsprod:
    rp = 0
    If pa > 0 And pb > 0 Then rp = poly((0& + poly(256 + pa) + poly(256 + pb)) Mod 255&)
    Return
1
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 GoTo 1
    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"
    GoTo 1
  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
1
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
    GoTo 1
  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
1
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 GoTo 1
  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
    GoTo 1
  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
1
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 GoTo 1
  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
1
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 GoTo 1
  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
1
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)
  ' Fill in the fields Parr (Piz x 24 bytes) of the field pdlen pb = number dbytes, pblocks = block ptlen total
  ' the logic of qr code - with interlacing
  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 ' they are great as well datablock
  vsb = pblocks - (pdlen Mod pblocks) ' the smaller datablock is?
  
  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
  GoTo 1
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 ' Data 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
1
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 ' undisguised
        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
    GoTo 1
  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
1
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
  Dim ecx_pos(3) As Integer
  Dim ecx_poc(3) As Integer
  Dim eb(20, 4) As Integer
  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"
    GoTo 1
  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
    If i > Len(ptext) Then
      k = -5
    Else
      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
        m = 1
        k = InStr(qralnum, Mid(ptext, i, 1)) - 1
      End If
    End If
    If (k < 0) Then ' bude byte nebo konec
      If ecx_cnt(1) >= 9 Or (k = -5 And ecx_cnt(1) = ecx_cnt(3)) Then ' 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) ' 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) ' 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) ' 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) ' 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 ' Muzeme alnum
      If (k >= 10 And ecx_cnt(1) >= 12) Then ' Az dosud bylo mozno num
        If (ecx_cnt(2) - ecx_cnt(1)) >= 8 Or (ecx_cnt(3) = ecx_cnt(2)) Then ' Je tam i alnum ktery stoji za to
          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 ' vse zpracovano
        ElseIf (ecx_cnt(3) > ecx_cnt(1)) Then ' Pred Num je byte
          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
        eb(ebcnt, 1) = 1         ' Typ numerix
        eb(ebcnt, 2) = ecx_pos(1)
        eb(ebcnt, 3) = ecx_cnt(1) ' 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
      If ecx_cnt(2) = 0 Then ecx_pos(2) = i
      ecx_cnt(2) = ecx_cnt(2) + 1
    Else ' mozno alnum
      ecx_cnt(2) = 0
    End If
    If k >= 0 And k < 10 Then ' 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 ' Uz by se mi tri dalsi bloky stejne nevesli
      ecx_cnt(1) = 0
      ecx_cnt(2) = 0
    End If
'MsgBox "Znak:" & 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
  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
'  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"
    GoTo 1
  End If
  siz = qrp(2)
'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)
  ' mode indicator (1=num,2=AlNum,4=Byte,8=kanji,ECI=7)
  '      mode: Byte Alhanum  Numeric  Kanji
  ' ver 1..9 :  8      9       11       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)
      Case 2: c = IIf(qrp(1) < 10, 9, IIf(qrp(1) < 27, 11, 13)): k = 2 * (2 ^ c) + eb(i, 3)
      Case 3: c = IIf(qrp(1) < 10, 8, 16): k = 4 * (2 ^ c) + eb(i, 3)
    End Select
    Call bb_putbits(encoded1, encix1, k, c + 4)
    j = 0
    m = eb(i, 2)
    r = 0
    While j < eb(i, 3)
      k = AscL(Mid(ptext, m, 1))
      m = m + 1
      If eb(i, 1) = 1 Then
        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
        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
        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"
    GoTo 1
  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 '''''''''These get removed
      If i < j Or j = -1 Then j = i: s = mask
    Next mask
    mask = s
    'MsgBox "best is " & mask & " with score " & j '''''''''These get removed
  End If
  ''                                                |  '
  ''                                                |  '
  ''All speed related issues are below this point  \|/ '
  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
  GoTo 1
addmm:
  k = ecl * 8 + mask
  ' poly: 101 0011 0111
  Call qr_bch_calc(k, &H537)
'MsgBox "mask :" & VBA.Hex(k, 3) & " " & Hex(k Xor &H5412, 3) '''''''''These get removed
  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) ' Vertically FMT info UL - apartments 0..5 SYNC 6.7 .... 8..14 down
    x = qr_bit(qrarr, -1, 8, c, ch) ' horizontally from the back 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 ' Skip to main horizontal sync
    If i = 8 Then c = c - 1 ' Skip to main vertical sync
  Next
  Return
1
End Function  ' qr_gen
Sub bc_2D(ShIx As Integer, xAddr As String, xBC As String)
  Dim xPage As Object
  Dim xShape As Object
  Dim xDoc As Object
  Dim xView As Object
  Dim xProv As Object
  Dim xSheet As Object
  Dim xRange As Object
  Dim xCell As Object
  Dim xPos As New com.sun.star.awt.Point
  Dim xPosOld As New com.sun.star.awt.Point
  Dim xSize As New com.sun.star.awt.Size
  Dim xSizeOld As New com.sun.star.awt.Size
  Dim xGrp As Object
  Dim xSolid As Long
  Dim x&, y&, n%, w%, s$, p$, m&, dm&, a&, b%
  xDoc = ThisComponent
  'On Error GoTo e2derr
  xView = ThisComponent.getCurrentController()
  xSheet = xDoc.Sheets.getByIndex(ShIx - 1)
  xCell = xSheet.getCellRangeByName(xAddr)
  xPage = xSheet.getDrawPage()
  On Error GoTo 0
  m = 60 ' block size
  xSolid = 1 ' com.sun.star.drawing.FillStyle.SOLID = 1
  xPosOld.x = xCell.Position.x
  xPosOld.y = xCell.Position.y
  xSizeOld.Width = 0
  xSizeOld.Height = 0
  s = "BC" & xAddr & "#GR"
  If xPage.hasElements() Then
    For n = (xPage.getCount() - 1) To 0 Step -1
      xShape = xPage.getByIndex(n)
      If xShape.Name = s Then
        xPosOld.x = xShape.Position.x
        xPosOld.y = xShape.Position.y
        xSizeOld.Width = xShape.Size.Width
        xSizeOld.Height = xShape.Size.Height
        xPage.Remove (xShape)
      End If
    Next n
  End If
  x = 0
  y = 0
  a = 0
  dm = m * 2&
  n = 1
  p = Trim(xBC)
  b = Len(p)
  'bbccddeeffgghhiijjkkllmmnnoopp
  '^  ^^^. I .^I^ .^. I^I..I..III
  Do While n <= b
    w = AscL(Mid(p, n, 1)) Mod 256
    If w >= 97 And w <= 112 Then
      a = a + dm
    End If
    If w = 10 Or n = b Then
      y = y + dm
      If a > x Then x = a
      a = 0
    End If
    n = n + 1
  Loop
  If x = 0 Or y = 0 Then GoTo 1
  xGrp = xDoc.createInstance("com.sun.star.drawing.GroupShape")
  xGrp.Name = s
  xPage.Add (xGrp)
  xShape = xDoc.createInstance("com.sun.star.drawing.RectangleShape")
  xShape.LineWidth = 0
  xShape.LineStyle = com.sun.star.Drawing.LineStyle.NONE
  xShape.FillStyle = xSolid
  xShape.FillColor = RGB(255, 255, 255)
  xPos.x = 0
  xPos.y = 0
  xShape.Position = xPos
  xSize.Width = x
  xSize.Height = y
  xShape.Size = xSize
  xGrp.Add (xShape)
  x = 0
  y = 0
  a = 1
  For n = 1 To b
    w = AscL(Mid(p, n, 1)) Mod 256
    If w = 10 Then
      y = y + dm
      x = 0
    ElseIf (w >= 97 And w <= 112) Then
      w = w - 97
      xSize.Height = m: xSize.Width = m: xPos.x = x: xPos.y = y
      Select Case w
        Case 1: GoSub crrect
        Case 2: xPos.x = x + m: GoSub crrect
        Case 3: xSize.Width = dm: GoSub crrect
        Case 4: xPos.y = y + m: GoSub crrect
        Case 5: xSize.Height = dm: GoSub crrect
        Case 6: xPos.x = x + m: GoSub crrect: xPos.x = x: xPos.y = y + m: GoSub crrect
        Case 7: xSize.Width = dm: GoSub crrect: xSize.Width = m: xPos.y = y + m: GoSub crrect
        Case 8: xPos.y = y + m: xPos.x = x + m: GoSub crrect
        Case 9: GoSub crrect: xPos.y = y + m: xPos.x = x + m: GoSub crrect
        Case 10: xPos.x = x + m: xSize.Height = dm: GoSub crrect
        Case 11: GoSub crrect: xPos.x = x + m: xSize.Height = dm: GoSub crrect
        Case 12: xPos.y = y + m: xSize.Width = dm: GoSub crrect
        Case 13: GoSub crrect: xPos.y = y + m: xSize.Width = dm: GoSub crrect
        Case 14: xPos.x = x + m: GoSub crrect: xPos.x = x: xPos.y = y + m: xSize.Width = dm: GoSub crrect
        Case 15: xSize.Width = dm: xSize.Height = dm: GoSub crrect
      End Select
      x = x + dm
    End If
  Next n
  xGrp.Visible = True
  xGrp.Position = xPosOld
  If xSizeOld.Width > 0 Then xGrp.Size = xSizeOld
  Erase xPos
  Erase xSize
  Erase xPosOld
  Erase xSizeOld
  GoTo 1
crrect:
  xShape = xDoc.createInstance("com.sun.star.drawing.RectangleShape")
  xShape.LineWidth = 0
  xShape.LineStyle = com.sun.star.Drawing.LineStyle.NONE
  xShape.LineColor = RGB(255, 255, 255)
  xShape.FillStyle = xSolid
  xShape.FillColor = RGB(0, 0, 0)
  xShape.Position = xPos
  xShape.Size = xSize
  xShape.Name = xAddr & "#BR" & a
  xGrp.Add (xShape)
  a = a + 1
  Return
e2derr:
1
  On Error GoTo 0
End Sub
Sub bc_2Dms(xBC As String, Optional xNam As String)
 Dim xShape As Shape, xBkgr As Shape
 Dim xSheet As Worksheet
 Dim xRange As Range, xCell As Range
 Dim xAddr As String
 Dim xPosOldX As Double, xPosOldY As Double
 Dim xSizeOldW As Double, xSizeOldH As Double
 Dim x, y, m, dm, a As Double
 Dim b%, n%, w%, p$, s$, h%, g%
 Dim XOff As Integer, YOff As Integer
 Dim MyQRSheet As Worksheet
 Set MyQRSheet = ThisWorkbook.Worksheets("QRSheet")
 If TypeName(Application.Caller) = "Range" Then
   Set xSheet = Application.Caller.Worksheet
   Set xRange = Application.Caller
   xAddr = xRange.Address
   xPosOldX = xRange.Left
   xPosOldY = xRange.Top
 Else
   Set xSheet = Worksheets(1)
   If IsMissing(xNam) Then
     xAddr = "QR"
   Else
     xAddr = xNam
   End If
 End If
 xSizeOldW = 0
 xSizeOldH = 0
 s = "BC" & xAddr & "#GR"
 x = 0#
 y = 0#
 m = 2.5
 dm = m * 2#
 a = 0#
 p = Trim(xBC)
 b = Len(p)
 For n = 1 To b
   w = AscL(Mid(p, n, 1)) Mod 256
   If (w >= 97 And w <= 112) Then
     a = a + dm
   ElseIf w = 10 Or n = b Then
     If x < a Then x = a
     y = y + dm
     a = 0#
   End If
 Next n
 If x <= 0# Then GoTo 1 '''Here are problems!!
 If CheckForShape(xSheet, s) Then
  Set xShape = xSheet.Shapes(s)
 Else
  Set xShape = Nothing
 End If
 If Not (xShape Is Nothing) Then
   xPosOldX = xShape.Left
   xPosOldY = xShape.Top
   xSizeOldW = xShape.Width
   xSizeOldH = xShape.Height
   xShape.Delete
 End If
  If CheckForShape(xSheet, "BC" & xAddr & "#BK") Then
  Set xShape = xSheet.Shapes("BC" & xAddr & "#BK")
 Else
  Set xShape = Nothing
 End If
 Set xBkgr = xSheet.Shapes.AddShape(msoShapeRectangle, 0, 0, x, y)
 xBkgr.Line.Visible = msoFalse
 xBkgr.Line.Weight = 0#
 xBkgr.Line.ForeColor.RGB = RGB(255, 255, 255)
 xBkgr.Fill.Solid
 xBkgr.Fill.ForeColor.RGB = RGB(255, 255, 255)
 xBkgr.Name = "BC" & xAddr & "#BK"
 Set xShape = Nothing
 x = 0#
 y = 0#
 g = 0
 XOff = 2
 YOff = 2
 For n = 1 To b
   w = AscL(Mid(p, n, 1)) Mod 256
   If w = 10 Then
     y = y + dm
     x = 0#
   ElseIf (w >= 97 And w <= 112) Then
     w = w - 97
     With xSheet.Shapes
       Select Case w
         Case 1: Set xShape = .AddShape(msoShapeRectangle, x, y, m, m): GoSub fmtxshape
                 'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 2: Set xShape = .AddShape(msoShapeRectangle, x + m, y, m, m): GoSub fmtxshape
                 'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 3: Set xShape = .AddShape(msoShapeRectangle, x, y, dm, m): GoSub fmtxshape
                 'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 4: Set xShape = .AddShape(msoShapeRectangle, x, y + m, m, m): GoSub fmtxshape
                 'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 5: Set xShape = .AddShape(msoShapeRectangle, x, y, m, dm): GoSub fmtxshape
                 'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 6: Set xShape = .AddShape(msoShapeRectangle, x + m, y, m, m): GoSub fmtxshape
                 'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
                 Set xShape = .AddShape(msoShapeRectangle, x, y + m, m, m): GoSub fmtxshape
                 'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 7: Set xShape = .AddShape(msoShapeRectangle, x, y, dm, m): GoSub fmtxshape
                 'MyQRSheet.Cells(x + XOff, y + YOff).Interior.ColorIndex = 1
                 Set xShape = .AddShape(msoShapeRectangle, x, y + m, m, m): GoSub fmtxshape
                 'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 8: Set xShape = .AddShape(msoShapeRectangle, x + m, y + m, m, m): GoSub fmtxshape
                 'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 9: Set xShape = .AddShape(msoShapeRectangle, x, y, m, m): GoSub fmtxshape
                 'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
                 Set xShape = .AddShape(msoShapeRectangle, x + m, y + m, m, m): GoSub fmtxshape
                 'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 10: Set xShape = .AddShape(msoShapeRectangle, x + m, y, m, dm): GoSub fmtxshape
                  'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 11: Set xShape = .AddShape(msoShapeRectangle, x, y, dm, m): GoSub fmtxshape
                  'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
                  Set xShape = .AddShape(msoShapeRectangle, x + m, y + m, m, m): GoSub fmtxshape
                  'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 12: Set xShape = .AddShape(msoShapeRectangle, x, y + m, dm, m): GoSub fmtxshape
                  'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 13: Set xShape = .AddShape(msoShapeRectangle, x, y, m, m): GoSub fmtxshape
                  'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
                  Set xShape = .AddShape(msoShapeRectangle, x, y + m, dm, m): GoSub fmtxshape
                  'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 14: Set xShape = .AddShape(msoShapeRectangle, x + m, y, m, m): GoSub fmtxshape
                  'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
                  Set xShape = .AddShape(msoShapeRectangle, x, y + m, dm, m): GoSub fmtxshape
                  'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
         Case 15: Set xShape = .AddShape(msoShapeRectangle, x, y, dm, dm): GoSub fmtxshape
                  'MyQRSheet.Cells(x + XOff, y + YOff).Interior.Color = RGB(0, 0, 0)
       End Select
     End With
     x = x + dm
   End If
 Next n
 If CheckForShape(xSheet, s) Then
  Set xShape = xSheet.Shapes(s)
 Else
  Set xShape = Nothing
 End If
 If Not (xShape Is Nothing) Then
   xShape.Left = xPosOldX
   xShape.Top = xPosOldY
   If xSizeOldW > 0 Then
     xShape.Width = xSizeOldW
     xShape.Height = xSizeOldH
   End If
 Else
   If Not (xBkgr Is Nothing) Then xBkgr.Delete
 End If
 GoTo 1
fmtxshape:
  xShape.Line.Visible = msoFalse 'msoFalse'Changed
  xShape.Line.Weight = 0#
  xShape.Fill.Solid
  xShape.Fill.ForeColor.RGB = RGB(0, 0, 0)
  g = g + 1
  xShape.Name = "BC" & xAddr & "#BR" & g
  If g = 1 Then
    xSheet.Shapes.Range(Array(xBkgr.Name, xShape.Name)).Group.Name = s
  Else
    xSheet.Shapes.Range(Array(s, xShape.Name)).Group.Name = s
  End If
  Return
1
End Sub
Public Function CheckForShape(InputWS As Worksheet, InputName As String) As Boolean
Dim LoopShape As Shape
 For Each LoopShape In InputWS.Shapes
  If LoopShape.Name = InputName Then
   CheckForShape = True
   GoTo 1
  End If
 Next LoopShape
CheckForShape = False
1
End Function

 

[HotRhodium]

Ok so I think I have found the problem. I am using this as a UDF and once it is called as a UDF I cant change any cell values until it is over correct? So I called this from another function without the shapes but coloring cells instead and it runs in an instant.

Booooo not cool I am using excels dependency tree to figure out when the QR code needs to be updated and what values to input into it. No mater how I do this I will need a UDF to determine when to change it and what to change it to correct? and no mater how I do this if I use a UDF it wont work? Is there any way out of this sandbox like Application.Letmechangeothercells = True or something?

Thanks for the help guys but that is very frustrating please let me know if there is any way around this.