【VB】VB6实现CRC32
Option ExplicitPublic 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表。
还可以直接使用系统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 我比较想说crc32需要区分算法，比方说我之前发过Castagnoli算法，并且SSE4.2就是算这玩意的。 tangptr@126.com 发表于 2020-7-4 22:45
我比较想说crc32需要区分算法，比方说我之前发过Castagnoli算法，并且SSE4.2就是算这玩意的。 ...
因为我的CRC32算法就叫CRC32（比较标准），所以我就这样了。我就提供这个CRC32。 啥也不说了，帖子就是带劲！
页:
[1]