[Aporte] Des-Compresor de recursos

por Shermie80 Jue Ago 22, 2013 11:13 am

Para descargarlo Clic Aquí

Fuente:

por Rydzek 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

[Aporte] Des-Compresor de recursos

[Aporte] Des-Compresor de recursos

Re: [Aporte] Des-Compresor de recursos