Módulo: modBcFunc
Option Compare Database
Option Explicit
Sub bb_putbits(ByRef parr As Variant, ByRef ppos As Integer, pa As Variant, ByVal plen As Integer)
Dim i As Integer, b As Integer, w As Long, l As Integer, j As Integer
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
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
Módulo: modFormFunc
Option Compare Database
Option Explicit
Public Enum enuERROR_CORRECTION
l '= "l"
m '= "m"
q '= "Q"
h '= "h"
End Enum
#If 1 = 2 Then
Dim l, m, q, h
#End If
Declare PtrSafe Sub wlib_AccColorDialog Lib "msaccess.exe" Alias "#53" (ByVal Hwnd As LongPtr, lngRGB As Long)
Function ColorPickerDialog() As Long
Dim lngColor As Long
wlib_AccColorDialog Screen.ActiveForm.Hwnd, lngColor
ColorPickerDialog = lngColor
End Function
Módulo: modGenera
Option Explicit
Public Const bcQR = 6 'QR Code
Public Function EncodeBarcode(TextControlName As Control, ReportControlName As Object, code As String, pBcType As Integer, _
Optional Mils As Long = 20, Optional DPI As Long = 300, Optional ApplyTilde As Integer = 0, Optional EncodingMode As Integer = 0, Optional preferredFormat As Integer = -1, Optional Orientation As Long = 0, _
Optional pGrafico As Integer = 1, Optional pParams As Integer = 0, Optional pZones As Integer = 2) 'As String
'@ Currency
'$ String
'# Double
'% Integer
'& Long
'! Single
Dim s As String, bcType As Integer, ModGrafico As Integer, params As Integer, zones As Integer
Dim oo As Object
zones = pZones
params = pParams
ModGrafico = pGrafico
bcType = pBcType
If bcType = 51 Then ' QRCode params: ECLevel 0=M 1=L 2=Q 3=H
s = "mode=" & Mid("MLQH", (params Mod 4) + 1, 1)
s = qr_gen(code, s)
Else
Exit Function
End If
If ModGrafico <> 0 Then
If bcType >= 50 Then
Call bc_2Dms(TextControlName, ReportControlName, s, , Mils, DPI, ApplyTilde, EncodingMode, preferredFormat, Orientation)
End If
EncodeBarcode = ""
Else
EncodeBarcode = s
End If
Exit Function
End Function
Function AscL(s As String) As Long
AscL = AscW(s)
End Function
Public Function wzGetFileToOpen(Optional ByVal Initial As String) As String
Dim wzhwndOwner As Long
Dim wzAppName As String
Dim wzDlgTitle As String
Dim wzOpenTitle As String
Dim wzFile As String
Dim wzInitialDir As String
Dim wzFilter As String
Dim wzFilterIndex As Long
Dim wzView As Long
Dim wzflags As Long
Dim wzfOpen As Boolean
Dim ret As Long
Dim fso As Object
If fso Is Nothing Then Set fso = CreateObject("Scripting.FileSystemObject")
If Trim(Initial) = "" Then
Initial = fso.GetParentFolderName(CurrentProject.Path)
End If
WizHook.Key = 51488399
wzhwndOwner = 0&
wzAppName = "Generador QR"
wzDlgTitle = "Abrir fichero"
wzOpenTitle = "Cargar Logo"
wzFile = String(255, Chr(0))
wzInitialDir = Initial
wzFilter = "Imagen " _
& "(*.jpg;*.png;*.bmp;*.gif)"
wzFilterIndex = 1
wzView = 1
wzflags = 64
wzfOpen = True
ret = WizHook.GetFileName(wzhwndOwner, _
wzAppName, wzDlgTitle, wzOpenTitle, wzFile, _
wzInitialDir, wzFilter, wzFilterIndex, _
wzView, wzflags, wzfOpen)
' Si no se ha pulsado el botón Cancelar (-302)
If ret <> -302 Then
wzGetFileToOpen = wzFile
End If
Set fso = Nothing
End Function
Módulo: modGraficos
Option Compare Database
Option Explicit
'-----------------------------------------------------------------------------------------------------------------------------------------------
' Fuente : https://access-global.net/vba-crea-codigos-qr-sin-conexion-a-internet/
'-----------------------------------------------------------------------------------------------------------------------------------------------
' Título : modGraficos
' Autor original : Alba Salvá
' Adaptado : desde lenguaje C por Alba Salvá
' Creado : 2010
' Propósito : generación de los gráficos
'-----------------------------------------------------------------------------------------------------------------------------------------------
Sub bc_2Dms(TextControlName As Control, ReportControlName As Object, _
xBC As String, Optional xNam As String, _
Optional Mils As Long = 40, Optional DPI As Long = 300, _
Optional ApplyTilde As Integer = 0, Optional EncodingMode As Integer = 0, _
Optional preferredFormat As Integer = -1, Optional Orientation As Long = 0)
Dim xAddr As String
Dim xPosOldX As Double, xPosOldY As Double
Dim xSizeOldW As Double, xSizeOldH As Double
Dim x As Long, y As Long, m As Integer, dm As Integer
Dim a As Double
Dim b As Integer, n As Integer, w As Integer, p As String, s As String, h As Integer, g As Integer
Dim maxX As Long, maxY As Long
Dim obPoint As clsPoint
Dim colPoints As Collection
Dim CurrentValue As Long
Dim WeightValue As Long
Dim Factor As Long
Dim XPixles As Long
Dim CanvasCurrentX As Long
Dim CanvasCurrentY As Long
Dim CanvasTop As Long
Dim CanvasHeight As Long
Dim CanvasWidth As Long
Dim j1 As Integer
Dim i1 As Integer
If IsMissing(xNam) Then
xAddr = "QR"
Else
xAddr = xNam
End If
xSizeOldW = 0
xSizeOldH = 0
x = 0#
y = 0#
'm = 2.5
m = 1
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 Exit Sub
On Error Resume Next
'***
' Aqui empieza el gráfico
'***
On Error GoTo 0
'Inicializamos variables
x = 0#
y = 0#
g = 0
If Not colPoints Is Nothing Then
Set colPoints = Nothing
End If
Set colPoints = New Collection
For n = 1 To b
w = AscL(Mid(p, n, 1)) Mod 256
If w = 10 Then
x = 0
y = y + 2
ElseIf (w >= 97 And w <= 112) Then
w = w - 97
Select Case w
Case 1:
'X-
'--
Set obPoint = New clsPoint
obPoint.x = x
obPoint.y = y
colPoints.Add obPoint
Case 2:
'-X
'--
Set obPoint = New clsPoint
obPoint.x = x + 1
obPoint.y = y
colPoints.Add obPoint
Case 3:
'XX
'--
Set obPoint = New clsPoint
obPoint.x = x
obPoint.y = y
colPoints.Add obPoint
Set obPoint = New clsPoint
obPoint.x = x + 1
obPoint.y = y
colPoints.Add obPoint
Case 4:
'--
'X-
Set obPoint = New clsPoint
obPoint.x = x
obPoint.y = y + 1
colPoints.Add obPoint
Case 5:
'X-
'X-
Set obPoint = New clsPoint
obPoint.x = x
obPoint.y = y
colPoints.Add obPoint
Set obPoint = New clsPoint
obPoint.x = x
obPoint.y = y + 1
colPoints.Add obPoint
Case 6:
'-X
'X-
Set obPoint = New clsPoint
obPoint.x = x + 1
obPoint.y = y
colPoints.Add obPoint
Set obPoint = New clsPoint
obPoint.x = x
obPoint.y = y + 1
colPoints.Add obPoint
Case 7:
'XX
'X-
Set obPoint = New clsPoint
obPoint.x = x
obPoint.y = y
colPoints.Add obPoint
Set obPoint = New clsPoint
obPoint.x = x + 1
obPoint.y = y
colPoints.Add obPoint
Set obPoint = New clsPoint
obPoint.x = x
obPoint.y = y + 1
colPoints.Add obPoint
Case 8:
'--
'-X
Set obPoint = New clsPoint
obPoint.x = x + 1
obPoint.y = y + 1
colPoints.Add obPoint
Case 9:
'X-
'-X
Set obPoint = New clsPoint
obPoint.x = x
obPoint.y = y
colPoints.Add obPoint
Set obPoint = New clsPoint
obPoint.x = x + 1
obPoint.y = y + 1
colPoints.Add obPoint
Case 10:
'-X
'-X
Set obPoint = New clsPoint
obPoint.x = x + 1
obPoint.y = y
colPoints.Add obPoint
Set obPoint = New clsPoint
obPoint.x = x + 1
obPoint.y = y + 1
colPoints.Add obPoint
Case 11:
'XX
'-X
Set obPoint = New clsPoint
obPoint.x = x
obPoint.y = y
colPoints.Add obPoint
Set obPoint = New clsPoint
obPoint.x = x + 1
obPoint.y = y
colPoints.Add obPoint
Set obPoint = New clsPoint
obPoint.x = x + 1
obPoint.y = y + 1
colPoints.Add obPoint
Case 12:
'--
'XX
Set obPoint = New clsPoint
obPoint.x = x
obPoint.y = y + 1
colPoints.Add obPoint
Set obPoint = New clsPoint
obPoint.x = x + 1
obPoint.y = y + 1
colPoints.Add obPoint
Case 13:
'X-
'XX
Set obPoint = New clsPoint
obPoint.x = x
obPoint.y = y
colPoints.Add obPoint
Set obPoint = New clsPoint
obPoint.x = x
obPoint.y = y + 1
colPoints.Add obPoint
Set obPoint = New clsPoint
obPoint.x = x + 1
obPoint.y = y + 1
colPoints.Add obPoint
Case 14:
'-X
'XX
Set obPoint = New clsPoint
obPoint.x = x + 1
obPoint.y = y
colPoints.Add obPoint
Set obPoint = New clsPoint
obPoint.x = x
obPoint.y = y + 1
colPoints.Add obPoint
Set obPoint = New clsPoint
obPoint.x = x + 1
obPoint.y = y + 1
colPoints.Add obPoint
Case 15:
'XX
'XX
Set obPoint = New clsPoint
obPoint.x = x
obPoint.y = y
colPoints.Add obPoint
Set obPoint = New clsPoint
obPoint.x = x + 1
obPoint.y = y
colPoints.Add obPoint
Set obPoint = New clsPoint
obPoint.x = x
obPoint.y = y + 1
colPoints.Add obPoint
Set obPoint = New clsPoint
obPoint.x = x + 1
obPoint.y = y + 1
colPoints.Add obPoint
End Select
x = x + 2
End If
Next n
For Each obPoint In colPoints
If maxX < obPoint.x Then maxX = obPoint.x
If maxY < obPoint.y Then maxY = obPoint.y
Next
ReDim resultBitmap(maxX, maxY)
For x = 0 To maxX
For y = 0 To maxY: resultBitmap(x, y) = 0: Next
Next
For Each obPoint In colPoints
resultBitmap(obPoint.x, obPoint.y) = 1
Next
If DPI < 301 And Mils < 8 Then Mils = 8
If DPI < 204 And Mils < 12 Then Mils = 12
CurrentValue = Mils * 1.44
WeightValue = CInt(1000 * (1000 / DPI))
Factor = (CurrentValue * 1000) Mod WeightValue
If Factor <> 0 Then
XPixles = CInt(CurrentValue + ((WeightValue - Factor) / 1000))
Else
XPixles = CInt(CurrentValue)
End If
CanvasCurrentX = TextControlName.Left
CanvasTop = TextControlName.Top
CanvasHeight = TextControlName.Height
CanvasCurrentY = CanvasTop
CanvasWidth = TextControlName.Width
TextControlName.Visible = False
XPixles = (CanvasWidth / maxX)
For j1 = 0 To maxY '- 1
If Orientation = 0 Then
CanvasCurrentX = TextControlName.Left
For i1 = 0 To maxX '- 1
If resultBitmap(i1, j1) = 0 Then
ReportControlName.Line (CanvasCurrentX, CanvasCurrentY)-Step(XPixles, -XPixles), 16777215, BF
Else
ReportControlName.Line (CanvasCurrentX, CanvasCurrentY)-Step(XPixles, -XPixles), 0, BF
End If
CanvasCurrentX = CanvasCurrentX + XPixles
Next i1
CanvasCurrentY = CanvasCurrentY + XPixles
End If
Next j1
On Error GoTo 0
lbFinally:
If Not colPoints Is Nothing Then
Set colPoints = Nothing
End If
End Sub
Módulo: modQR
Option Compare Database
Option Explicit
'-----------------------------------------------------------------------------------------------------------------------------------------------
' Fuente : https://access-global.net/vba-crea-codigos-qr-sin-conexion-a-internet/
'-----------------------------------------------------------------------------------------------------------------------------------------------
' Título : modQR
' Autor original : Alba Salvá
' Adaptado : desde lenguaje C por Alba Salvá
' Creado : 2010
' Propósito : generación de códigos QR
'-----------------------------------------------------------------------------------------------------------------------------------------------
Dim ruta As String
Function qr_gen(ptext As String, poptions As String) As String
Dim encoded1() As Byte ' byte mode (ASCII) -- max 3200 bytes
Dim encix1 As Integer
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 As String, mode As String, err As String
Dim ecl As Integer, r As Integer, c As Integer, mask As Integer, utf8 As Integer, ebcnt As Integer
Dim i As Long, j As Long, k As Long, m As Long
Dim ch As Integer, s As Integer, siz As Integer
Dim x As Boolean
Dim qrarr() As Byte 'Matriz final
Dim qrpos As Integer
Dim qrp(15) As Integer ' 1:version,2:size,3:ccs,4:ccb,5:totby,6-12:syncs(7),13-15:versinfo(3)
Dim qrsync1(1 To 8) As Byte
Dim qrsync2(1 To 5) As Byte
ascimatrix = ""
err = ""
mode = "M"
i = InStr(poptions, "mode=")
If i > 0 Then mode = Mid(poptions, i + 5, 1)
' M=0,L=1,H=2,Q=3
ecl = InStr("MLHQ", mode) - 1
If ecl < 0 Then mode = "M": ecl = 0
If ptext = "" Then
err = "Not data"
Exit Function
End If
For i = 1 To 3
ecx_pos(i) = 0
ecx_cnt(i) = 0
ecx_poc(i) = 0
Next i
ebcnt = 1
utf8 = 0
For i = 1 To Len(ptext) + 1
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
If ecx_cnt(1) >= 9 Or (k = -5 And ecx_cnt(1) = ecx_cnt(3)) Then
If (ecx_cnt(2) - ecx_cnt(1)) >= 8 Or (ecx_cnt(3) = ecx_cnt(2)) Then
If (ecx_cnt(3) > ecx_cnt(2)) Then
eb(ebcnt, 1) = 3
eb(ebcnt, 2) = ecx_pos(3)
eb(ebcnt, 3) = ecx_cnt(3) - ecx_cnt(2)
ebcnt = ebcnt + 1
ecx_poc(3) = ecx_poc(3) + 1
End If
eb(ebcnt, 1) = 2
eb(ebcnt, 2) = ecx_pos(2)
eb(ebcnt, 3) = ecx_cnt(2) - ecx_cnt(1)
ebcnt = ebcnt + 1
ecx_poc(2) = ecx_poc(2) + 1
ecx_cnt(2) = 0
ElseIf ecx_cnt(3) > ecx_cnt(1) Then
eb(ebcnt, 1) = 3
eb(ebcnt, 2) = ecx_pos(3)
eb(ebcnt, 3) = ecx_cnt(3) - ecx_cnt(1)
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
If (ecx_cnt(3) > ecx_cnt(2)) Then
eb(ebcnt, 1) = 3
eb(ebcnt, 2) = ecx_pos(3)
eb(ebcnt, 3) = ecx_cnt(3) - ecx_cnt(2)
ebcnt = ebcnt + 1
ecx_poc(3) = ecx_poc(3) + 1
End If
eb(ebcnt, 1) = 2
eb(ebcnt, 2) = ecx_pos(2)
eb(ebcnt, 3) = ecx_cnt(2)
ebcnt = ebcnt + 1
ecx_poc(2) = ecx_poc(2) + 1
ecx_cnt(3) = 0
ecx_cnt(2) = 0
ElseIf (k = -5 And ecx_cnt(3) > 0) Then
eb(ebcnt, 1) = 3
eb(ebcnt, 2) = ecx_pos(3)
eb(ebcnt, 3) = ecx_cnt(3)
ebcnt = ebcnt + 1
ecx_poc(3) = ecx_poc(3) + 1
End If
End If
If k = -5 Then Exit For
If (k >= 0) Then
If (k >= 10 And ecx_cnt(1) >= 12) Then
If (ecx_cnt(2) - ecx_cnt(1)) >= 8 Or (ecx_cnt(3) = ecx_cnt(2)) Then
If (ecx_cnt(3) > ecx_cnt(2)) Then
eb(ebcnt, 1) = 3
eb(ebcnt, 2) = ecx_pos(3)
eb(ebcnt, 3) = ecx_cnt(3) - ecx_cnt(2)
ebcnt = ebcnt + 1
ecx_poc(3) = ecx_poc(3) + 1
End If
eb(ebcnt, 1) = 2
eb(ebcnt, 2) = ecx_pos(2)
eb(ebcnt, 3) = ecx_cnt(2) - ecx_cnt(1)
ebcnt = ebcnt + 1
ecx_poc(2) = ecx_poc(2) + 1
ecx_cnt(2) = 0
ElseIf (ecx_cnt(3) > ecx_cnt(1)) Then
eb(ebcnt, 1) = 3
eb(ebcnt, 2) = ecx_pos(3)
eb(ebcnt, 3) = ecx_cnt(3) - ecx_cnt(1)
ebcnt = ebcnt + 1
ecx_poc(3) = ecx_poc(3) + 1
End If
eb(ebcnt, 1) = 1
eb(ebcnt, 2) = ecx_pos(1)
eb(ebcnt, 3) = ecx_cnt(1)
ebcnt = ebcnt + 1
ecx_poc(1) = ecx_poc(1) + 1
ecx_cnt(1) = 0
ecx_cnt(2) = 0
ecx_cnt(3) = 0
End If
If ecx_cnt(2) = 0 Then ecx_pos(2) = i
ecx_cnt(2) = ecx_cnt(2) + 1
Else
ecx_cnt(2) = 0
End If
If k >= 0 And k < 10 Then
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
ecx_cnt(1) = 0
ecx_cnt(2) = 0
End If
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
Call qr_params(c, ecl, qrp, ecx_poc)
If qrp(1) <= 0 Then
err = "Too long"
Exit Function
End If
siz = qrp(2)
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
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
Next i
Call bb_putbits(encoded1, encix1, 0, 4)
If (encix1 Mod 8) <> 0 Then
Call bb_putbits(encoded1, encix1, 0, 8 - (encix1 Mod 8))
End If
i = (qrp(5) - qrp(3) * qrp(4)) * 8
If encix1 > i Then
err = "Encode length error"
Exit Function
End If
Do While encix1 < i
Call bb_putbits(encoded1, encix1, &HEC11, 16)
Loop
i = qrp(3) * qrp(4)
Call qr_rs(&H11D, encoded1, qrp(5) - i, i, qrp(4))
encix1 = qrp(5)
ReDim qrarr(0)
ReDim qrarr(1, qrp(2) * 24& + 24&)
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)
Call qr_mask(qrarr, 0, 8, 8, 0)
Call qr_mask(qrarr, qrsync1, 8, 0, siz - 7)
Call qr_mask(qrarr, 0, 8, 8, siz - 8)
Call qr_mask(qrarr, qrsync1, 8, siz - 7, 0)
Call qr_mask(qrarr, 0, 8, siz - 8, 0)
For i = 0 To 6
x = qr_bit(qrarr, -1, i, 8, 0)
x = qr_bit(qrarr, -1, i, siz - 8, 0)
x = qr_bit(qrarr, -1, siz - 1 - i, 8, 0)
Next
x = qr_bit(qrarr, -1, 7, 8, 0)
x = qr_bit(qrarr, -1, 7, siz - 8, 0)
x = qr_bit(qrarr, -1, 8, 8, 0) '
x = qr_bit(qrarr, -1, siz - 8, 8, 1)
If qrp(13) <> 0 Or qrp(14) <> 0 Then
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)
x = qr_bit(qrarr, -1, siz - 11 + c, r, ch)
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
x = qr_bit(qrarr, -1, i, 6, c)
x = qr_bit(qrarr, -1, 6, i, c)
c = (c + 1) Mod 2
Next
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
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
Call qr_fill(qrarr, siz, encoded1, qrp(4), qrp(5) - qrp(3) * qrp(4), qrp(5))
mask = 8
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)
If i < j Or j = -1 Then j = i: s = mask
Next mask
mask = s
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
Call qr_bch_calc(k, &H537)
k = k Xor &H5412
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)
x = qr_bit(qrarr, -1, 8, c, ch)
c = c - 1
r = r + 1
If i = 7 Then c = 7: r = siz - 7
If i = 5 Then r = r + 1
If i = 8 Then c = c - 1
Next
Return
End Function
Sub qr_params(ByVal pcap As Long, ByVal ecl As Integer, ByRef rv As Variant, ByRef ecx_poc As Variant)
Dim siz As Integer, totby As Long, s As String, i As Long, syncs As Integer, ccsiz As Integer, ccblks As Integer, j As Long, ver As Integer
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
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
Sub qr_rs(ppoly As Integer, pmemptr As Variant, ByVal psize As Integer, ByVal plen As Integer, ByVal pblocks As Integer)
Dim v_x As Integer, v_y As Integer, v_z As Integer, v_a As Integer, v_b As Integer
Dim pa As Integer, pb As Integer, rp As Integer
Dim v_last As Integer, v_bs As Integer, v_b2c As Integer
Dim vpo As Integer, vdo As Integer, v_es As Integer
Dim poly(512) As Byte
Dim v_ply() As Byte
v_x = 1: v_y = 0
For v_y = 0 To 255
poly(v_y) = v_x
poly(v_x + 256) = v_y
v_x = v_x * 2
If v_x > 255 Then v_x = v_x Xor ppoly
Next
For v_x = 1 To plen
pmemptr(v_x + psize) = 0
Next
v_b2c = pblocks
v_bs = Int(psize / pblocks)
v_es = Int(plen / pblocks)
v_x = psize Mod pblocks
v_b2c = pblocks - v_x
ReDim v_ply(v_es + 1)
v_z = 0
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
For v_b = 0 To (pblocks - 1)
vpo = v_b * v_es + 1 + psize
vdo = v_b * v_bs + 1
If v_b > v_b2c Then vdo = vdo + v_b - v_b2c
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
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
Sub qr_mask(parr As Variant, pb As Variant, ByVal pbits As Integer, ByVal pr As Integer, ByVal pc As Integer)
Dim i As Integer, w As Long, r As Integer, c As Integer, j As Integer
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
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
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 As Integer, va As Integer, r As Integer, c As Integer, s As Integer
r = prow
c = pcol
qr_bit = False
ix = r * 24 + Int(c / 8)
If ix > (UBound(parr, 2)) Or ix < 0 Then Exit Function
c = 2 ^ (c Mod 8)
va = parr(0, ix)
If psiz > 0 Then
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)
If pbit > 0 Then parr(1, ix) = parr(1, ix) Or c
If psiz < 0 Then parr(0, ix) = parr(0, ix) Or c
End If
End Function
Sub qr_fill(parr As Variant, ByVal psiz As Integer, pb As Variant, ByVal pblocks As Integer, ByVal pdlen As Integer, ByVal ptlen As Integer)
Dim vx As Integer, vb As Integer, vy As Integer, vdnlen As Integer, vds As Integer, ves As Integer, c As Integer, r As Integer, wa As Integer, wb As Integer, w As Integer, smer As Integer, vsb As Integer
vds = Int(pdlen / pblocks)
ves = Int((ptlen - pdlen) / pblocks)
vdnlen = vds * pblocks
vsb = pblocks - (pdlen Mod pblocks)
c = psiz - 1: r = c
smer = 0
' 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
vx = 0
Else
w = (w * 2) Mod 256
End If
End If
Select Case smer
Case 0, 2
c = c - 1
smer = smer + 1
Case 1
If r = 0 Then
c = c - 1
If c = 6 And psiz >= 21 Then c = c - 1
smer = 2
Else
c = c + 1
r = r - 1
smer = 0
End If
Case 3
If r = (psiz - 1) Then
c = c - 1
If c = 6 And psiz >= 21 Then c = c - 1
smer = 0
Else
c = c + 1
r = r + 1
smer = 2
End If
End Select
Loop
Exit Sub
qrfnb:
If vb < pdlen Then
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
w = pb(1 + vds * wb + wa)
ElseIf vb < ptlen Then
wa = vb - pdlen
wb = wa Mod pblocks
wa = Int(wa / pblocks)
w = pb(1 + pdlen + ves * wb + wa)
End If
vb = vb + 1
Return
End Sub
' Negro si 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 As Long, bl As Long, rp As Long, rc As Long, c As Integer, r As Integer, m As Integer, ix As Integer, i As Integer, w As Integer
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
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 = 0: bl = 0
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
cols(1, c) = (cols(1, c) And &H3FF) * 2
If (warr(ix) And m) <> 0 Then
If rc < 0 Then
If rc <= -5 Then score = score - 2 - rc
rc = 0
End If
rc = rc + 1
If cols(0, c) < 0 Then
If cols(0, c) <= -5 Then score = score - 2 - cols(0, c)
cols(0, c) = 0
End If
cols(0, c) = cols(0, c) + 1
rp = rp Or 1
cols(1, c) = cols(1, c) Or 1
bl = bl + 1
Else
If rc > 0 Then
If rc >= 5 Then score = score - 2 + rc
rc = 0
End If
rc = rc - 1
If cols(0, c) > 0 Then
If cols(0, c) >= 5 Then score = score - 2 + cols(0, c)
cols(0, c) = 0
End If
cols(0, c) = cols(0, c) - 1
End If
If c > 0 And r > 0 Then
i = rp And 3
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
End If
End If
If c >= 10 And (rp = &H5D Or rp = &H5D0) Then
score = score + 40
End If
If r >= 10 And (cols(1, c) = &H5D Or cols(1, c) = &H5D0) Then
score = score + 40
End If
If m = 128 Then
m = 1
ix = ix + 1
Else
m = m * 2
End If
Next
If rc <= -5 Then score = score - 2 - rc
If rc >= 5 Then score = score - 2 + rc
Next
For c = 0 To siz - 1
If cols(0, c) <= -5 Then score = score - 2 - cols(0, c)
If cols(0, c) >= 5 Then score = score - 2 + cols(0, c)
Next
bl = Int(Abs((bl * 100&) / (siz * siz) - 50&) / 5) * 10
qr_xormask = score + bl
End Function
Sub qr_bch_calc(ByRef Data As Long, ByVal poly As Long)
Dim b As Integer, n As Integer, rv As Long, x As Long
b = qr_numbits(poly) - 1
If Data = 0 Then
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
Function qr_numbits(ByVal num As Long) As Integer
Dim n As Integer, a As Long
a = 1: n = 0
Do While a <= num
a = a * 2
n = n + 1
Loop
qr_numbits = n
End Function
Módulo: modVars
Option Compare Database
Option Explicit
Public Const QRalnum As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ $%*+-./:"
Módulo de clase: clsPoint
Option Compare Database
Option Explicit
Public x As Long
Public y As Long
Public Value As Byte
Private Sub Class_Initialize()
Value = 1
End Sub
Módulo de clase: clsQRCodeEncoder
Option Compare Database
Option Explicit
Public ERROR_CORRECTION As enuERROR_CORRECTION
Public ENCODE_MODE As Byte
