Tus Funciones Favoritas & Aportaciones & Artículos

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