[Problema] Carga de recursos comprimidos IAO Clon

Option Explicit

'This structure will describe our binary file's
'size and number of contained files
Public Type FILEHEADER
lngFileSize As Long 'How big is this file? (Used to check integrity)
intNumFiles As Integer 'How many files are inside?
End Type

'This structure will describe each file contained
'in our binary file
Public Type INFOHEADER
lngFileStart As Long 'Where does the chunk start?
lngFileSize As Long 'How big is this chunk of stored data?
strFileName As String * 32 'What's the name of the file this data came from?
lngFileSizeUncompressed As Long 'How big is the file compressed
End Type

Public Enum resource_file_type
Graphics
Midi
MP3
Wav
Scripts
Patch
Interface
Maps
End Enum

Public Const GRAPHIC_PATH As String = "\Recursos\Graficos\"
Public Const MIDI_PATH As String = "\Recursos\Midi\"
Public Const MP3_PATH As String = "\Recursos\Mp3\"
Public Const WAV_PATH As String = "\Recursos\Wav\"
Public Const MAP_PATH As String = "\Recursos\Mapas\"
Public Const INTERFACE_PATH As String = "\Recursos\Interface\"
Public Const SCRIPT_PATH As String = "\Recursos\Init\"
Public Const PATCH_PATH As String = "\Recursos\Patches\"
Public Const OUTPUT_PATH As String = "\Output\"

Private Declare Function Compress Lib "zlib.dll" Alias "compress" (dest As Any, destLen As Any, src As Any, ByVal srcLen As Long) As Long
Private Declare Function UnCompress Lib "zlib.dll" Alias "uncompress" (dest As Any, destLen As Any, src As Any, ByVal srcLen As Long) As Long
'To get free bytes in drive
Private Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceExA" (ByVal lpRootPathName As String, FreeBytesToCaller As Currency, BytesTotal As Currency, FreeBytesTotal As Currency) As Long

Public Sub Compress_Data(ByRef data() As Byte)
'*****************************************************************
'Author: Juan Martín Dotuyo Dodero
'Last Modify Date: 10/13/2004
'Compresses binary data avoiding data loses
'*****************************************************************
Dim Dimensions As Long
Dim DimBuffer As Long
Dim BufTemp() As Byte
Dim BufTemp2() As Byte
Dim loopc As Long

'Get size of the uncompressed data
Dimensions = UBound(data)

'Prepare a buffer 1.06 times as big as the original size
DimBuffer = Dimensions * 1.06
ReDim BufTemp(DimBuffer)

'Compress data using zlib
Compress BufTemp(0), DimBuffer, data(0), Dimensions

'Deallocate memory used by uncompressed data
Erase data

'Get rid of unused bytes in the compressed data buffer
ReDim Preserve BufTemp(DimBuffer - 1)

'Copy the compressed data buffer to the original data array so it will return to caller
data = BufTemp

'Deallocate memory used by the temp buffer
Erase BufTemp

'Encrypt the first byte of the compressed data for extra security
data(0) = data(0) Xor 189
End Sub

Public Sub Encrypt_File_Header(ByRef FileHead As FILEHEADER)
'*****************************************************************
'Author: Juan Martín Dotuyo Dodero
'Last Modify Date: 10/13/2004
'Encrypts normal data or turns encrypted data back to normal
'*****************************************************************
'Each different variable is encrypted with a different key for extra security
With FileHead
.intNumFiles = .intNumFiles Xor 4725
.lngFileSize = .lngFileSize Xor 2435437
End With
End Sub

Public Sub Encrypt_Info_Header(ByRef InfoHead As INFOHEADER)
'*****************************************************************
'Author: Juan Martín Dotuyo Dodero
'Last Modify Date: 10/13/2004
'Encrypts normal data or turns encrypted data back to normal
'*****************************************************************
Dim EncryptedFileName As String
Dim loopc As Long

For loopc = 1 To Len(InfoHead.strFileName)
If loopc Mod 2 = 0 Then
EncryptedFileName = EncryptedFileName & Chr$(Asc(Mid$(InfoHead.strFileName, loopc, 1)) Xor 161)
Else
EncryptedFileName = EncryptedFileName & Chr$(Asc(Mid$(InfoHead.strFileName, loopc, 1)) Xor 47)
End If
Next loopc

'Each different variable is encrypted with a different key for extra security
With InfoHead
.lngFileSize = .lngFileSize Xor 689947
.lngFileSizeUncompressed = .lngFileSizeUncompressed Xor 445275
.lngFileStart = .lngFileStart Xor 87540
.strFileName = EncryptedFileName
End With
End Sub

Public Function Compress_Files(ByVal file_type As resource_file_type, ByVal resource_path As String, ByVal dest_path As String) As Boolean
'*****************************************************************
'Author: Juan Martín Dotuyo Dodero
'Last Modify Date: 10/13/2004
'Comrpesses all files to a resource file
'*****************************************************************
Dim SourceFilePath As String
Dim SourceFileExtension As String
Dim OutputFilePath As String
Dim SourceFile As Long
Dim OutputFile As Long
Dim SourceFileName As String
Dim SourceData() As Byte
Dim FileHead As FILEHEADER
Dim InfoHead() As INFOHEADER
Dim FileNames() As String
Dim lngFileStart As Long
Dim loopc As Long

'Set up the error handler
On Local Error GoTo ErrHandler

Select Case file_type
Case Graphics
SourceFilePath = App.Path & resource_path
SourceFileExtension = ".bmp"
OutputFilePath = App.Path & dest_path & "Graficos.oao"

Case Midi
SourceFilePath = App.Path & resource_path
SourceFileExtension = ".mid"
OutputFilePath = App.Path & dest_path & "MIDI.oao"

Case MP3
SourceFilePath = App.Path & resource_path
SourceFileExtension = ".mp3"
OutputFilePath = App.Path & dest_path & "MP3.oao"

Case Wav
SourceFilePath = App.Path & resource_path
SourceFileExtension = ".wav"
OutputFilePath = App.Path & dest_path & "Sounds.oao"

Case Scripts
SourceFilePath = App.Path & resource_path
SourceFileExtension = ".*"
OutputFilePath = App.Path & dest_path & "Init.oao"

Case Patch
SourceFilePath = App.Path & resource_path
SourceFileExtension = ".*"
OutputFilePath = App.Path & dest_path & "Patch.oao"

Case Interface
SourceFilePath = App.Path & resource_path
SourceFileExtension = ".jpg"
OutputFilePath = App.Path & dest_path & "Interface.oao"

Case Maps
SourceFilePath = App.Path & resource_path
SourceFileExtension = ".csm"
OutputFilePath = App.Path & dest_path & "Mapas.oao"
End Select

'Get first file in the directoy
SourceFileName = Dir$(SourceFilePath & "*" & SourceFileExtension, vbNormal)

SourceFile = FreeFile

'Get all other files i nthe directory
While SourceFileName <> ""
FileHead.intNumFiles = FileHead.intNumFiles + 1

ReDim Preserve FileNames(FileHead.intNumFiles - 1)
FileNames(FileHead.intNumFiles - 1) = LCase(SourceFileName)

'Search new file
SourceFileName = Dir$()
Wend

'If we found none, be can't compress a thing, so we exit
If FileHead.intNumFiles = 0 Then
MsgBox "There are no files of extension " & SourceFileExtension & " in " & SourceFilePath & ".", , "Error"
Exit Function
End If

'Sort file names alphabetically (this will make patching much easier).
General_Quick_Sort FileNames(), 0, UBound(FileNames)

'Resize InfoHead array
ReDim InfoHead(FileHead.intNumFiles - 1)

'Destroy file if it previuosly existed
If Dir(OutputFilePath, vbNormal) <> "" Then
Kill OutputFilePath
End If

'Open a new file
OutputFile = FreeFile
Open OutputFilePath For Binary Access Read Write As OutputFile

For loopc = 0 To FileHead.intNumFiles - 1
'Find a free file number to use and open the file
SourceFile = FreeFile
Open SourceFilePath & FileNames(loopc) For Binary Access Read Lock Write As SourceFile

'Store file name
InfoHead(loopc).strFileName = FileNames(loopc)

'Find out how large the file is and resize the data array appropriately
ReDim SourceData(LOF(SourceFile) - 1)

'Store the value so we can decompress it later on
InfoHead(loopc).lngFileSizeUncompressed = LOF(SourceFile)

'Get the data from the file
Get SourceFile, , SourceData

'Compress it
'Compress_Data SourceData

'Save it to a temp file
Put OutputFile, , SourceData

'Set up the file header
FileHead.lngFileSize = FileHead.lngFileSize + UBound(SourceData) + 1

'Set up the info headers
InfoHead(loopc).lngFileSize = UBound(SourceData) + 1

Erase SourceData

'Close temp file
Close SourceFile

DoEvents
Next loopc

'Finish setting the FileHeader data
FileHead.lngFileSize = FileHead.lngFileSize + CLng(FileHead.intNumFiles) * Len(InfoHead(0)) + Len(FileHead)

'Set InfoHead data
lngFileStart = Len(FileHead) + CLng(FileHead.intNumFiles) * Len(InfoHead(0)) + 1
For loopc = 0 To FileHead.intNumFiles - 1
InfoHead(loopc).lngFileStart = lngFileStart
lngFileStart = lngFileStart + InfoHead(loopc).lngFileSize
'Once an InfoHead index is ready, we encrypt it
Encrypt_Info_Header InfoHead(loopc)
Next loopc

'Encrypt the FileHeader
Encrypt_File_Header FileHead

'************ Write Data

'Get all data stored so far
ReDim SourceData(LOF(OutputFile) - 1)
Seek OutputFile, 1
Get OutputFile, , SourceData

Seek OutputFile, 1

'Store the data in the file
Put OutputFile, , FileHead
Put OutputFile, , InfoHead
Put OutputFile, , SourceData

'Close the file
Close OutputFile

Erase InfoHead
Erase SourceData
Exit Function

ErrHandler:
Erase SourceData
Erase InfoHead
'Display an error message if it didn't work
MsgBox "Unable to create binary file. Reason: " & Err.Number & " : " & Err.Description, vbOKOnly, "Error"
End Function

Public Function General_Drive_Get_Free_Bytes(ByVal DriveName As String) As Currency
'**************************************************************
'Author: Juan Martín Sotuyo Dodero
'Last Modify Date: 6/07/2004
'
'**************************************************************
Dim RetVal As Long
Dim FB As Currency
Dim BT As Currency
Dim FBT As Currency

RetVal = GetDiskFreeSpace(Left(DriveName, 2), FB, BT, FBT)

General_Drive_Get_Free_Bytes = FB * 10000 'convert result to actual size in bytes
End Function

Public Sub General_Quick_Sort(ByRef SortArray As Variant, ByVal first As Long, ByVal last As Long)
'**************************************************************
'Author: juan Martín Sotuyo Dodero
'Last Modify Date: 3/03/2005
'Good old QuickSort algorithm
'**************************************************************
Dim Low As Long, High As Long
Dim temp As Variant
Dim List_Separator As Variant

Low = first
High = last
List_Separator = SortArray((first + last) / 2)
Do While (Low <= High)
Do While SortArray(Low) < List_Separator
Low = Low + 1
Loop
Do While SortArray(High) > List_Separator
High = High - 1
Loop
If Low <= High Then
temp = SortArray(Low)
SortArray(Low) = SortArray(High)
SortArray(High) = temp
Low = Low + 1
High = High - 1
End If
Loop
If first < High Then General_Quick_Sort SortArray, first, High
If Low < last Then General_Quick_Sort SortArray, Low, last
End Sub

Public Sub Delete_File(ByVal file_path As String)
'*****************************************************************
'Author: Juan Martín Dotuyo Dodero
'Last Modify Date: 3/03/2005
'Deletes a resource files
'*****************************************************************
Dim handle As Integer
Dim data() As Byte

On Error GoTo Error_Handler

'We open the file to delete
handle = FreeFile
Open file_path For Binary Access Write Lock Read As handle

'We replace all the bytes in it with 0s
ReDim data(LOF(handle) - 1)
Put handle, 1, data

'We close the file
Close handle

'Now we delete it, knowing that if they retrieve it (some antivirus may create backup copies of deleted files), it will be useless
Kill file_path

Exit Sub

Error_Handler:
Kill file_path
End Sub