[Aporte] Des-Compresor de recursos

Ir abajo

[Aporte] Des-Compresor de recursos

Mensaje por Shermie80 el Jue Ago 22, 2013 11:13 am

Para descargarlo Clic Aquí

Fuente:
Gs Zone
Shermie80
Shermie80



CoverAOStaff
Aportes : 55
Mensajes : 139
Puntos : 822
Edad : 22

Ver perfil de usuario http://todo-argentum.foroargentina.net

Volver arriba Ir abajo

Re: [Aporte] Des-Compresor de recursos

Mensaje por Rydzek el Jue Ago 22, 2013 8:12 pm

No sirve para comprimir :/. Osea, no tiene los botones Sad

Edit:
Este es el mod compression:
Código:
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 = resource_path & GRAPHIC_PATH
SourceFileExtension = ".bmp"
OutputFilePath = dest_path & "Graficos.iao"

Case Midi
SourceFilePath = resource_path & MIDI_PATH
SourceFileExtension = ".mid"
OutputFilePath = dest_path & "MIDI.iao"

Case MP3
SourceFilePath = resource_path & MP3_PATH
SourceFileExtension = ".mp3"
OutputFilePath = dest_path & "MP3.iao"

Case Wav
SourceFilePath = resource_path & WAV_PATH
SourceFileExtension = ".wav"
OutputFilePath = dest_path & "Sounds.iao"

Case Scripts
SourceFilePath = resource_path & SCRIPT_PATH
SourceFileExtension = ".*"
OutputFilePath = dest_path & "Init.iao"

Case Patch
SourceFilePath = resource_path & PATCH_PATH
SourceFileExtension = ".*"
OutputFilePath = dest_path & "Patch.iao"

Case Interface
SourceFilePath = resource_path & INTERFACE_PATH
SourceFileExtension = ".bmp"
OutputFilePath = dest_path & "Interface.iao"

Case Maps
SourceFilePath = resource_path & MAP_PATH
SourceFileExtension = ".csm"
OutputFilePath = dest_path & "Mapas.iao"
End Select

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

SourceFile = FreeFile

'Get all other files i nthe directory

While SourceFileName <> vbNullString

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) <> vbNullString 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 Extract_File(ByVal file_type As resource_file_type, _
ByVal resource_path As String, _
ByVal file_name As String, _
ByVal OutputFilePath As String, _
Optional ByVal UseOutputFolder As Boolean = False) As Boolean
'*****************************************************************
'Author: Juan Martín Dotuyo Dodero
'Last Modify Date: 10/13/2004
'Extracts all files from a resource file
'*****************************************************************

Dim loopc As Long
Dim SourceFilePath As String
Dim SourceData() As Byte
Dim InfoHead As INFOHEADER
Dim handle As Integer
Dim tempbyte As Byte

'Set up the error handler
On Local Error GoTo ErrHandler

Select Case file_type

Case Graphics

If UseOutputFolder Then
SourceFilePath = resource_path & OUTPUT_PATH & "Graficos.iao"
Else
SourceFilePath = resource_path & "\Graficos.iao"
End If

Case Midi

If UseOutputFolder Then
SourceFilePath = resource_path & OUTPUT_PATH & "MIDI.iao"
Else
SourceFilePath = resource_path & "\MIDI.iao"
End If

Case MP3

If UseOutputFolder Then
SourceFilePath = resource_path & OUTPUT_PATH & "MP3.iao"
Else
SourceFilePath = resource_path & "\MP3.iao"
End If

Case Wav

If UseOutputFolder Then
SourceFilePath = resource_path & OUTPUT_PATH & "Sounds.iao"
Else
SourceFilePath = resource_path & "\Sounds.iao"
End If

Case Scripts

If UseOutputFolder Then
SourceFilePath = resource_path & OUTPUT_PATH & "Init.iao"
Else
SourceFilePath = resource_path & "\Init.iao"
End If

Case Interface

If UseOutputFolder Then
SourceFilePath = resource_path & OUTPUT_PATH & "Interface.iao"
Else
SourceFilePath = resource_path & "\Interface.iao"
End If

Case Maps

If UseOutputFolder Then
SourceFilePath = resource_path & OUTPUT_PATH & "Mapas.iao"
Else
SourceFilePath = resource_path & "\Mapas.iao"
End If

Case Else

Exit Function

End Select

file_name = LCase$(file_name)

'Find the Info Head of the desired file
InfoHead = File_Find(SourceFilePath, file_name)

If InfoHead.strFileName = vbNullString Or InfoHead.lngFileSize = 0 Then Exit Function

'Open the binary file
handle = FreeFile
Open SourceFilePath For Binary Access Read Lock Write As handle

'Make sure there is enough space in the HD

If InfoHead.lngFileSizeUncompressed > General_Drive_Get_Free_Bytes(Left$(App.Path, 3)) Then
Close handle
MsgBox "There is not enough drive space to extract the compressed file.", , "Error"

Exit Function

End If

'Extract file from the binary file

'Resize the byte data array
ReDim SourceData(InfoHead.lngFileSize - 1)

'Get the data
Get handle, InfoHead.lngFileStart + 9, SourceData

'Decompress all data
Decompress_Data SourceData, InfoHead.lngFileSizeUncompressed

'Close the binary file
Close handle

'Get a free handler
handle = FreeFile

Open OutputFilePath & InfoHead.strFileName For Binary Access Write As handle

Put handle, 1, SourceData

Close handle

Erase SourceData

Extract_File = True

Exit Function

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

Public Function Extract_BMP_Memory(ByVal file_name As String, _
SourceData() As Byte) As Boolean
'*****************************************************************
'Author: Juan Martín Dotuyo Dodero
'Last Modify Date: 10/13/2004
'Extracts all files from a resource file
'*****************************************************************

Dim loopc As Long
Dim InfoHead As INFOHEADER
Dim handle As Integer

'Set up the error handler
On Local Error GoTo ErrHandler

'Find the Info Head of the desired file
InfoHead = File_Find(App.Path & "\Resources\Graficos.iao", file_name)

If InfoHead.strFileName = vbNullString Or InfoHead.lngFileSize = 0 Then Exit Function

'Open the binary file
handle = FreeFile
Open App.Path & "\Resources\Graficos.iao" For Binary Access Read Lock Write As handle

'Resize the byte data array
ReDim SourceData(InfoHead.lngFileSize - 1)

'Get the data
Get handle, InfoHead.lngFileStart + 9, SourceData

'Decompress all data
Decompress_Data SourceData, InfoHead.lngFileSizeUncompressed

'Close the binary file
Close handle

Extract_BMP_Memory = True

Exit Function

ErrHandler:
Close handle
Erase SourceData
End Function

Private Function File_Find(ByVal resource_file_path As String, _
ByVal file_name As String) As INFOHEADER
'**************************************************************
'Author: Juan Martín Sotuyo Dodero
'Last Modify Date: 5/04/2005
'Looks for a compressed file in a resource file. Uses binary search ;)
'**************************************************************

On Error GoTo ErrHandler

Dim max As Long 'Max index
Dim min As Long 'Min index
Dim mid As Long 'Middle index
Dim file_handler As Integer
Dim file_head As FILEHEADER
Dim info_head As INFOHEADER
Dim tempbyte As Byte

'Fill file name with spaces for compatibility

If Len(file_name) < Len(info_head.strFileName) Then file_name = file_name & Space$(Len(info_head.strFileName) - Len(file_name))

'Open resource file
file_handler = FreeFile
Open resource_file_path For Binary Access Read Lock Write As file_handler

Get file_handler, 1, tempbyte

'Get file head
Get file_handler, , file_head

Encrypt_File_Header file_head

Get file_handler, , tempbyte
Get file_handler, , tempbyte

min = 1
max = file_head.intNumFiles

Do While min <= max
mid = (min + max) / 2

'Get the info header of the appropiate compressed file
Get file_handler, CLng(Len(file_head) + CLng(Len(info_head)) * CLng((mid - 1)) + 1) + 3, info_head
Encrypt_Info_Header info_head

If file_name < info_head.strFileName Then
If max = mid Then
max = max - 1
Else
max = mid
End If

ElseIf file_name > info_head.strFileName Then

If min = mid Then
min = min + 1
Else
min = mid
End If

Else
'Copy info head
File_Find = info_head

'Close file and exit
Close file_handler

Exit Function

End If

Loop

ErrHandler:
'Close file
Close file_handler
File_Find.strFileName = vbNullString
File_Find.lngFileSize = 0
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
Rydzek
Rydzek



Aportes : 4
Mensajes : 25
Puntos : 39

Ver perfil de usuario

Volver arriba Ir abajo

Volver arriba

- Temas similares

 
Permisos de este foro:
No puedes responder a temas en este foro.