home *** CD-ROM | disk | FTP | other *** search
/ io Programmo 72 / IOPROG_72.ISO / tips / CRC32 / Crc32 / Module1.bas < prev    next >
Encoding:
BASIC Source File  |  2003-07-02  |  2.6 KB  |  115 lines
  1. Attribute VB_Name = "Module1"
  2. Option Explicit
  3.  
  4. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
  5.  
  6. Private crc32table(255) As Long
  7. Private Crc32TableSet As Boolean
  8.  
  9. Public Sub CreateTable(Optional lPolinomio As Long = &HEDB88320)
  10.   Dim I     As Long
  11.   Dim j     As Long
  12.   Dim lCrc  As Long
  13.   
  14.   For I = 1 To 255 Step 1
  15.     lCrc = I
  16.     j = 8
  17.     
  18.     For j = 1 To 8 Step 1
  19.       If (lCrc And 1) Then
  20.         lCrc = ((lCrc And &HFFFFFFFE) \ 2&) And &H7FFFFFFF
  21.         lCrc = lCrc Xor lPolinomio
  22.       Else
  23.         lCrc = ((lCrc And &HFFFFFFFE) \ 2&) And &H7FFFFFFF
  24.       End If
  25.     Next
  26.     
  27.     crc32table(I) = lCrc
  28. Next I
  29.  
  30.     Crc32TableSet = True
  31.     
  32. End Sub
  33.  
  34. Public Function CalcCRC32(ByteArr() As Byte) As Long
  35.   Dim I As Long
  36.   Dim CRC32Val As Long
  37.   Dim ArrLen As Long
  38.   Dim LongBytes(3) As Byte
  39.   
  40.   If (Not Crc32TableSet) Then CreateTable
  41.   
  42.   CRC32Val = -1
  43.   ArrLen = UBound(ByteArr())
  44.   
  45.   For I = 0 To ArrLen Step 1
  46.       SplitLongValues CRC32Val, LongBytes(): LongBytes(3) = 0
  47.       CRC32Val = crc32table((CRC32Val Xor ByteArr(I)) And &HFF)
  48.       CRC32Val = CRC32Val Xor MergeLongValues(LongBytes())
  49.   Next
  50.   
  51.   CalcCRC32 = CRC32Val
  52. End Function
  53.  
  54. Public Function CalcCRC32FromString(sStr As String) As Long
  55. Dim bArr() As Byte, I As Long
  56.  
  57.     If Len(sStr) > 0 Then
  58.     
  59.         ReDim bArr(0 To (Len(sStr) - 1)) As Byte
  60.     
  61.         For I = 1 To Len(sStr) Step 1
  62.             bArr(I - 1) = Asc(Mid(sStr, I, 1))
  63.         Next
  64.         
  65.         CalcCRC32FromString = CalcCRC32(bArr())
  66.         
  67.     End If
  68.     
  69. End Function
  70.  
  71. Public Function CalcCRC32FromFile(sFile As String) As Long
  72. On Local Error Resume Next
  73.  
  74. Dim bArr() As Byte, I As Long, L As Long
  75.  
  76.     If FileLen(sFile) > 0 Then
  77.         If Err <> 0 Then Err = 0: Exit Function
  78.     
  79.         ReDim bArr(0 To (FileLen(sFile) - 1)) As Byte
  80.     
  81.         L = FreeFile()
  82.         Open sFile For Binary As L
  83.             Get L, , bArr()
  84.         Close L
  85.         
  86.         CalcCRC32FromFile = CalcCRC32(bArr())
  87.         
  88.     End If
  89.     
  90. End Function
  91.  
  92. Public Sub SplitLongValues(lValue As Long, ByteArr() As Byte)
  93.  
  94.     CopyMemory ByteArr(0), lValue, 4
  95.  
  96. End Sub
  97.  
  98. Public Sub SplitIntegerValues(iValue As Integer, ByteArr() As Byte)
  99.  
  100.     CopyMemory ByteArr(0), lValue, 2
  101.  
  102. End Sub
  103.  
  104. Public Function MergeLongValues(ByteArr() As Byte) As Long
  105.  
  106.     CopyMemory MergeLongValues, ByteArr(0), 4
  107.  
  108. End Function
  109.  
  110. Public Function MergeIntegerValues(ByteArr() As Byte) As Integer
  111.  
  112.     CopyMemory MergeIntegerValues, ByteArr(0), 2
  113.  
  114. End Function
  115.