home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 7_2009-2012.ISO / data / zips / Remote_Des21926411122010.psc / RemoteDesktop / class / clsZLib.cls < prev   
Text File  |  2010-11-12  |  9KB  |  281 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "clsZLib"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = False
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. '<CSCC>
  15. '--------------------------------------------------------------------------------
  16. '    Component  : clsZLib
  17. '    Project    : NetRemote
  18. '    Author     : B2qid www.labsoft.web.id
  19. '    Description: {ParamList}
  20. '
  21. '    Modified   : 11/12/2010 2:52:18 PM
  22. '--------------------------------------------------------------------------------
  23. '</CSCC>
  24. Option Explicit
  25.  
  26. 'Property Variables
  27. Private m_CompressedSize As Long
  28. Private m_OriginalSize As Long
  29. Private m_CRC As Long
  30.  
  31. 'Declares
  32. Private Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" (ByVal hwnd As Long, ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long
  33. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
  34. Private Declare Function compress Lib "zlib.dll" (dest As Any, destLen As Any, src As Any, ByVal srcLen As Long) As Long
  35. Private Declare Function uncompress Lib "zlib.dll" (dest As Any, destLen As Any, src As Any, ByVal srcLen As Long) As Long
  36. Private Declare Function crc32 Lib "zlib.dll" (ByVal CRC As Long, buf As Byte, ByVal buf_len As Long) As Long
  37. Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
  38. Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
  39.  
  40. Public Function CompressByte(ByteArray() As Byte) As Boolean
  41.  
  42.   Dim BufferSize As Long
  43.   Dim TempBuffer() As Byte
  44.   
  45.   'Create a buffer to hold the compressed data
  46.   BufferSize = UBound(ByteArray) + 1
  47.   BufferSize = BufferSize + (BufferSize * 0.01) + 12
  48.   ReDim TempBuffer(BufferSize)
  49.  
  50.   'Compress byte array (data)
  51.   CompressByte = (compress(TempBuffer(0), BufferSize, ByteArray(0), UBound(ByteArray) + 1) = 0)
  52.  
  53.   'Add the size of the original data
  54.   Call CopyMem(ByteArray(0), CLng(UBound(ByteArray) + 1), 4)
  55.   
  56.   'Remove redundant data
  57.   ReDim Preserve ByteArray(0 To BufferSize + 4 - 1)
  58.   Call CopyMem(ByteArray(4), TempBuffer(0), BufferSize)
  59.   
  60. End Function
  61. Public Sub CompressFile(SourceFilename As String, DestFilename As String)
  62.  
  63.   Dim Filenr As Integer
  64.   Dim ByteArray() As Byte
  65.   
  66.   'Read the data in the sourcefile
  67.   Filenr = FreeFile
  68.   Open SourceFilename For Binary As #Filenr
  69.   ReDim ByteArray(0 To LOF(Filenr) - 1)
  70.   Get #Filenr, , ByteArray()
  71.   Close #Filenr
  72.   
  73.   'Compress the bytearray
  74.   Call CompressByte(ByteArray())
  75.   
  76.   'Store the data in the destfile
  77.   Filenr = FreeFile
  78.   Open DestFilename For Output As #Filenr: Close #Filenr
  79.   Open DestFilename For Binary As #Filenr
  80.   Put #Filenr, , ByteArray()
  81.   Close #Filenr
  82.   
  83. End Sub
  84.  
  85. Public Property Get CompressedSize() As Long
  86.     
  87.   CompressedSize = m_CompressedSize
  88.  
  89. End Property
  90. Public Function CompressString(Text As String) As String
  91.  
  92.   Dim CmpSize As Long
  93.   Dim CmpByte() As Byte
  94.   Dim ByteArray() As Byte
  95.   
  96.   'Convert the string into a byte array
  97.   ByteArray() = StrConv(Text, vbFromUnicode)
  98.   
  99.   'Create a buffer to contain the compressed data
  100.   '(worst case scenario is 1% added and 12 bytes)
  101.   CmpSize = 4 + Len(Text) + (Len(Text) * 0.01) + 12
  102.   ReDim CmpByte(0 To CmpSize)
  103.   
  104.   'Compress the source string into the temp buffer
  105.   Call compress(CmpByte(4), CmpSize, ByteArray(0), Len(Text))
  106.  
  107.   'Add the size of the original text
  108.   Call CopyMem(CmpByte(0), CLng(Len(Text)), 4)
  109.   
  110.   'Remove any redundant data
  111.   ReDim Preserve CmpByte(0 To CmpSize + 4 - 1)
  112.   
  113.   'Convert the byte array into a string
  114.   CompressString = StrConv(CmpByte(), vbUnicode)
  115.  
  116. End Function
  117. Public Property Let CRC(New_Value As Long)
  118.  
  119.   m_CRC = New_Value
  120.   
  121. End Property
  122.  
  123. Public Property Get CRC() As Long
  124.  
  125.   CRC = m_CRC
  126.   
  127. End Property
  128.  
  129. Public Function CRCArray(ByteArray() As Byte, Size As Long, Optional CRC As Variant) As Long
  130.  
  131.   If Not IsMissing(CRC) Then m_CRC = CRC
  132.   m_CRC = crc32(m_CRC, ByteArray(0), Size)
  133.   CRCArray = m_CRC
  134.  
  135. End Function
  136. Public Function CRCString(Value As String, Size As Long, Optional CRC As Variant) As Long
  137.  
  138.   Dim ByteArray() As Byte
  139.   
  140.   ReDim ByteArray(Size - 1)
  141.   Call CopyMem(ByteArray(0), ByVal Value, Size)
  142.   
  143.   If Not IsMissing(CRC) Then m_CRC = CRC
  144.   m_CRC = crc32(m_CRC, ByteArray(0), Size)
  145.   CRCString = m_CRC
  146.  
  147. End Function
  148. Public Function CRCFile(Filename As String, Optional BufferSize As Long = 100000) As Long
  149.  
  150.   Dim Buffer() As Byte
  151.   Dim FileSize As Long
  152.   Dim Filenr As Integer
  153.   Dim BytesRead As Long
  154.   Dim lngActualBytesRead As Long
  155.   
  156.   m_CRC = 0
  157.   Filenr = FreeFile
  158.   Open Filename For Binary Access Read As #Filenr
  159.   FileSize = LOF(Filenr)
  160.   
  161.   'While there is still data in the file
  162.   Do Until (FileSize = BytesRead)
  163.     If (BytesRead + 1 + BufferSize < FileSize) Then
  164.       lngActualBytesRead = BufferSize
  165.     ElseIf (FileSize - BytesRead > 0) Then
  166.       ' If we are attempting to read more data than is left in the file,
  167.       ' calculate how much data we should read
  168.       lngActualBytesRead = FileSize - BytesRead
  169.     End If
  170.     
  171.     'Read the data
  172.     ReDim Buffer(lngActualBytesRead - 1)
  173.     Get #Filenr, , Buffer
  174.     
  175.     m_CRC = crc32(m_CRC, Buffer(0), lngActualBytesRead)
  176.     
  177.     'Get the total amount of the file that has been processed
  178.     BytesRead = BytesRead + lngActualBytesRead
  179.     
  180.     'Raise the progress
  181.     'RaiseEvent Progress(lngBytesRead / lngFileLength)
  182.     'DoEvents
  183.   Loop
  184.  
  185.   CRCFile = m_CRC
  186.   
  187. End Function
  188. Public Sub DecompressByte(TheData() As Byte)
  189.  
  190.   Dim OrigLen As Long
  191.   Dim BufferSize As Long
  192.   Dim TempBuffer() As Byte
  193.  
  194.   'Get the original size
  195.   Call CopyMem(OrigLen, TheData(0), 4)
  196.   
  197.   'Create a buffer to hold the uncompressed data
  198.   BufferSize = OrigLen
  199.   BufferSize = BufferSize + (BufferSize * 0.01) + 12
  200.   ReDim TempBuffer(BufferSize)
  201.  
  202.   'Decompress data
  203.   Call uncompress(TempBuffer(0), BufferSize, TheData(4), UBound(TheData) - 4 + 1)
  204.  
  205.   'Remove redundant data
  206.   ReDim Preserve TheData(0 To BufferSize - 1)
  207.   CopyMemory TheData(0), TempBuffer(0), BufferSize
  208.  
  209. End Sub
  210. Public Function DecompressString(Text As String) As String
  211.  
  212.   Dim OrigLen As Long
  213.   Dim OrigByte() As Byte
  214.   Dim BufferSize As Long
  215.   Dim ByteArray() As Byte
  216.   
  217.   'Convert the string into a bytearray
  218.   ByteArray() = StrConv(Text, vbFromUnicode)
  219.   
  220.   'Extract the OrigLen value from the data
  221.   Call CopyMem(OrigLen, ByteArray(0), 4)
  222.   BufferSize = OrigLen + (OrigLen * 0.01) + 12
  223.   ReDim OrigByte(0 To BufferSize)
  224.   
  225.   'Decompress the data
  226.   Call uncompress(OrigByte(0), BufferSize, ByteArray(4), UBound(ByteArray) - 3)
  227.   If (BufferSize <> OrigLen) Then Stop
  228.   
  229.   'Remove redundant information
  230.   ReDim Preserve OrigByte(0 To OrigLen - 1)
  231.   
  232.   'Return the decompressed data in string format
  233.   DecompressString = StrConv(OrigByte(), vbUnicode)
  234.  
  235. '  'Allocate string space
  236. '  Dim CmpSize As Long
  237. '  Dim TBuff As String
  238. '
  239. '  TBuff = String(OriginalSize + (OriginalSize * 0.01) + 12, 0)
  240. '  CmpSize = Len(TBuff)
  241. '
  242. '  'Decompress
  243. '  DecompressString = (uncompress(ByVal TBuff, CmpSize, ByVal TheString, Len(TheString)) = 0)
  244. '
  245. '  'Make string the size of the uncompressed string
  246. '  TheString = Left$(TBuff, CmpSize)
  247. '
  248. '  'Reset properties
  249. '  If DecompressString Then
  250. '    m_CompressedSize = 0
  251. '    m_OriginalSize = 0
  252. '  End If
  253.  
  254. End Function
  255. Public Property Get OriginalSize() As Long
  256.  
  257.   OriginalSize = m_OriginalSize
  258.  
  259. End Property
  260.  
  261. Private Sub Class_Initialize()
  262.  
  263.   Dim ByteArray() As Byte
  264.   Dim Filenr As Integer
  265.   
  266. '  If (Len(Dir$(WinSysDir & "Zlib.dll", vbSystem + vbHidden)) = 0) Then
  267. '    Call MsgBox("ZLib DLL will be added to the " & WinSysDir & " directory.", vbOKOnly + vbInformation)
  268. '    ByteArray = LoadResData(101, "DLL")
  269. '    Filenr = FreeFile
  270. '    Open WinSysDir & "Zlib.dll" For Binary As #Filenr
  271. '    Put #Filenr, , ByteArray
  272. '    Close #Filenr
  273. '  End If
  274.   
  275. End Sub
  276.  
  277. Private Function WinSysDir() As String
  278.  
  279.   Dim t As String * 500
  280.   
  281.   WinSysDir = Left$(t, GetSystemDirectory(t, Len(t)  Byte) As Long Close #Fib(t,btFilenr As Integerction CRCStriiu)Dec+D unarArrayiiuuuff, CmpSiz