Attribute VB_Name = "PAK" Option Explicit ' ------------------------------------------------------------------------------ ' ' Title: Rob's File Packer ' Author: Rob Loach ' Date: January 06, 2003 ' Purpose: This module is used to pack files into one single file pack and ' easily extract them. This does not encrypt or compress. That ' feature may be added in later though. ' Copyright: 2003 Rob Loach ' ' ------------------------------------------------------------------------------ ' ------------------------------------------------------------------------------ ' ' PROPERTIES, CONSTANTS, VARIABLES, AND TYPES ' ' ------------------------------------------------------------------------------ 'Private PAKFile As String ' The Header is what is put at the beginning of the PAK file. ' It is recommended that you leave this as is. Private Const Header As String = "OTPak " ' The collection of files in the PAK file. Public PAKFileList As New Collection ' ------------------------------------------------------------------------------ ' ' FUNCTIONS ' ' ------------------------------------------------------------------------------ Public Function PAKOpen(FileName As String) As Boolean ' Opens and initiates a PAK file for editing or viewing. ' FileName The full file path of the file you would like to open. Dim FileNumber As Long Dim FileListStart As Long Dim CurrentFileOffset As Long Dim CurrentFileSize As Long Dim CurrentFileName As String 'On Error GoTo Erro ' Reset the file information On Error Resume Next For FileNumber = 1 To PAKFileList.Count PAKFileList.Remove (FileNumber) Next On Error GoTo 0 'Check if is a valid PAK file If PAKValid(FileName) = True Then PAKOpen = True FileNumber = FreeFile Open FileName For Binary As FileNumber 'Is a valid PAK file 'Get the PAKFileList Get FileNumber, 7, FileListStart If FileListStart = 0 Then 'MessageBox "Empy file!", OKOnly, Information Close FileNumber Exit Function Else 'PAKFile = FileName 'Toolbar.Buttons(4).Enabled = True 'Add the FileName, CurrentOffset and CurrentSize in the ListView control 'ListFiles.ListItems.Clear Do Get FileNumber, FileListStart, CurrentFileOffset FileListStart = FileListStart + 4 Get FileNumber, FileListStart, CurrentFileSize FileListStart = FileListStart + 4 CurrentFileName = String$(255, Chr$(0)) Get FileNumber, FileListStart, CurrentFileName CurrentFileName = Mid(CurrentFileName, 1, InStr(1, CurrentFileName, Chr$(0)) - 1) FileListStart = FileListStart + Len(CurrentFileName) + 1 ' Check to make sure it's valid again. If CurrentFileName = "" Or CurrentFileOffset = 0 Or CurrentFileSize = 0 Then 'MessageBox "Empy file!", OKOnly, Information Close FileNumber Exit Function End If PAKFileList.Add CurrentFileName Loop Until FileListStart > LOF(FileNumber) End If Else 'Is a invalid PAK file PAKOpen = False 'CommonDialog.FileName = "" 'PAKFile = "" 'Toolbar.Buttons(4).Enabled = False 'MessageBox "The specified filename is not a valid file!", OKOnly, Critical Close FileNumber Exit Function End If Close FileNumber Exit Function Erro: If Err = 5 Then PAKOpen = False 'PAKFile = "" 'CommonDialog.FileName = "" 'ListFiles.ListItems.Clear 'Toolbar.Buttons(4).Enabled = False 'MessageBox "A error occur when trying to read the file!", OKOnly, Critical Close FileNumber Exit Function End If End Function Public Function PAKCreate(FileName As String) As Boolean ' Creates a new PAK file. ' FileName The full file path of new PAK file you'd like to make. On Error GoTo Erro Dim FileNumber As Long Dim FileListStart As Long FileListStart = 0 If FileExist(FileName) = True Then PAKCreate = False Exit Function Else FileNumber = FreeFile Open FileName For Binary As FileNumber Put FileNumber, 1, Header Put FileNumber, Len(Header) + 1, FileListStart Close FileNumber End If 'PAKFile = FileName 'Toolbar.Buttons(4).Enabled = True PAKCreate = True Exit Function Erro: If Err <> 0 Then PAKCreate = False Exit Function End If End Function Public Function PAKExists(ByVal FileName As String, ByVal FilePAK As String, Optional ByVal OpenAgain As Boolean = True) ' Checks if a file inside the given PAK file exists. Dim x As Long If OpenAgain Then PAK.PAKOpen FileName For x = 1 To PAKFileList.Count If LCase$(PAKFileList.Item(x)) = LCase$(FilePAK) Then PAKExists = True Exit Function End If Next x End Function Public Function PAKAdd(ByVal FilePAK As String, ByVal FileADD As String, Optional ByVal NameADD As String) As Boolean ' Adds a file to the given PAK file. ' FilePAK The PAK file's full file path. ' FileADD The file you would like to add to the PAK file. ' NameADD Use this if you would like to change the filename of the file once it's in the PAK file. ' If you don't suply NameADD then it uses the filename given in the file's path. On Error GoTo Erro Dim BytesADD As String Dim OffSetADD As Long Dim SizeADD As Long Dim FileNumberPAK As Long Dim FileNumberADD As Long Dim Position As Long Dim sFileList As String Dim FileListStart As Long ' Make the name from the path if it isn't given. If Len(NameADD) = 0 Then NameADD = Mid$(FileADD, Len(FileADD) - InStr(StrReverse(FileADD), "\") + 2) NameADD = NameADD & Chr$(0) If FileExist(FilePAK) = False Or FileExist(FileADD) = False Then PAKAdd = False Exit Function Else 'Check if is a valid PAK file If PAKValid(FilePAK) = True Then 'Is a valid PAK file FileNumberPAK = FreeFile Open FilePAK For Binary As FileNumberPAK 'Get the sFileList Get FileNumberPAK, 7, FileListStart 'Get the sFileList and put in the memory If FileListStart = 0 Then FileListStart = LOF(FileNumberPAK) + 1 sFileList = "" Else sFileList = String(LOF(FileNumberPAK) - FileListStart + 1, Chr$(0)) Get FileNumberPAK, FileListStart, sFileList End If OffSetADD = FileListStart SizeADD = FileLen(FileADD) 'Put the file inside of the PAK FileNumberADD = FreeFile Open FileADD For Binary As FileNumberADD If LOF(FileNumberADD) > 1000000 Then Position = -999999 Do Position = Position + 1000000 If Position + 999999 > LOF(FileNumberADD) Then BytesADD = String(LOF(FileNumberADD) - Position + 1, Chr$(0)) Else BytesADD = String(1000000, Chr$(0)) End If Get FileNumberADD, Position, BytesADD Put FileNumberPAK, FileListStart, BytesADD FileListStart = FileListStart + Len(BytesADD) Loop Until Position + 999999 > LOF(FileNumberADD) Else BytesADD = String(LOF(FileNumberADD), Chr$(0)) Get FileNumberADD, 1, BytesADD Put FileNumberPAK, FileListStart, BytesADD FileListStart = FileListStart + Len(BytesADD) End If Close FileNumberADD 'Add the new file in the sFileList Put FileNumberPAK, 7, FileListStart Put FileNumberPAK, FileListStart, sFileList Put FileNumberPAK, FileListStart + Len(sFileList), OffSetADD Put FileNumberPAK, FileListStart + Len(sFileList) + 4, SizeADD Put FileNumberPAK, FileListStart + Len(sFileList) + 8, NameADD PAKFileList.Add FileADD Close FileNumberPAK Else PAKAdd = False Exit Function End If End If PAKAdd = True Exit Function Erro: PAKAdd = False Exit Function End Function Public Function PAKValid(PAKFileName As String) As Boolean ' Checks to see if the given file is a valid PAK file. ' PAKFileName The file you want to check. Dim Header2 As String Dim FileNumber As Long Header2 = String$(Len(Header), Chr$(0)) If FileExist(PAKFileName) = False Then PAKValid = False Exit Function Else FileNumber = FreeFile Open PAKFileName For Binary As FileNumber Get FileNumber, 1, Header2 If Header2 = Header Then PAKValid = True Else PAKValid = False End If Close FileNumber End If End Function Public Function PAKExtract(ByVal PAKFile As String, ByVal FileToExtract As String, Optional ByVal DestinationFile As String) As Boolean ' Extracts a file from the given PAKFile. ' PAKFile The PAK file you would like to extract from. ' FileToExtract The file you would like to extract from the PAK file. ' DestinationFile The location you would like to extract the file to. Dim BytesExtract As String Dim offset As Long Dim Size As Long Dim Name As String Dim FileNumber As Long Dim DestinationNumber As Long Dim Position As Long Dim FileListStart As Long ' Make the destination if it isn't provided. If Len(DestinationFile) = 0 Then DestinationFile = Left$(PAKFile, InStrRev(PAKFile, "\") - 1) & "\" & FileToExtract If FileExist(PAKFile) = False Or FileExist(DestinationFile) = True Then PAKExtract = False Exit Function Else If PAKValid(PAKFile) = True Then FileNumber = FreeFile Open PAKFile For Binary As FileNumber 'Get the PAKFileList Get FileNumber, 7, FileListStart If FileListStart = 0 Then PAKExtract = False Close FileNumber Exit Function Else Do Get FileNumber, FileListStart, offset FileListStart = FileListStart + 4 Get FileNumber, FileListStart, Size FileListStart = FileListStart + 4 Name = String$(255, Chr$(0)) Get FileNumber, FileListStart, Name Name = Mid(Name, 1, InStr(1, Name, Chr$(0)) - 1) FileListStart = FileListStart + Len(Name) + 1 If Name = "" Or offset = 0 Or Size = 0 Then PAKExtract = False Close FileNumber Exit Function ElseIf LCase$(Name) = LCase$(FileToExtract) Then DestinationNumber = FreeFile() Open DestinationFile For Binary As DestinationNumber If Size > 100000 Then Position = -1000000 Do Position = Position + 1000000 If Position + 999999 > Size Then BytesExtract = String(Size - Position, Chr$(0)) Else BytesExtract = String(1000000, Chr$(0)) End If Get FileNumber, Position + offset, BytesExtract Put DestinationNumber, Position + 1, BytesExtract Loop Until Position + 999999 >= Size Else BytesExtract = String(Size, Chr$(0)) Get FileNumber, offset, BytesExtract Put DestinationNumber, 1, BytesExtract End If Close DestinationNumber Close FileNumber PAKExtract = True Exit Function End If Loop Until FileListStart > LOF(FileNumber) End If Close FileNumber PAKExtract = False Else PAKExtract = False Exit Function End If End If End Function Private Function FileExist(FileName As String) As Boolean ' Checks if any file exists. ' FileName The full file path you would like to check. On Error GoTo Erro If FileLen(FileName) <> 0 Then FileExist = True Else FileExist = False End If Exit Function Erro: If Err = 76 Or Err = 53 Then FileExist = False End Function