|
|
|
|
|
|
|
|
Dicas
|
|
|
Visual Basic (Datas/Números/Strings)
|
|
 |
Título da Dica: Compactando texto com ZLib
|
 |
|
|
|
Postada em 19/10/2003 por ^HEAVY-METAL^
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function ZCompress Lib "zlib.dll" Alias "compress" (dest As Any, destLen As Any, src As Any, ByVal srcLen As Long) As Long
Private Declare Function ZUncompress Lib "zlib.dll" Alias "uncompress" (dest As Any, destLen As Any, src As Any, ByVal srcLen As Long) As Long
Public Sub Example()
Dim sTmp As String
Dim lKey As Long
sTmp = Compress("This is a test.")
Debug.Print Len(sTmp), Len(Uncompress(sTmp))
sTmp = Compress("This is a test.", lKey)
Debug.Print Len(sTmp), Len(Uncompress(sTmp, lKey))
sTmp = vbNullString
End Sub
Public Function Compress(Data, Optional Key)
Dim lKey As Long 'original size
Dim sTmp As String 'String buffer
Dim bData() As Byte 'data buffer
Dim bRet() As Byte 'Output buffer
Dim lCSz As Long 'compressed size
If TypeName(Data) = "Byte()" Then 'If given Byte array data
bData = Data 'copy To data buffer
ElseIf TypeName(Data) = "String" Then 'If given String data
If Len(Data) > 0 Then 'If there Is data
sTmp = Data 'copy To String buffer
ReDim bData(Len(sTmp) - 1) 'allocate data buffer
CopyMemory bData(0), ByVal sTmp, Len(sTmp) 'copy To data buffer
sTmp = vbNullString 'deallocate String buffer
End If
End If
If StrPtr(bData) <> 0 Then 'If data buffer contains data
lKey = UBound(bData) + 1 'Get data size
lCSz = lKey + (lKey * 0.01) + 12 'estimate compressed size
ReDim bRet(lCSz - 1) 'allocate Output buffer
Call ZCompress(bRet(0), lCSz, bData(0), lKey) 'compress data (lCSz returns actual size)
ReDim Preserve bRet(lCSz - 1) 'resize Output buffer To actual size
Erase bData 'deallocate data buffer
If IsMissing(Key) Then 'If Key variable Not supplied
ReDim bData(lCSz + 3) 'allocate data buffer
CopyMemory bData(0), lKey, 4 'copy key To buffer
CopyMemory bData(4), bRet(0), lCSz 'copy data To buffer
Erase bRet 'deallocate Output buffer
bRet = bData 'copy To Output buffer
Erase bData 'deallocate data buffer
Else 'Key variable Is supplied
Key = lKey 'Set Key variable
End If
If TypeName(Data) = "Byte()" Then 'If given Byte array data
Compress = bRet 'Return Output buffer
ElseIf TypeName(Data) = "String" Then 'If given String data
sTmp = Space(UBound(bRet) + 1) 'allocate String buffer
CopyMemory ByVal sTmp, bRet(0), UBound(bRet) + 1 'copy To String buffer
Compress = sTmp 'Return String buffer
sTmp = vbNullString 'deallocate String buffer
End If
Erase bRet 'deallocate Output buffer
End If
End Function
Public Function Uncompress(Data, Optional ByVal Key)
Dim lKey As Long 'original size
Dim sTmp As String 'String buffer
Dim bData() As Byte 'data buffer
Dim bRet() As Byte 'Output buffer
Dim lCSz As Long 'compressed size
If TypeName(Data) = "Byte()" Then 'If given Byte array data
bData = Data 'copy To data buffer
ElseIf TypeName(Data) = "String" Then 'If given String data
If Len(Data) > 0 Then 'If there Is data
sTmp = Data 'copy To String buffer
ReDim bData(Len(sTmp) - 1) 'allocate data buffer
CopyMemory bData(0), ByVal sTmp, Len(sTmp) 'copy To data buffer
sTmp = vbNullString 'deallocate String buffer
End If
End If
If StrPtr(bData) <> 0 Then 'If there Is data
If IsMissing(Key) Then 'If Key variable Not supplied
lCSz = UBound(bData) - 3 'Get actual data size
CopyMemory lKey, bData(0), 4 'copy key value To key
ReDim bRet(lCSz - 1) 'allocate Output buffer
CopyMemory bRet(0), bData(4), lCSz 'copy data To Output buffer
Erase bData 'deallocate data buffer
bData = bRet 'copy To data buffer
Erase bRet 'deallocate Output buffer
Else 'Key variable Is supplied
lCSz = UBound(bData) + 1 'Get data size
lKey = Key 'Get Key
End If
ReDim bRet(lKey - 1) 'allocate Output buffer
Call ZUncompress(bRet(0), lKey, bData(0), lCSz) 'decompress To Output buffer
Erase bData 'deallocate data buffer
If TypeName(Data) = "Byte()" Then 'If given Byte array data
Uncompress = bRet 'Return Output buffer
ElseIf TypeName(Data) = "String" Then 'If given String data
sTmp = Space(lKey) 'allocate String buffer
CopyMemory ByVal sTmp, bRet(0), lKey 'copy To String buffer
Uncompress = sTmp 'Return String buffer
sTmp = vbNullString 'deallocate String buffer
End If
Erase bRet 'deallocate Return buffer
End If
End Function
T+,
|
|
|
|
|
