【VB】VB6实现CRC32

0xAA55 发表于 2020-7-1 07:16:03

Option Explicit

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Public g_CRC32_Table() As Long

Private Function ShR1(ByVal Value As Long) As Long
If Value >= 0 Then
ShR1 = Value \ &H2&
Else
ShR1 = ((Value And &H7FFFFFFF) \ &H2&) Or &H40000000
End If
End Function

Private Function ShR8(ByVal Value As Long) As Long
If Value >= 0 Then
ShR8 = Value \ &H100&
Else
ShR8 = ((Value And &H7FFFFFFF) \ &H100&) Or &H800000
End If
End Function

Private Sub CRC32_GenTable()
Erase g_CRC32_Table
ReDim g_CRC32_Table(255)
Dim I As Long, J As Long, Remainder As Long
Const Polynomial As Long = &HEDB88320
For I = 0 To 255
Remainder = I
For J = 0 To 7
   If Remainder And 1 Then
         Remainder = ShR1(Remainder) Xor Polynomial
   Else
         Remainder = ShR1(Remainder)
   End If
Next
g_CRC32_Table(I) = Remainder
'Debug.Print Hex8(Remainder); ", ";
'If I Mod 4 = 3 Then Debug.Print
Next
End Sub

Sub CRC32_Init()
On Local Error GoTo ErrHandler
Dim ByteArray() As Byte
ByteArray = LoadResData("CRC_TABLE", "BIN")
ReDim g_CRC32_Table((UBound(ByteArray) + 1) / 4 - 1)
CopyMemory g_CRC32_Table(0), ByteArray(0), UBound(ByteArray) + 1
Exit Sub
ErrHandler:
CRC32_GenTable
End Sub

Function CRC32(ByVal CRC As Long, Data() As Byte) As Long
On Local Error GoTo ErrHandler
Dim I As Long
Start:

CRC32 = Not CRC

For I = LBound(Data) To UBound(Data)
CRC32 = g_CRC32_Table((CRC32 Xor Data(I)) And &HFF&) Xor ShR8(CRC32)
Next

CRC32 = Not CRC32

Exit Function
ErrHandler:
If Err.Number = 9 Then
Err.Clear
CRC32_Init
GoTo Start
Else
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End If
End Function其实CRC32需要的这个移位操作可以用整数除法实现。关键是：VB6的Long是有符号的，负数做除法的效果不同于移位，所以需要对负数做特殊处理。但总之，可以轻松实现。

CRC32需要CRC表，这个表可以直接做成RES资源，然后用LoadResData读出为Byte数组，再Copy成Long数组即可。

虽说这份代码会自动没有RES资源的时候，现场计算CRC表。

Golden Blonde 发表于 2020-7-4 03:17:21

还可以直接使用系统API。Attribute VB_Name = "ModGetCRC32"
'*************************************************************************
'**模块名：ModGetCRC32
'**说明：调用系统提供的API取CRC32值
'**创建人：嗷嗷叫的老马
'**日期：2008年9月29日
'**备注: 紫水晶工作室版权所有
'**       更多模块/类模块请访问我站:http://www.m5home.com
'**版本：V1.0
'*************************************************************************
Option Explicit

Private Declare Function RtlComputeCrc32 Lib "ntdll.dll" (ByVal dwInitial As Long, _
                                                         ByVal pData As Long, _
                                                         ByVal iLen As Long) As Long

Public Function GetFileCRC32(ByVal FileName As String) As Long
'取文件CRC32值
'ByVal FileName As String
'    文件名
'返回值:
'    成功,返回CRC32值,十六进制.
'    失败,返回空字符串
'备注:
'    需要与内存映射类模块cMapFile配合
' Dim lRet As Long, lpFileMemory As Long, lFileLen As Long, tmpMapFile As New cMapFile
' lpFileMemory = tmpMapFile.MapFile(FileName, lFileLen) '取得文件指针与文件长度
' If lpFileMemory = 0 Then Exit Function
' lRet = RtlComputeCrc32(0, lpFileMemory, lFileLen)
' GetFileCRC32 = lRet
'============
Dim buffer() As Byte: buffer = ReadBin(FileName)
If IsByteArrayEmpty(buffer) Then
   GetFileCRC32 = 0
Else
   GetFileCRC32 = RtlComputeCrc32(0, VarPtr(buffer(0)), UBound(buffer) + 1)
End If
End Function

Public Function GetStringCRC32(ByVal InString As String) As Long
'取字符串CRC32值
Dim lRet As Long, tBuff() As Byte
tBuff = StrConv(InString, vbFromUnicode)
lRet = RtlComputeCrc32(0, VarPtr(tBuff(0)), UBound(tBuff) + 1)
GetStringCRC32 = lRet
End Function

唐凌发表于 2020-7-4 22:45:38

我比较想说crc32需要区分算法，比方说我之前发过Castagnoli算法，并且SSE4.2就是算这玩意的。

0xAA55 发表于 2020-7-5 08:06:31

tangptr@126.com 发表于 2020-7-4 22:45
我比较想说crc32需要区分算法，比方说我之前发过Castagnoli算法，并且SSE4.2就是算这玩意的。 ...

因为我的CRC32算法就叫CRC32（比较标准），所以我就这样了。我就提供这个CRC32。

gujin163 发表于 2024-2-7 11:05:17

啥也不说了，帖子就是带劲！

tlwh163 发表于 2026-5-2 09:47:50

最近正好要鼓捣一个CRC32 那楼主的代码请教了AI 最后弄出来个这玩意

Option Explicit

Private Declare Sub GetMem4 Lib "msvbvm60" (Ptr As Any, RetVal As Long)

Private Function ShR1(ByVal Value As Long) As Long
ShR1 = (Value \ &H2&) And &H7FFFFFFF
End Function

Private Function ShR8(ByVal Value As Long) As Long
ShR8 = (Value \ &H100&) And &HFFFFFF
End Function

Private Function ShR16(ByVal Value As Long) As Long
ShR16 = (Value \ &H10000) And &HFFFF&
End Function

Private Function ShR24(ByVal Value As Long) As Long
ShR24 = (Value \ &H1000000) And &HFF&
End Function

Private Sub CRC32_GenTable(Table() As Long, Optional Polynomial As Long = &HEDB88320)
Dim I As Long, J As Long, C As Long, B As Long
For I = 0 To 255
   C = I
   For J = 0 To 7
         B = (C And 1)
         C = ShR1(C)
         If B Then C = C Xor Polynomial
   Next
   Table(I) = C
Next
For I = 0 To 255
   C = Table(I)
   C = ShR8(C) Xor Table(C And &HFF) : Table(256 * 1 + I) = C
   C = ShR8(C) Xor Table(C And &HFF) : Table(256 * 2 + I) = C
   C = ShR8(C) Xor Table(C And &HFF) : Table(256 * 3 + I) = C
Next
End Sub

Function CRC32(ByVal CRC As Long, Data() As Byte) As Long
Static Table(0 To 4 * 256 - 1) As Long
Static initialized As Boolean = False
If (initialized = False) Then
   CRC32_GenTable Table(), &HEDB88320
   initialized = True
End If
Dim I As Long : I = LBound(Data)
Dim N As Long : N = UBound(Data) - I + 1
Dim P As Long : P = VarPtr(Data(I))
Dim t As Long
CRC = CRC Xor &HFFFFFFFF
While N > 0 And (P And &H3&) <> 0 ' 4字节对齐
   CRC = Table((CRC Xor Data(I)) And &HFF&) Xor ShR8(CRC)
   I = I + 1
   P = P + 1
   N = N - 1
Wend
While N >= 4 ' 提高带宽每次处理4字节
   GetMem4 Byval P, t
   CRC = CRC Xor t
   CRC = Table(768 + (CRC And &HFF&)) Xor _
         Table(512 + (ShR8(CRC) And &HFF&)) Xor _
         Table(256 + (ShR16(CRC) And &HFF&)) Xor _
         Table(ShR24(CRC) And &HFF&)
   I = I + 4
   P = P + 4
   N = N - 4
Wend
While N > 0 ' 剩余字节
   CRC = Table((CRC Xor Data(I)) And &HFF&) Xor ShR8(CRC)
   I = I + 1
   N = N - 1
Wend
CRC32 = CRC Xor &HFFFFFFFF
End Function

YY菌 发表于 2026-5-15 09:18:43

tlwh163 发表于 2026-5-2 09:47
最近正好要鼓捣一个CRC32 那楼主的代码请教了AI 最后弄出来个这玩意

Option Explicit

ShR16 不如用 GetMem2直接读取 VarPtr(参数) + 2, Shr24 可以直接 GetMem1读取 VarPtr(参数) + 3。

tlwh163 发表于 2026-5-16 08:06:11

YY菌发表于 2026-5-15 09:18
ShR16 不如用 GetMem2直接读取 VarPtr(参数) + 2, Shr24 可以直接 GetMem1读取 VarPtr(参数) + 3。 ...

我觉得楼主的原意是想让编译器把整数除法优化成移位指令所以就依葫芦画瓢了

YY菌 发表于 2026-5-18 09:13:11

tlwh163 发表于 2026-5-16 08:06
我觉得楼主的原意是想让编译器把整数除法优化成移位指令所以就依葫芦画瓢了 ...

没有你想的那么简单
1.要是VB6有这能力，为啥本身不提供位移运算符？
2.只有无符号整数的右移才和除法一致，有符号的负数除法是向0取整，负数是向下取整。所以，编译器会认为除法优化成位移反而会导致结果有错，因此不会给你优化。

页: [1]

技术宅的结界's Archiver

【VB】VB6实现CRC32