vb吧 关注：156,111贴子：1,166,211
‘==============模块代码开始======================================
Option Explicit
Private Type PictDesc
cbSizeofStruct As Long
picType As Long
hImage As Long
xExt As Long
yExt As Long
End Type
Private Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors(255) As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function StretchDIBits Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal wSrcWidth As Long, ByVal wSrcHeight As Long, ByRef lpBits As Any, ByRef lpBitsInfo As BITMAPINFO, ByVal wUsage As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32.dll" (ByVal hdc As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PictDesc, riid As Guid, ByVal fPictureOwnsHandle As Long, ipic As IUnknown) As Long
Public Function BitmapToPicture(ByVal hBmp As Long, ByVal fPictureOwnsHandle As Long) As StdPicture
If (hBmp = 0) Then Exit Function
Dim oNewPic As IUnknown, tPicConv As PictDesc, IGuid As Guid
' Fill PictDesc structure with necessary parts:
With tPicConv
.cbSizeofStruct = Len(tPicConv)
.picType = vbPicTypeBitmap
.hImage = hBmp
End With
' Fill in IUnknown Interface ID
With IGuid
.Data4(0) = &HC0
.Data4(7) = &H46
End With
' Create a picture object:
OleCreatePictureIndirect tPicConv, IGuid, fPictureOwnsHandle, oNewPic
' Return it:
Set BitmapToPicture = oNewPic
End Function
'color depth: 8 bits, 0=white, all other=black
'width must be a multiple of 4
Public Function ByteArrayToPicture(ByVal lp As Long, ByVal nWidth As Long, ByVal nHeight As Long, Optional ByVal nLeftPadding As Long, Optional ByVal nTopPadding As Long, Optional ByVal nRightPadding As Long, Optional ByVal nBottomPadding As Long) As StdPicture
Dim tBMI As BITMAPINFO
Dim h As Long, hdc As Long, hBmp As Long
Dim hbr As Long
Dim r As RECT
With tBMI.bmiHeader
.biSize = 40&
.biWidth = nWidth
.biHeight = -nHeight
.biPlanes = 1
.biBitCount = 8
.biSizeImage = nWidth * nHeight
.biClrUsed = 256
End With
tBMI.bmiColors(0) = &HFFFFFF
tBMI.bmiColors(2) = &H808080 'debug only
h = GetDC(0)
hdc = CreateCompatibleDC(h)
r.Right = nWidth + nLeftPadding + nRightPadding
r.Bottom = nHeight + nTopPadding + nBottomPadding
hBmp = CreateCompatibleBitmap(h, r.Right, r.Bottom)
hBmp = SelectObject(hdc, hBmp)
hbr = CreateSolidBrush(vbWhite)
FillRect hdc, r, hbr
DeleteObject hbr
StretchDIBits hdc, nLeftPadding, nTopPadding, nWidth, nHeight, 0, 0, nWidth, nHeight, ByVal lp, tBMI, 0, vbSrcCopy
hBmp = SelectObject(hdc, hBmp)
DeleteDC hdc
ReleaseDC 0, h
Set ByteArrayToPicture = BitmapToPicture(hBmp, 1)
End Function
‘==============模块代码结束======================================
Option Explicit
Private Type PictDesc
cbSizeofStruct As Long
picType As Long
hImage As Long
xExt As Long
yExt As Long
End Type
Private Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors(255) As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function StretchDIBits Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal wSrcWidth As Long, ByVal wSrcHeight As Long, ByRef lpBits As Any, ByRef lpBitsInfo As BITMAPINFO, ByVal wUsage As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32.dll" (ByVal hdc As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PictDesc, riid As Guid, ByVal fPictureOwnsHandle As Long, ipic As IUnknown) As Long
Public Function BitmapToPicture(ByVal hBmp As Long, ByVal fPictureOwnsHandle As Long) As StdPicture
If (hBmp = 0) Then Exit Function
Dim oNewPic As IUnknown, tPicConv As PictDesc, IGuid As Guid
' Fill PictDesc structure with necessary parts:
With tPicConv
.cbSizeofStruct = Len(tPicConv)
.picType = vbPicTypeBitmap
.hImage = hBmp
End With
' Fill in IUnknown Interface ID
With IGuid
.Data4(0) = &HC0
.Data4(7) = &H46
End With
' Create a picture object:
OleCreatePictureIndirect tPicConv, IGuid, fPictureOwnsHandle, oNewPic
' Return it:
Set BitmapToPicture = oNewPic
End Function
'color depth: 8 bits, 0=white, all other=black
'width must be a multiple of 4
Public Function ByteArrayToPicture(ByVal lp As Long, ByVal nWidth As Long, ByVal nHeight As Long, Optional ByVal nLeftPadding As Long, Optional ByVal nTopPadding As Long, Optional ByVal nRightPadding As Long, Optional ByVal nBottomPadding As Long) As StdPicture
Dim tBMI As BITMAPINFO
Dim h As Long, hdc As Long, hBmp As Long
Dim hbr As Long
Dim r As RECT
With tBMI.bmiHeader
.biSize = 40&
.biWidth = nWidth
.biHeight = -nHeight
.biPlanes = 1
.biBitCount = 8
.biSizeImage = nWidth * nHeight
.biClrUsed = 256
End With
tBMI.bmiColors(0) = &HFFFFFF
tBMI.bmiColors(2) = &H808080 'debug only
h = GetDC(0)
hdc = CreateCompatibleDC(h)
r.Right = nWidth + nLeftPadding + nRightPadding
r.Bottom = nHeight + nTopPadding + nBottomPadding
hBmp = CreateCompatibleBitmap(h, r.Right, r.Bottom)
hBmp = SelectObject(hdc, hBmp)
hbr = CreateSolidBrush(vbWhite)
FillRect hdc, r, hbr
DeleteObject hbr
StretchDIBits hdc, nLeftPadding, nTopPadding, nWidth, nHeight, 0, 0, nWidth, nHeight, ByVal lp, tBMI, 0, vbSrcCopy
hBmp = SelectObject(hdc, hBmp)
DeleteDC hdc
ReleaseDC 0, h
Set ByteArrayToPicture = BitmapToPicture(hBmp, 1)
End Function
‘==============模块代码结束======================================
‘=========类模块一开始clsFiniteField=========================
Option Explicit
#Const UseInverseLUT = False
Private Const m_nMaxOrderShift As Long = 14
Private Const m_nMaxOrder As Long = 2 ^ m_nMaxOrderShift
Private m_nOrder As Long
Private m_nPolynomial As Long
Private m_nPrimitiveRoot As Long
Private m_nDiscreteLog(m_nMaxOrder - 1) As Integer
Private m_nDiscreteExp(m_nMaxOrder - 1) As Integer
#If UseInverseLUT Then
Private m_nInverse(m_nMaxOrder - 1) As Integer
#End If
Friend Property Get Order() As Long
Order = m_nOrder
End Property
Friend Property Get MinimalPolynomial() As Long
MinimalPolynomial = m_nPolynomial
End Property
Friend Property Get PrimitiveRoot() As Long
PrimitiveRoot = m_nPrimitiveRoot
End Property
'internal function
Friend Function pFindPrimitiveRoot() As Long
Dim nPrimeFactor(7) As Long
Dim t(m_nMaxOrderShift - 1) As Long
Dim nPrimeFactorCount As Long
Dim nPrimitiveRoot As Long
Dim i As Long, j As Long, k As Long
Dim m As Long
'///first factor order-1 using naive method
i = m_nOrder - 1
If (i And 1&) = 0 Then
nPrimeFactor(0) = i \ 2&
nPrimeFactorCount = 1
Do Until i And 1&
i = i \ 2&
Loop
End If
m = Sqr(i) + 2
j = 3
Do Until j > m
k = i \ j
If k * j = i Then
Do
i = k
k = i \ j
Loop While k * j = i
nPrimeFactor(nPrimeFactorCount) = (m_nOrder - 1) \ j
nPrimeFactorCount = nPrimeFactorCount + 1
m = Sqr(i) + 2
End If
j = j + 2
Loop
If i > 1 Then
nPrimeFactor(nPrimeFactorCount) = (m_nOrder - 1) \ i
nPrimeFactorCount = nPrimeFactorCount + 1
End If
'///try primitive root using naive method
For nPrimitiveRoot = 2 To m_nOrder - 1
'///build table
t(0) = nPrimitiveRoot
j = nPrimitiveRoot
For i = 1 To m_nMaxOrderShift - 1
j = Multiply(j, j)
t(i) = j
Next i
'///try it
For i = 0 To nPrimeFactorCount - 1
m = nPrimeFactor(i)
j = 1
For k = 0 To m_nMaxOrderShift - 1
If m And 1& Then j = Multiply(j, t(k))
m = m \ 2&
If m = 0 Then Exit For
Next k
If j = 1 Then Exit For
Next i
'///check if we find it
If i >= nPrimeFactorCount Then
pFindPrimitiveRoot = nPrimitiveRoot
Exit Function
End If
Next nPrimitiveRoot
End Function
'nOrder: should be a prime or power of two, max=16384
'nPolynomial: only used when order is power of two
'nPrimitiveRoot: 0 for automatic find a primitive root, or the input value must be a primitive root
Friend Function Init(ByVal nOrder As Long, Optional ByVal nPolynomial As Long, Optional ByVal nPrimitiveRoot As Long) As Boolean
Dim i As Long, j As Long, k As Long
'///
If nOrder <= 1 Or nOrder > m_nMaxOrder Then Exit Function
If nOrder = 2 Then
m_nOrder = 2
m_nPolynomial = 2
m_nPrimitiveRoot = 1
m_nDiscreteLog(0) = 0
m_nDiscreteLog(1) = 0
m_nDiscreteExp(0) = 1
m_nDiscreteExp(1) = 1
#If UseInverseLUT Then
m_nInverse(0) = 0
m_nInverse(1) = 1
#End If
ElseIf (nOrder And (nOrder - 1)) = 0 Then
'///power of two
If nPolynomial = 0 Then Exit Function
m_nOrder = nOrder
m_nPolynomial = nPolynomial
If nPrimitiveRoot = 0 Then nPrimitiveRoot = pFindPrimitiveRoot
m_nPrimitiveRoot = nPrimitiveRoot
'///calc discrete log LUT
m_nDiscreteLog(0) = 0
m_nDiscreteLog(1) = 0
m_nDiscreteLog(nPrimitiveRoot) = 1
m_nDiscreteExp(0) = 1
m_nDiscreteExp(nOrder - 1) = 1
m_nDiscreteExp(1) = nPrimitiveRoot
j = nPrimitiveRoot
For i = 2 To nOrder - 2
j = Multiply(j, nPrimitiveRoot)
m_nDiscreteLog(j) = i
m_nDiscreteExp(i) = j
Next i
'///calc inverse LUT
#If UseInverseLUT Then
m_nInverse(0) = 0
m_nInverse(1) = 1
For i = 1 To nOrder - 2
m_nInverse(m_nDiscreteExp(i)) = m_nDiscreteExp(nOrder - 1 - i)
Next i
#End If
Else
'///assume it's a prime
m_nOrder = nOrder
m_nPolynomial = nOrder
If nPrimitiveRoot = 0 Then nPrimitiveRoot = pFindPrimitiveRoot
m_nPrimitiveRoot = nPrimitiveRoot
'///calc discrete log LUT
m_nDiscreteLog(0) = 0
m_nDiscreteLog(1) = 0
m_nDiscreteLog(nPrimitiveRoot) = 1
m_nDiscreteExp(0) = 1
m_nDiscreteExp(nOrder - 1) = 1
m_nDiscreteExp(1) = nPrimitiveRoot
j = nPrimitiveRoot
For i = 2 To nOrder - 2
j = (j * nPrimitiveRoot) Mod nOrder
m_nDiscreteLog(j) = i
m_nDiscreteExp(i) = j
Next i
'///calc inverse LUT
#If UseInverseLUT Then
m_nInverse(0) = 0
m_nInverse(1) = 1
For i = 1 To nOrder - 2
m_nInverse(m_nDiscreteExp(i)) = m_nDiscreteExp(nOrder - 1 - i)
Next i
#End If
End If
'///over
Init = True
End Function
'input should be >=0, <order
Friend Function Add(ByVal n1 As Long, ByVal n2 As Long) As Long
If (m_nOrder And (m_nOrder - 1)) = 0 Then
Add = n1 Xor n2
Else
n1 = n1 + n2
If n1 >= m_nOrder Then n1 = n1 - m_nOrder
Add = n1
End If
End Function
'input should be >=0, <order
Friend Function Negative(ByVal n1 As Long) As Long
If (m_nOrder And (m_nOrder - 1)) = 0 Or n1 = 0 Then
Negative = n1
Else
Negative = m_nOrder - n1
End If
End Function
'input should be >=0, <order
Friend Function Subtract(ByVal n1 As Long, ByVal n2 As Long) As Long
If (m_nOrder And (m_nOrder - 1)) = 0 Then
Subtract = n1 Xor n2
Else
n1 = n1 - n2
If n1 < 0 Then n1 = n1 + m_nOrder
Subtract = n1
End If
End Function
'input should be >=0, <order
Friend Function MultiplyLUT(ByVal n1 As Long, ByVal n2 As Long) As Long
If n1 = 0 Or n2 = 0 Then Exit Function
n1 = m_nDiscreteLog(n1) + m_nDiscreteLog(n2)
If n1 >= m_nOrder - 1 Then n1 = n1 - m_nOrder + 1
MultiplyLUT = m_nDiscreteExp(n1)
End Function
'input should be >=0, <order
Friend Function Multiply(ByVal n1 As Long, ByVal n2 As Long) As Long
Dim i As Long, j As Long
'///
If n1 = 0 Or n2 = 0 Then Exit Function
If m_nOrder = 2 Then
Multiply = 1
ElseIf (m_nOrder And (m_nOrder - 1)) = 0 Then
i = 1
Do
If n2 And i Then
n2 = n2 Xor i
j = j Xor n1
End If
If n2 = 0 Then Exit Do
i = i + i
n1 = n1 + n1
If n1 And m_nOrder Then n1 = (n1 Xor m_nPolynomial) And (m_nOrder - 1)
Loop
Multiply = j
Else
Multiply = (n1 * n2) Mod m_nOrder
End If
End Function
'input should be >=0, <order
Friend Function InverseLUT(ByVal n As Long) As Long
If n = 0 Then Exit Function
#If UseInverseLUT Then
InverseLUT = m_nInverse(n)
#Else
InverseLUT = m_nDiscreteExp(m_nOrder - 1 - m_nDiscreteLog(n))
#End If
End Function
'input should be >=0, <order
Friend Function Inverse(ByVal b As Long) As Long
Dim a As Long, q As Long, t As Long
Dim y As Long, y1 As Long
'///
If b = 0 Then Exit Function
If m_nOrder = 2 Then
Inverse = 1
ElseIf (m_nOrder And (m_nOrder - 1)) = 0 Then
Debug.Assert False
Else
'///extended GCD
a = m_nOrder
'x := 0 lastx := 1 'does not need
'y := 1 lasty := 0
y = 1
'while b ≠ 0
Do While b <> 0
'quotient := a div b
q = a \ b
'(a, b) := (b, a mod b)
t = a - q * b
a = b
b = t
'(x, lastx) := (lastx - quotient*x, x) 'does not need
'(y, lasty) := (lasty - quotient*y, y)
t = y1 - q * y
y1 = y
y = t
Loop
'return (lastx, lasty)
y1 = y1 Mod m_nOrder
If y1 < 0 Then y1 = y1 + m_nOrder
Inverse = y1
End If
End Function
'input should be >=0, <order
Friend Function DivideLUT(ByVal n1 As Long, ByVal n2 As Long) As Long
If n1 = 0 Or n2 = 0 Then Exit Function
n1 = m_nDiscreteLog(n1) - m_nDiscreteLog(n2)
If n1 < 0 Then n1 = n1 + m_nOrder - 1
DivideLUT = m_nDiscreteExp(n1)
End Function
'input should be >=0, <order
Friend Function Divide(ByVal n1 As Long, ByVal n2 As Long) As Long
Dim a As Long, q As Long, t As Long
Dim y As Long, y1 As Long
'///
If n1 = 0 Or n2 = 0 Then Exit Function
If m_nOrder = 2 Then
Divide = 1
ElseIf (m_nOrder And (m_nOrder - 1)) = 0 Then
'TODO:
Debug.Assert False
Else
'///extended GCD
a = m_nOrder
'x := 0 lastx := 1 'does not need
'y := 1 lasty := 0
y = 1
'while b ≠ 0
Do While n2 <> 0
'quotient := a div b
q = a \ n2
'(a, b) := (b, a mod b)
t = a - q * n2
a = n2
n2 = t
'(x, lastx) := (lastx - quotient*x, x) 'does not need
'(y, lasty) := (lasty - quotient*y, y)
t = y1 - q * y
y1 = y
y = t
Loop
'return (lastx, lasty)
y1 = (n1 * y1) Mod m_nOrder
If y1 < 0 Then y1 = y1 + m_nOrder
Divide = y1
End If
End Function
'input should be >=0, <order
Friend Function DiscreteLog(ByVal n As Long) As Long
DiscreteLog = m_nDiscreteLog(n)
End Function
Friend Function DiscreteExp(ByVal n As Long) As Long
n = n Mod (m_nOrder - 1)
If n < 0 Then n = n + m_nOrder - 1
DiscreteExp = m_nDiscreteExp(n)
End Function
‘=========类模块一结束=========================================
‘=========类模块二开始clsQRCode==============================
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private m_objField As New clsFiniteField
Private m_objRS As New clsReedSolomon
Private m_nAlignmentPatternStep(1 To 40) As Byte
Private m_nECBlockCount(1 To 4, 1 To 40) As Byte
Private m_nECCodewordPerBlock(1 To 4, 1 To 40) As Byte
Private Type typeDynamicProgrammingNode
nPrevMode As Long
nCost As Long
nCount As Long
End Type
Private m_nPowerOfTwo(17) As Long
Private Sub Class_Initialize()
Dim i As Long, j As Long ', k As Long
Dim t(19) As Currency
m_objField.Init 256, 285, 2
For i = 1 To 6
m_nAlignmentPatternStep(i) = 255
Next i
For i = 7 To 13
m_nAlignmentPatternStep(i) = i * 2 + 2
Next i
For i = 14 To 20
m_nAlignmentPatternStep(i) = ((i * 2 + 4) \ 3) * 2
Next i
For i = 21 To 27
m_nAlignmentPatternStep(i) = (i + 2) And &HFFFFFFFE
Next i
For i = 28 To 34
m_nAlignmentPatternStep(i) = (i \ 3) * 2 + 6
Next i
For i = 35 To 40
m_nAlignmentPatternStep(i) = (i \ 3) * 2 + 2
Next i
t(0) = 7234017283807.6673@
t(1) = 28879552945704.1665@
t(2) = 28936068276237.1585@
t(3) = 43403882080855.757@
t(4) = 57871806698986.0098@
t(5) = 79545709764228.0196@
t(6) = 115743501728796.0836@
t(7) = 115771760039978.855@
t(8) = 151829034411806.183@
t(9) = 180708697744900.4551@
t(10) = 245645085252721.4856@
t(11) = 231346486727206.9641@
t(12) = 267572646950765.0828@
t(13) = 303629921758806.6572@
t(14) = 347005546390815.4382@
t(15) = 390381280975671.272@
t(16) = 433785163058198.197@
t(17) = 477160787262394.5235@
t(18) = 534976298105354.1141@
t(19) = 585585940022854.8376@
CopyMemory m_nECBlockCount(1, 1), t(0), 160&
t(0) = 202382271797140.1223@
t(1) = 116025973148025.4991@
t(2) = 202438570236877.8266@
t(3) = 187971418724617.8836@
t(4) = 202439669751874.1022@
t(5) = 202495527519598.1332@
t(6) = 173503827394324.6362@
t(7) = 216851411038831.2086@
t(8) = 202552264903282.5884@
t(9) = 202608559036262.6588@
t(10) = 173785741330141.0332@
t(11) = 217020298611904.4126@
t(12) = 216964002757568.8218@
t(13) = 217020298611904.4126@
t(14) = 217020298611904.4126@
t(15) = 217020298611904.4126@
t(16) = 217020298611904.4126@
t(17) = 217020298611904.4126@
t(18) = 217020298611904.4126@
t(19) = 217020298611904.4126@
CopyMemory m_nECCodewordPerBlock(1, 1), t(0), 160&
j = 1
For i = 0 To 17
m_nPowerOfTwo(i) = j
j = j + j
Next i
End Sub
Friend Function pDataModuleCount(ByVal nVersion As Long) As Long
Dim m As Long, i As Long
m = pModuleSize(nVersion)
Select Case nVersion
Case -4 To -1
pDataModuleCount = m * m - 81 + 4 * nVersion
Case 1 To 40
m = m * (m - 2) - 191
i = pAlignmentPatternSize(nVersion)
If i >= 2 Then
m = m + i * (10 - i * 25) + 55
If i > 2 Then m = m - 36
End If
pDataModuleCount = m
End Select
End Function
Friend Function pDataCodewordCount(ByVal nVersion As Long) As Long
Select Case nVersion
Case -4 To -1
pDataCodewordCount = (pDataModuleCount(nVersion) + 4) \ 8
Case 1 To 40
pDataCodewordCount = pDataModuleCount(nVersion) \ 8
End Select
End Function
Friend Function pModuleSize(ByVal nVersion As Long) As Long
Select Case nVersion
Case -4 To -1
pModuleSize = 9 - 2 * nVersion
Case 1 To 40
pModuleSize = 17 + 4 * nVersion
End Select
End Function
Friend Function pAlignmentPatternSize(ByVal nVersion As Long) As Long
If nVersion < 2 Then pAlignmentPatternSize = 1 _
Else pAlignmentPatternSize = 2 + nVersion \ 7
End Function
Friend Function pAlignmentPatternCount(ByVal nVersion As Long) As Long
Dim i As Long
i = pAlignmentPatternSize(nVersion)
If i < 2 Then pAlignmentPatternCount = 0 _
Else pAlignmentPatternCount = i * i - 3
End Function
Friend Function Encode(ByRef bInput() As Byte, ByVal nSize As Long, Optional ByVal nVersion As Long, Optional ByVal nECLevel As Long = 2, Optional ByVal nMaskType As Long = -1) As StdPicture
Dim b() As Byte, b2() As Byte
Dim bEncodedBit() As Byte
Dim bInterleavedBit() As Byte
Dim nPolynomial(255) As Long
Dim nEncodedBitCount As Long
Dim nDataCodewordCount As Long
Dim nAvaliableDataCodewordCount As Long
Dim nECBlockCount As Long
Dim nSmallBlockCount As Long
Dim nDataCodewordPerBlock As Long
Dim nECCodewordPerBlock As Long
Dim i As Long, ii As Long, j As Long, k As Long, kk As Long
Dim lp As Long, lp2 As Long
Dim bb As Byte
If nECLevel <= 0 Or nECLevel > 4 Then nECLevel = 2
If nVersion < 0 Then
Else
ReDim bEncodedBit(32767)
If nVersion = 0 Or nVersion > 40 Then
Do
nEncodedBitCount = pEncodeToBitArray(bEncodedBit, bInput, nSize, 1, True)
For nVersion = 1 To 9
nAvaliableDataCodewordCount = pDataCodewordCount(nVersion) - CLng(m_nECBlockCount(nECLevel, nVersion)) _
* CLng(m_nECCodewordPerBlock(nECLevel, nVersion))
If nEncodedBitCount - 4 <= nAvaliableDataCodewordCount * 8& Then Exit Do
Next nVersion
nEncodedBitCount = pEncodeToBitArray(bEncodedBit, bInput, nSize, 10, True)
For nVersion = 10 To 26
nAvaliableDataCodewordCount = pDataCodewordCount(nVersion) - CLng(m_nECBlockCount(nECLevel, nVersion)) _
* CLng(m_nECCodewordPerBlock(nECLevel, nVersion))
If nEncodedBitCount - 4 <= nAvaliableDataCodewordCount * 8& Then Exit Do
Next nVersion
nEncodedBitCount = pEncodeToBitArray(bEncodedBit, bInput, nSize, 27, True)
For nVersion = 27 To 40
nAvaliableDataCodewordCount = pDataCodewordCount(nVersion) - CLng(m_nECBlockCount(nECLevel, nVersion)) _
* CLng(m_nECCodewordPerBlock(nECLevel, nVersion))
If nEncodedBitCount - 4 <= nAvaliableDataCodewordCount * 8& Then Exit Do
Next nVersion
Exit Function
Loop
End If
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private m_objField As New clsFiniteField
Private m_objRS As New clsReedSolomon
Private m_nAlignmentPatternStep(1 To 40) As Byte
Private m_nECBlockCount(1 To 4, 1 To 40) As Byte
Private m_nECCodewordPerBlock(1 To 4, 1 To 40) As Byte
Private Type typeDynamicProgrammingNode
nPrevMode As Long
nCost As Long
nCount As Long
End Type
Private m_nPowerOfTwo(17) As Long
Private Sub Class_Initialize()
Dim i As Long, j As Long ', k As Long
Dim t(19) As Currency
m_objField.Init 256, 285, 2
For i = 1 To 6
m_nAlignmentPatternStep(i) = 255
Next i
For i = 7 To 13
m_nAlignmentPatternStep(i) = i * 2 + 2
Next i
For i = 14 To 20
m_nAlignmentPatternStep(i) = ((i * 2 + 4) \ 3) * 2
Next i
For i = 21 To 27
m_nAlignmentPatternStep(i) = (i + 2) And &HFFFFFFFE
Next i
For i = 28 To 34
m_nAlignmentPatternStep(i) = (i \ 3) * 2 + 6
Next i
For i = 35 To 40
m_nAlignmentPatternStep(i) = (i \ 3) * 2 + 2
Next i
t(0) = 7234017283807.6673@
t(1) = 28879552945704.1665@
t(2) = 28936068276237.1585@
t(3) = 43403882080855.757@
t(4) = 57871806698986.0098@
t(5) = 79545709764228.0196@
t(6) = 115743501728796.0836@
t(7) = 115771760039978.855@
t(8) = 151829034411806.183@
t(9) = 180708697744900.4551@
t(10) = 245645085252721.4856@
t(11) = 231346486727206.9641@
t(12) = 267572646950765.0828@
t(13) = 303629921758806.6572@
t(14) = 347005546390815.4382@
t(15) = 390381280975671.272@
t(16) = 433785163058198.197@
t(17) = 477160787262394.5235@
t(18) = 534976298105354.1141@
t(19) = 585585940022854.8376@
CopyMemory m_nECBlockCount(1, 1), t(0), 160&
t(0) = 202382271797140.1223@
t(1) = 116025973148025.4991@
t(2) = 202438570236877.8266@
t(3) = 187971418724617.8836@
t(4) = 202439669751874.1022@
t(5) = 202495527519598.1332@
t(6) = 173503827394324.6362@
t(7) = 216851411038831.2086@
t(8) = 202552264903282.5884@
t(9) = 202608559036262.6588@
t(10) = 173785741330141.0332@
t(11) = 217020298611904.4126@
t(12) = 216964002757568.8218@
t(13) = 217020298611904.4126@
t(14) = 217020298611904.4126@
t(15) = 217020298611904.4126@
t(16) = 217020298611904.4126@
t(17) = 217020298611904.4126@
t(18) = 217020298611904.4126@
t(19) = 217020298611904.4126@
CopyMemory m_nECCodewordPerBlock(1, 1), t(0), 160&
j = 1
For i = 0 To 17
m_nPowerOfTwo(i) = j
j = j + j
Next i
End Sub
Friend Function pDataModuleCount(ByVal nVersion As Long) As Long
Dim m As Long, i As Long
m = pModuleSize(nVersion)
Select Case nVersion
Case -4 To -1
pDataModuleCount = m * m - 81 + 4 * nVersion
Case 1 To 40
m = m * (m - 2) - 191
i = pAlignmentPatternSize(nVersion)
If i >= 2 Then
m = m + i * (10 - i * 25) + 55
If i > 2 Then m = m - 36
End If
pDataModuleCount = m
End Select
End Function
Friend Function pDataCodewordCount(ByVal nVersion As Long) As Long
Select Case nVersion
Case -4 To -1
pDataCodewordCount = (pDataModuleCount(nVersion) + 4) \ 8
Case 1 To 40
pDataCodewordCount = pDataModuleCount(nVersion) \ 8
End Select
End Function
Friend Function pModuleSize(ByVal nVersion As Long) As Long
Select Case nVersion
Case -4 To -1
pModuleSize = 9 - 2 * nVersion
Case 1 To 40
pModuleSize = 17 + 4 * nVersion
End Select
End Function
Friend Function pAlignmentPatternSize(ByVal nVersion As Long) As Long
If nVersion < 2 Then pAlignmentPatternSize = 1 _
Else pAlignmentPatternSize = 2 + nVersion \ 7
End Function
Friend Function pAlignmentPatternCount(ByVal nVersion As Long) As Long
Dim i As Long
i = pAlignmentPatternSize(nVersion)
If i < 2 Then pAlignmentPatternCount = 0 _
Else pAlignmentPatternCount = i * i - 3
End Function
Friend Function Encode(ByRef bInput() As Byte, ByVal nSize As Long, Optional ByVal nVersion As Long, Optional ByVal nECLevel As Long = 2, Optional ByVal nMaskType As Long = -1) As StdPicture
Dim b() As Byte, b2() As Byte
Dim bEncodedBit() As Byte
Dim bInterleavedBit() As Byte
Dim nPolynomial(255) As Long
Dim nEncodedBitCount As Long
Dim nDataCodewordCount As Long
Dim nAvaliableDataCodewordCount As Long
Dim nECBlockCount As Long
Dim nSmallBlockCount As Long
Dim nDataCodewordPerBlock As Long
Dim nECCodewordPerBlock As Long
Dim i As Long, ii As Long, j As Long, k As Long, kk As Long
Dim lp As Long, lp2 As Long
Dim bb As Byte
If nECLevel <= 0 Or nECLevel > 4 Then nECLevel = 2
If nVersion < 0 Then
Else
ReDim bEncodedBit(32767)
If nVersion = 0 Or nVersion > 40 Then
Do
nEncodedBitCount = pEncodeToBitArray(bEncodedBit, bInput, nSize, 1, True)
For nVersion = 1 To 9
nAvaliableDataCodewordCount = pDataCodewordCount(nVersion) - CLng(m_nECBlockCount(nECLevel, nVersion)) _
* CLng(m_nECCodewordPerBlock(nECLevel, nVersion))
If nEncodedBitCount - 4 <= nAvaliableDataCodewordCount * 8& Then Exit Do
Next nVersion
nEncodedBitCount = pEncodeToBitArray(bEncodedBit, bInput, nSize, 10, True)
For nVersion = 10 To 26
nAvaliableDataCodewordCount = pDataCodewordCount(nVersion) - CLng(m_nECBlockCount(nECLevel, nVersion)) _
* CLng(m_nECCodewordPerBlock(nECLevel, nVersion))
If nEncodedBitCount - 4 <= nAvaliableDataCodewordCount * 8& Then Exit Do
Next nVersion
nEncodedBitCount = pEncodeToBitArray(bEncodedBit, bInput, nSize, 27, True)
For nVersion = 27 To 40
nAvaliableDataCodewordCount = pDataCodewordCount(nVersion) - CLng(m_nECBlockCount(nECLevel, nVersion)) _
* CLng(m_nECCodewordPerBlock(nECLevel, nVersion))
If nEncodedBitCount - 4 <= nAvaliableDataCodewordCount * 8& Then Exit Do
Next nVersion
Exit Function
Loop
End If
Next k
Next l
Next i
Next j
For i = m - 7 - s To 18 Step -s
For l = -2 To 2
For k = -2 To 2
j = 2 + (k = 2 Or k = -2 Or l = 2 Or l = -2 Or (k Or l) = 0)
b(i + k, 6 + l) = j
b(6 + l, i + k) = j
Next k
Next l
Next i
End If
End Select
End Sub
Friend Function pAlphaNumericToNumber(ByVal b As Byte) As Long
Select Case b
Case &H30& To &H39&
pAlphaNumericToNumber = b - 48
Case &H41& To &H5A&
pAlphaNumericToNumber = b - 55
Case &H20
pAlphaNumericToNumber = 36
Case &H24
pAlphaNumericToNumber = 37
Case &H25
pAlphaNumericToNumber = 38
Case &H2A
pAlphaNumericToNumber = 39
Case &H2B
pAlphaNumericToNumber = 40
Case &H2D
pAlphaNumericToNumber = 41
Case &H2E
pAlphaNumericToNumber = 42
Case &H2F
pAlphaNumericToNumber = 43
Case &H3A
pAlphaNumericToNumber = 44
End Select
End Function
Friend Function pCheckExclusiveSubset(ByVal b As Byte) As Long
Select Case b
Case &H30& To &H39&
pCheckExclusiveSubset = 1
Case &H41& To &H5A&, &H20, &H24, &H25, &H2A, &H2B, &H2D, &H2E&, &H2F, &H3A
pCheckExclusiveSubset = 2
End Select
End Function
Friend Function pCheckKanji(ByVal b1 As Byte, ByVal b2 As Byte) As Boolean
If b2 >= &H40& Then
Select Case b1
Case &H81& To &H9F&, &HE0& To &HEA&
pCheckKanji = True
Case &HEB&
pCheckKanji = b2 <= &HBF&
End Select
End If
End Function
Friend Function pEncodeToBitArray(ByRef bOutput() As Byte, ByRef bInput() As Byte, ByVal nSize As Long, ByVal nVersion As Long, Optional ByVal bCheckSizeOnly As Boolean) As Long
Dim nEncodingMode() As Byte
Dim tNode() As typeDynamicProgrammingNode
Dim nMaxSize(3) As Long
Dim i As Long, j As Long, k As Long, m As Long
Dim nCost As Long, nCount As Long
Dim lp As Long, lp2 As Long
If nSize <= 0 Then
bOutput(0) = 0
bOutput(1) = 0
bOutput(2) = 0
bOutput(3) = 0
pEncodeToBitArray = 4
Exit Function
End If
Select Case nVersion
Case Is < 10
nVersion = 2
nMaxSize(0) = 255
nMaxSize(1) = 1023
nMaxSize(2) = 511
nMaxSize(3) = 255
Case Is < 27
nVersion = 4
nMaxSize(0) = 65535
nMaxSize(1) = 4095
nMaxSize(2) = 2047
nMaxSize(3) = 1023
Case Else
nVersion = 6
nMaxSize(0) = 65535
nMaxSize(1) = 16383
nMaxSize(2) = 8191
nMaxSize(3) = 4095
End Select
ReDim tNode(3, nSize - 1)
For lp = 0 To nSize - 1
If lp > 0 Then
nCost = &H7FFFFFFF
For i = 0 To 3
k = tNode(i, lp - 1).nCost + 8
If i <> 0 Or tNode(i, lp - 1).nCount >= nMaxSize(0) Then k = k + 12 + (nVersion And 4) * 2
If k < nCost Then
j = i
nCost = k
nCount = tNode(i, lp - 1).nCount And i = 0 And tNode(i, lp - 1).nCount < nMaxSize(0)
End If
Next i
Else
j = -1
nCost = 20 + (nVersion And 4) * 2
nCount = 0
End If
tNode(0, lp).nPrevMode = j
tNode(0, lp).nCost = nCost
tNode(0, lp).nCount = nCount + 1
lp2 = pCheckExclusiveSubset(bInput(lp))
If lp2 = 1 Then
If lp > 0 Then
nCost = &H7FFFFFFF
For i = 0 To 3
k = tNode(i, lp - 1).nCost
If i <> 1 Or tNode(i, lp - 1).nCount >= nMaxSize(1) Then
k = k + 16 + nVersion
Else
k = k + 3
If (tNode(i, lp - 1).nCount Mod 3) = 0 Then k = k + 1
End If
If k < nCost Then
j = i
nCost = k
nCount = tNode(i, lp - 1).nCount And i = 1 And tNode(i, lp - 1).nCount < nMaxSize(1)
End If
Next i
Else
j = -1
nCost = 16 + nVersion
nCount = 0
End If
tNode(1, lp).nPrevMode = j
tNode(1, lp).nCost = nCost
tNode(1, lp).nCount = nCount + 1
Else
tNode(1, lp).nCost = &H70000000
End If
If lp2 > 0 Then
If lp > 0 Then
nCost = &H7FFFFFFF
For i = 0 To 3
k = tNode(i, lp - 1).nCost
If i <> 2 Or tNode(i, lp - 1).nCount >= nMaxSize(2) Then
k = k + 17 + nVersion
Else
k = k + 5
If (tNode(i, lp - 1).nCount And 1) = 0 Then k = k + 1
End If
If k < nCost Then
j = i
nCost = k
nCount = tNode(i, lp - 1).nCount And i = 2 And tNode(i, lp - 1).nCount < nMaxSize(2)
End If
Next i
Else
j = -1
nCost = 17 + nVersion
nCount = 0
End If
tNode(2, lp).nPrevMode = j
tNode(2, lp).nCost = nCost
tNode(2, lp).nCount = nCount + 1
Else
tNode(2, lp).nCost = &H70000000
End If
If lp = 0 Then
tNode(3, lp).nCost = &H70000000
ElseIf Not pCheckKanji(bInput(lp - 1), bInput(lp)) Then
tNode(3, lp).nCost = &H70000000
Else
If lp > 1 Then
nCost = &H7FFFFFFF
For i = 0 To 3
k = tNode(i, lp - 2).nCost + 13
If i <> 3 Or tNode(i, lp - 2).nCount >= nMaxSize(3) Then k = k + 10 + nVersion
If k < nCost Then
j = i
nCost = k
nCount = tNode(i, lp - 2).nCount And i = 3 And tNode(i, lp - 2).nCount < nMaxSize(3)
End If
Next i
Else
j = -1
nCost = 23 + nVersion
nCount = 0
End If
tNode(3, lp).nPrevMode = j
tNode(3, lp).nCost = nCost
tNode(3, lp).nCount = nCount + 1
End If
Next lp
nCost = &H7FFFFFFF
For i = 0 To 3
k = tNode(i, nSize - 1).nCost
If k < nCost Then
j = i
nCost = k
End If
Next i
If bCheckSizeOnly Then
pEncodeToBitArray = nCost + 4
Exit Function
End If
ReDim nEncodingMode(nSize - 1)
lp = nSize - 1
Do
k = tNode(j, lp).nPrevMode
nEncodingMode(lp) = j
lp = lp - 1
If j = 3 Then
If lp < 0 Then
Debug.Assert False
Exit Function
End If
nEncodingMode(lp) = j
lp = lp - 1
End If
j = k
Loop While lp >= 0
Erase tNode
nMaxSize(3) = nMaxSize(3) * 2
lp = 0
lp2 = 0
Do
j = nEncodingMode(lp)
For nCount = 1 To nSize - 1 - lp
If nEncodingMode(lp + nCount) <> j Then Exit For
If nCount >= nMaxSize(j) Then Exit For
Next nCount
Select Case j
Case 0 'byte
bOutput(lp2) = 0
bOutput(lp2 + 1) = 1
bOutput(lp2 + 2) = 0
bOutput(lp2 + 3) = 0
lp2 = lp2 + 4
m = 8 + (nVersion And 4) * 2
For i = 0 To m - 1
bOutput(lp2 + i) = (nCount And m_nPowerOfTwo(m - 1 - i)) <> 0 And 1
Next i
lp2 = lp2 + m
For j = 0 To nCount - 1
k = bInput(lp + j)
For i = 0 To 7
bOutput(lp2 + i) = (k And m_nPowerOfTwo(7 - i)) <> 0 And 1
Next i
lp2 = lp2 + 8
Next j
Case 1 'number
bOutput(lp2) = 0
bOutput(lp2 + 1) = 0
bOutput(lp2 + 2) = 0
bOutput(lp2 + 3) = 1
lp2 = lp2 + 4
m = 8 + nVersion
For i = 0 To m - 1
bOutput(lp2 + i) = (nCount And m_nPowerOfTwo(m - 1 - i)) <> 0 And 1
Next i
lp2 = lp2 + m
For j = 0 To nCount - 3 Step 3
k = (bInput(lp + j) And &HF&) * 100& + (bInput(lp + j + 1) And &HF&) * 10& + (bInput(lp + j + 2) And &HF&)
For i = 0 To 9
bOutput(lp2 + i) = (k And m_nPowerOfTwo(9 - i)) <> 0 And 1
Next i
lp2 = lp2 + 10
Next j
Select Case nCount Mod 3
Case 1
k = (bInput(lp + nCount - 1) And &HF&)
For i = 0 To 3
bOutput(lp2 + i) = (k And m_nPowerOfTwo(3 - i)) <> 0 And 1
Next i
lp2 = lp2 + 4
Case 2
k = (bInput(lp + nCount - 2) And &HF&) * 10& + (bInput(lp + nCount - 1) And &HF&)
For i = 0 To 6
bOutput(lp2 + i) = (k And m_nPowerOfTwo(6 - i)) <> 0 And 1
Next i
lp2 = lp2 + 7
End Select
Case 2 'alphanumeric
bOutput(lp2) = 0
bOutput(lp2 + 1) = 0
bOutput(lp2 + 2) = 1
bOutput(lp2 + 3) = 0
lp2 = lp2 + 4
m = 7 + nVersion
For i = 0 To m - 1
bOutput(lp2 + i) = (nCount And m_nPowerOfTwo(m - 1 - i)) <> 0 And 1
Next i
lp2 = lp2 + m
For j = 0 To nCount - 2 Step 2
k = pAlphaNumericToNumber(bInput(lp + j)) * 45& + pAlphaNumericToNumber(bInput(lp + j + 1))
For i = 0 To 10
bOutput(lp2 + i) = (k And m_nPowerOfTwo(10 - i)) <> 0 And 1
Next i
lp2 = lp2 + 11
Next j
If nCount And 1& Then
k = pAlphaNumericToNumber(bInput(lp + nCount - 1))
For i = 0 To 5
bOutput(lp2 + i) = (k And m_nPowerOfTwo(5 - i)) <> 0 And 1
Next i
lp2 = lp2 + 6
End If
Case 3 'kanji
bOutput(lp2) = 1
bOutput(lp2 + 1) = 0
bOutput(lp2 + 2) = 0
bOutput(lp2 + 3) = 0
lp2 = lp2 + 4
Debug.Assert (nCount And 1&) = 0
m = 6 + nVersion
For i = 0 To m - 1
bOutput(lp2 + i) = (nCount And m_nPowerOfTwo(m - i)) <> 0 And 1
Next i
lp2 = lp2 + m
For j = 0 To nCount - 2 Step 2
i = bInput(lp + j)
Select Case i
Case &H81& To &H9F&
i = i - &H81&
Case &HE0& To &HEB&
i = i - &HC1&
Case Else
Debug.Assert False
Exit Function
End Select
k = bInput(lp + j + 1) - &H40&
Debug.Assert k >= 0
k = k + i * &HC0&
Debug.Assert k < &H2000&
For i = 0 To 12
bOutput(lp2 + i) = (k And m_nPowerOfTwo(12 - i)) <> 0 And 1
Next i
lp2 = lp2 + 13
Next j
End Select
lp = lp + nCount
Loop While lp < nSize
bOutput(lp2) = 0
bOutput(lp2 + 1) = 0
bOutput(lp2 + 2) = 0
bOutput(lp2 + 3) = 0
pEncodeToBitArray = lp2 + 4
End Function
‘=========类模块二结束=========================================
Next l
Next i
Next j
For i = m - 7 - s To 18 Step -s
For l = -2 To 2
For k = -2 To 2
j = 2 + (k = 2 Or k = -2 Or l = 2 Or l = -2 Or (k Or l) = 0)
b(i + k, 6 + l) = j
b(6 + l, i + k) = j
Next k
Next l
Next i
End If
End Select
End Sub
Friend Function pAlphaNumericToNumber(ByVal b As Byte) As Long
Select Case b
Case &H30& To &H39&
pAlphaNumericToNumber = b - 48
Case &H41& To &H5A&
pAlphaNumericToNumber = b - 55
Case &H20
pAlphaNumericToNumber = 36
Case &H24
pAlphaNumericToNumber = 37
Case &H25
pAlphaNumericToNumber = 38
Case &H2A
pAlphaNumericToNumber = 39
Case &H2B
pAlphaNumericToNumber = 40
Case &H2D
pAlphaNumericToNumber = 41
Case &H2E
pAlphaNumericToNumber = 42
Case &H2F
pAlphaNumericToNumber = 43
Case &H3A
pAlphaNumericToNumber = 44
End Select
End Function
Friend Function pCheckExclusiveSubset(ByVal b As Byte) As Long
Select Case b
Case &H30& To &H39&
pCheckExclusiveSubset = 1
Case &H41& To &H5A&, &H20, &H24, &H25, &H2A, &H2B, &H2D, &H2E&, &H2F, &H3A
pCheckExclusiveSubset = 2
End Select
End Function
Friend Function pCheckKanji(ByVal b1 As Byte, ByVal b2 As Byte) As Boolean
If b2 >= &H40& Then
Select Case b1
Case &H81& To &H9F&, &HE0& To &HEA&
pCheckKanji = True
Case &HEB&
pCheckKanji = b2 <= &HBF&
End Select
End If
End Function
Friend Function pEncodeToBitArray(ByRef bOutput() As Byte, ByRef bInput() As Byte, ByVal nSize As Long, ByVal nVersion As Long, Optional ByVal bCheckSizeOnly As Boolean) As Long
Dim nEncodingMode() As Byte
Dim tNode() As typeDynamicProgrammingNode
Dim nMaxSize(3) As Long
Dim i As Long, j As Long, k As Long, m As Long
Dim nCost As Long, nCount As Long
Dim lp As Long, lp2 As Long
If nSize <= 0 Then
bOutput(0) = 0
bOutput(1) = 0
bOutput(2) = 0
bOutput(3) = 0
pEncodeToBitArray = 4
Exit Function
End If
Select Case nVersion
Case Is < 10
nVersion = 2
nMaxSize(0) = 255
nMaxSize(1) = 1023
nMaxSize(2) = 511
nMaxSize(3) = 255
Case Is < 27
nVersion = 4
nMaxSize(0) = 65535
nMaxSize(1) = 4095
nMaxSize(2) = 2047
nMaxSize(3) = 1023
Case Else
nVersion = 6
nMaxSize(0) = 65535
nMaxSize(1) = 16383
nMaxSize(2) = 8191
nMaxSize(3) = 4095
End Select
ReDim tNode(3, nSize - 1)
For lp = 0 To nSize - 1
If lp > 0 Then
nCost = &H7FFFFFFF
For i = 0 To 3
k = tNode(i, lp - 1).nCost + 8
If i <> 0 Or tNode(i, lp - 1).nCount >= nMaxSize(0) Then k = k + 12 + (nVersion And 4) * 2
If k < nCost Then
j = i
nCost = k
nCount = tNode(i, lp - 1).nCount And i = 0 And tNode(i, lp - 1).nCount < nMaxSize(0)
End If
Next i
Else
j = -1
nCost = 20 + (nVersion And 4) * 2
nCount = 0
End If
tNode(0, lp).nPrevMode = j
tNode(0, lp).nCost = nCost
tNode(0, lp).nCount = nCount + 1
lp2 = pCheckExclusiveSubset(bInput(lp))
If lp2 = 1 Then
If lp > 0 Then
nCost = &H7FFFFFFF
For i = 0 To 3
k = tNode(i, lp - 1).nCost
If i <> 1 Or tNode(i, lp - 1).nCount >= nMaxSize(1) Then
k = k + 16 + nVersion
Else
k = k + 3
If (tNode(i, lp - 1).nCount Mod 3) = 0 Then k = k + 1
End If
If k < nCost Then
j = i
nCost = k
nCount = tNode(i, lp - 1).nCount And i = 1 And tNode(i, lp - 1).nCount < nMaxSize(1)
End If
Next i
Else
j = -1
nCost = 16 + nVersion
nCount = 0
End If
tNode(1, lp).nPrevMode = j
tNode(1, lp).nCost = nCost
tNode(1, lp).nCount = nCount + 1
Else
tNode(1, lp).nCost = &H70000000
End If
If lp2 > 0 Then
If lp > 0 Then
nCost = &H7FFFFFFF
For i = 0 To 3
k = tNode(i, lp - 1).nCost
If i <> 2 Or tNode(i, lp - 1).nCount >= nMaxSize(2) Then
k = k + 17 + nVersion
Else
k = k + 5
If (tNode(i, lp - 1).nCount And 1) = 0 Then k = k + 1
End If
If k < nCost Then
j = i
nCost = k
nCount = tNode(i, lp - 1).nCount And i = 2 And tNode(i, lp - 1).nCount < nMaxSize(2)
End If
Next i
Else
j = -1
nCost = 17 + nVersion
nCount = 0
End If
tNode(2, lp).nPrevMode = j
tNode(2, lp).nCost = nCost
tNode(2, lp).nCount = nCount + 1
Else
tNode(2, lp).nCost = &H70000000
End If
If lp = 0 Then
tNode(3, lp).nCost = &H70000000
ElseIf Not pCheckKanji(bInput(lp - 1), bInput(lp)) Then
tNode(3, lp).nCost = &H70000000
Else
If lp > 1 Then
nCost = &H7FFFFFFF
For i = 0 To 3
k = tNode(i, lp - 2).nCost + 13
If i <> 3 Or tNode(i, lp - 2).nCount >= nMaxSize(3) Then k = k + 10 + nVersion
If k < nCost Then
j = i
nCost = k
nCount = tNode(i, lp - 2).nCount And i = 3 And tNode(i, lp - 2).nCount < nMaxSize(3)
End If
Next i
Else
j = -1
nCost = 23 + nVersion
nCount = 0
End If
tNode(3, lp).nPrevMode = j
tNode(3, lp).nCost = nCost
tNode(3, lp).nCount = nCount + 1
End If
Next lp
nCost = &H7FFFFFFF
For i = 0 To 3
k = tNode(i, nSize - 1).nCost
If k < nCost Then
j = i
nCost = k
End If
Next i
If bCheckSizeOnly Then
pEncodeToBitArray = nCost + 4
Exit Function
End If
ReDim nEncodingMode(nSize - 1)
lp = nSize - 1
Do
k = tNode(j, lp).nPrevMode
nEncodingMode(lp) = j
lp = lp - 1
If j = 3 Then
If lp < 0 Then
Debug.Assert False
Exit Function
End If
nEncodingMode(lp) = j
lp = lp - 1
End If
j = k
Loop While lp >= 0
Erase tNode
nMaxSize(3) = nMaxSize(3) * 2
lp = 0
lp2 = 0
Do
j = nEncodingMode(lp)
For nCount = 1 To nSize - 1 - lp
If nEncodingMode(lp + nCount) <> j Then Exit For
If nCount >= nMaxSize(j) Then Exit For
Next nCount
Select Case j
Case 0 'byte
bOutput(lp2) = 0
bOutput(lp2 + 1) = 1
bOutput(lp2 + 2) = 0
bOutput(lp2 + 3) = 0
lp2 = lp2 + 4
m = 8 + (nVersion And 4) * 2
For i = 0 To m - 1
bOutput(lp2 + i) = (nCount And m_nPowerOfTwo(m - 1 - i)) <> 0 And 1
Next i
lp2 = lp2 + m
For j = 0 To nCount - 1
k = bInput(lp + j)
For i = 0 To 7
bOutput(lp2 + i) = (k And m_nPowerOfTwo(7 - i)) <> 0 And 1
Next i
lp2 = lp2 + 8
Next j
Case 1 'number
bOutput(lp2) = 0
bOutput(lp2 + 1) = 0
bOutput(lp2 + 2) = 0
bOutput(lp2 + 3) = 1
lp2 = lp2 + 4
m = 8 + nVersion
For i = 0 To m - 1
bOutput(lp2 + i) = (nCount And m_nPowerOfTwo(m - 1 - i)) <> 0 And 1
Next i
lp2 = lp2 + m
For j = 0 To nCount - 3 Step 3
k = (bInput(lp + j) And &HF&) * 100& + (bInput(lp + j + 1) And &HF&) * 10& + (bInput(lp + j + 2) And &HF&)
For i = 0 To 9
bOutput(lp2 + i) = (k And m_nPowerOfTwo(9 - i)) <> 0 And 1
Next i
lp2 = lp2 + 10
Next j
Select Case nCount Mod 3
Case 1
k = (bInput(lp + nCount - 1) And &HF&)
For i = 0 To 3
bOutput(lp2 + i) = (k And m_nPowerOfTwo(3 - i)) <> 0 And 1
Next i
lp2 = lp2 + 4
Case 2
k = (bInput(lp + nCount - 2) And &HF&) * 10& + (bInput(lp + nCount - 1) And &HF&)
For i = 0 To 6
bOutput(lp2 + i) = (k And m_nPowerOfTwo(6 - i)) <> 0 And 1
Next i
lp2 = lp2 + 7
End Select
Case 2 'alphanumeric
bOutput(lp2) = 0
bOutput(lp2 + 1) = 0
bOutput(lp2 + 2) = 1
bOutput(lp2 + 3) = 0
lp2 = lp2 + 4
m = 7 + nVersion
For i = 0 To m - 1
bOutput(lp2 + i) = (nCount And m_nPowerOfTwo(m - 1 - i)) <> 0 And 1
Next i
lp2 = lp2 + m
For j = 0 To nCount - 2 Step 2
k = pAlphaNumericToNumber(bInput(lp + j)) * 45& + pAlphaNumericToNumber(bInput(lp + j + 1))
For i = 0 To 10
bOutput(lp2 + i) = (k And m_nPowerOfTwo(10 - i)) <> 0 And 1
Next i
lp2 = lp2 + 11
Next j
If nCount And 1& Then
k = pAlphaNumericToNumber(bInput(lp + nCount - 1))
For i = 0 To 5
bOutput(lp2 + i) = (k And m_nPowerOfTwo(5 - i)) <> 0 And 1
Next i
lp2 = lp2 + 6
End If
Case 3 'kanji
bOutput(lp2) = 1
bOutput(lp2 + 1) = 0
bOutput(lp2 + 2) = 0
bOutput(lp2 + 3) = 0
lp2 = lp2 + 4
Debug.Assert (nCount And 1&) = 0
m = 6 + nVersion
For i = 0 To m - 1
bOutput(lp2 + i) = (nCount And m_nPowerOfTwo(m - i)) <> 0 And 1
Next i
lp2 = lp2 + m
For j = 0 To nCount - 2 Step 2
i = bInput(lp + j)
Select Case i
Case &H81& To &H9F&
i = i - &H81&
Case &HE0& To &HEB&
i = i - &HC1&
Case Else
Debug.Assert False
Exit Function
End Select
k = bInput(lp + j + 1) - &H40&
Debug.Assert k >= 0
k = k + i * &HC0&
Debug.Assert k < &H2000&
For i = 0 To 12
bOutput(lp2 + i) = (k And m_nPowerOfTwo(12 - i)) <> 0 And 1
Next i
lp2 = lp2 + 13
Next j
End Select
lp = lp + nCount
Loop While lp < nSize
bOutput(lp2) = 0
bOutput(lp2 + 1) = 0
bOutput(lp2 + 2) = 0
bOutput(lp2 + 3) = 0
pEncodeToBitArray = lp2 + 4
End Function
‘=========类模块二结束=========================================
‘=========类模块三开始clsReedSolomon============================
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Const m_nMaxSize As Long = 1024
Private m_objField As clsFiniteField
Private m_nDataCount As Long
Private m_nChecksumCount As Long
Private m_nPrimitiveRoot As Long
Private m_nStartingPower As Long
Private m_nGeneratorPolynomial(m_nMaxSize - 1) As Long
Friend Property Get Field() As clsFiniteField
Set Field = m_objField
End Property
Friend Property Set Field(ByVal obj As clsFiniteField)
Set m_objField = obj
End Property
Friend Property Get PrimitiveRoot() As Long
PrimitiveRoot = m_nPrimitiveRoot
End Property
Friend Property Let PrimitiveRoot(ByVal n As Long)
m_nPrimitiveRoot = n
End Property
Friend Property Get DataCount() As Long
DataCount = m_nDataCount
End Property
Friend Property Get ChecksumCount() As Long
ChecksumCount = m_nChecksumCount
End Property
Friend Property Get StartingPower() As Long
StartingPower = m_nStartingPower
End Property
Friend Property Get GeneratorPolynomialCoefficient(ByVal nDegree As Long) As Long
GeneratorPolynomialCoefficient = m_nGeneratorPolynomial(nDegree)
End Property
Friend Function Init(ByVal nDataCount As Long, ByVal nChecksumCount As Long, Optional ByVal objField As clsFiniteField, Optional ByVal nPrimitiveRoot As Long, Optional ByVal nStartingPower As Long) As Boolean
Dim i As Long, j As Long
Dim t As Long
'///
If nDataCount <= 0 Or nChecksumCount <= 0 Or nDataCount + nChecksumCount > m_nMaxSize Then Exit Function
If nStartingPower < 0 Then Exit Function
If objField Is Nothing Then Set objField = m_objField _
Else Set m_objField = objField
If objField Is Nothing Then Exit Function
'///
If nPrimitiveRoot = 0 Then nPrimitiveRoot = m_nPrimitiveRoot
If nPrimitiveRoot = 0 Then nPrimitiveRoot = m_objField.PrimitiveRoot
If nPrimitiveRoot = 0 Then Exit Function
m_nDataCount = nDataCount
m_nChecksumCount = nChecksumCount
m_nPrimitiveRoot = nPrimitiveRoot
m_nStartingPower = nStartingPower
'///some stupid things
If nStartingPower And 1 Then
t = nPrimitiveRoot
nStartingPower = nStartingPower Xor 1
Else
t = 1
End If
i = 1
j = nPrimitiveRoot
Do Until nStartingPower = 0
i = i + i
j = objField.MultiplyLUT(j, j)
If nStartingPower And i Then
t = objField.MultiplyLUT(t, j)
nStartingPower = nStartingPower Xor i
End If
Loop
t = objField.Negative(t)
'///
'calc generator polynomial $g(x)=\prod_{i=1}^{nChecksumCount}(x-nPrimitiveRoot^i)$
'using naive polynomial multiply
Erase m_nGeneratorPolynomial
m_nGeneratorPolynomial(0) = t
m_nGeneratorPolynomial(1) = 1
For i = 2 To nChecksumCount
t = objField.MultiplyLUT(t, nPrimitiveRoot)
m_nGeneratorPolynomial(i) = 1
For j = i - 1 To 1 Step -1
m_nGeneratorPolynomial(j) = objField.Add(m_nGeneratorPolynomial(j - 1), _
objField.MultiplyLUT(m_nGeneratorPolynomial(j), t))
Next j
m_nGeneratorPolynomial(0) = objField.MultiplyLUT(m_nGeneratorPolynomial(0), t)
Next i
'///over
Init = True
End Function
'input: index nChecksumCount to nChecksumCount+nDataCount-1
'output: index 0 to nChecksumCount-1
Friend Sub Encode(ByRef nData() As Long)
Dim t(m_nMaxSize - 1) As Long
Dim i As Long, j As Long, k As Long
'///input data
CopyMemory t(m_nChecksumCount), nData(m_nChecksumCount), m_nDataCount * 4&
'///calc the remainder using naive algorithm
For i = m_nDataCount - 1 To 0 Step -1
k = t(i + m_nChecksumCount)
For j = 0 To m_nChecksumCount - 1
t(i + j) = m_objField.Subtract(t(i + j), m_objField.MultiplyLUT(k, m_nGeneratorPolynomial(j)))
Next j
Next i
'///output data
For i = 0 To m_nChecksumCount - 1
nData(i) = m_objField.Negative(t(i))
Next i
'///over
End Sub
‘=========类模块三结束=========================================
名正在想
