【VB】VB6实现CRC32

0xAA55

1. Option Explicit
   
2. 
   
3. Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
   
4. 
   
5. Public g_CRC32_Table() As Long
   
6. 
   
7. Private Function ShR1(ByVal Value As Long) As Long
   
8. If Value >= 0 Then
   
9.     ShR1 = Value \ &H2&
   
10. Else
    
11.     ShR1 = ((Value And &H7FFFFFFF) \ &H2&) Or &H40000000
    
12. End If
    
13. End Function
    
14. 
    
15. Private Function ShR8(ByVal Value As Long) As Long
    
16. If Value >= 0 Then
    
17.     ShR8 = Value \ &H100&
    
18. Else
    
19.     ShR8 = ((Value And &H7FFFFFFF) \ &H100&) Or &H800000
    
20. End If
    
21. End Function
    
22. 
    
23. Private Sub CRC32_GenTable()
    
24. Erase g_CRC32_Table
    
25. ReDim g_CRC32_Table(255)
    
26. Dim I As Long, J As Long, Remainder As Long
    
27. Const Polynomial As Long = &HEDB88320
    
28. For I = 0 To 255
    
29.     Remainder = I
    
30.     For J = 0 To 7
    
31.         If Remainder And 1 Then
    
32.             Remainder = ShR1(Remainder) Xor Polynomial
    
33.         Else
    
34.             Remainder = ShR1(Remainder)
    
35.         End If
    
36.     Next
    
37.     g_CRC32_Table(I) = Remainder
    
38.     'Debug.Print Hex8(Remainder); ", ";
    
39.     'If I Mod 4 = 3 Then Debug.Print
    
40. Next
    
41. End Sub
    
42. 
    
43. Sub CRC32_Init()
    
44. On Local Error GoTo ErrHandler
    
45. Dim ByteArray() As Byte
    
46. ByteArray = LoadResData("CRC_TABLE", "BIN")
    
47. ReDim g_CRC32_Table((UBound(ByteArray) + 1) / 4 - 1)
    
48. CopyMemory g_CRC32_Table(0), ByteArray(0), UBound(ByteArray) + 1
    
49. Exit Sub
    
50. ErrHandler:
    
51. CRC32_GenTable
    
52. End Sub
    
53. 
    
54. Function CRC32(ByVal CRC As Long, Data() As Byte) As Long
    
55. On Local Error GoTo ErrHandler
    
56. Dim I As Long
    
57. Start:
    
58. 
    
59. CRC32 = Not CRC
    
60. 
    
61. For I = LBound(Data) To UBound(Data)
    
62.     CRC32 = g_CRC32_Table((CRC32 Xor Data(I)) And &HFF&) Xor ShR8(CRC32)
    
63. Next
    
64. 
    
65. CRC32 = Not CRC32
    
66. 
    
67. Exit Function
    
68. ErrHandler:
    
69. If Err.Number = 9 Then
    
70.     Err.Clear
    
71.     CRC32_Init
    
72.     GoTo Start
    
73. Else
    
74.     Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
    
75. End If
    
76. End Function

复制代码

其实CRC32需要的这个移位操作可以用整数除法实现。关键是：VB6的Long是有符号的，负数做除法的效果不同于移位，所以需要对负数做特殊处理。但总之，可以轻松实现。

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

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

crc_table.zip (1.16 KB, 下载次数: 9)

2020-7-1 07:15 上传

点击文件名下载附件

Golden Blonde

还可以直接使用系统API。

1. Attribute VB_Name = "ModGetCRC32"
   
2. '*************************************************************************
   
3. '**模 块 名：ModGetCRC32
   
4. '**说    明：调用系统提供的API取CRC32值
   
5. '**创 建 人：嗷嗷叫的老马
   
6. '**日    期：2008年9月29日
   
7. '**备    注: 紫水晶工作室 版权所有
   
8. '**          更多模块/类模块请访问我站:  http://www.m5home.com
   
9. '**版    本：V1.0
   
10. '*************************************************************************
    
11. Option Explicit
    
12. 
    
13. Private Declare Function RtlComputeCrc32 Lib "ntdll.dll" (ByVal dwInitial As Long, _
    
14.                                                             ByVal pData As Long, _
    
15.                                                             ByVal iLen As Long) As Long
    
16. 
    
17. Public Function GetFileCRC32(ByVal FileName As String) As Long
    
18.     '取文件CRC32值
    
19.     'ByVal FileName As String
    
20.     '       文件名
    
21.     '返回值:
    
22.     '       成功,返回CRC32值,十六进制.
    
23.     '       失败,返回空字符串
    
24.     '备注:
    
25.     '       需要与内存映射类模块cMapFile配合
    
26. '    Dim lRet As Long, lpFileMemory As Long, lFileLen As Long, tmpMapFile As New cMapFile
    
27. '    lpFileMemory = tmpMapFile.MapFile(FileName, lFileLen)   '取得文件指针与文件长度
    
28. '    If lpFileMemory = 0 Then Exit Function
    
29. '    lRet = RtlComputeCrc32(0, lpFileMemory, lFileLen)
    
30. '    GetFileCRC32 = lRet
    
31. '============
    
32.     Dim buffer() As Byte: buffer = ReadBin(FileName)
    
33.     If IsByteArrayEmpty(buffer) Then
    
34.         GetFileCRC32 = 0
    
35.     Else
    
36.         GetFileCRC32 = RtlComputeCrc32(0, VarPtr(buffer(0)), UBound(buffer) + 1)
    
37.     End If
    
38. End Function
    
39. 
    
40. Public Function GetStringCRC32(ByVal InString As String) As Long
    
41.     '取字符串CRC32值
    
42.     Dim lRet As Long, tBuff() As Byte
    
43.     tBuff = StrConv(InString, vbFromUnicode)
    
44.     lRet = RtlComputeCrc32(0, VarPtr(tBuff(0)), UBound(tBuff) + 1)
    
45.     GetStringCRC32 = lRet
    
46. End Function

复制代码

唐凌

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

0xAA55

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

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

gujin163

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

tlwh163

最近正好要鼓捣一个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