Hello everyone
I have written a mini-class for reading information about files contained inside a ZIP. My class reads file attributes, date and time of files stored inside a ZIP.
Class code:
Form code:
I have written a mini-class for reading information about files contained inside a ZIP. My class reads file attributes, date and time of files stored inside a ZIP.
- It even works in Windows 98
- Opens all files, even DOCX format
- Automatically detects the encoding of file names inside the ZIP (DOS or UTF-8 encoding)
- Gets a list of files inside the ZIP
- Opens even SFX-EXE files for reading
- Gets file attributes and date and time
- Supports large files over 500 MB
- Supports unicode file names
Class code:
Code:
Option Explicit
'////////////////////////////////////////////
'// Class for reading ZIP files //
'// Copyright (c) 2025-03-01 by HackerVlad //
'// e-mail: vladislavpeshkov@ya.ru //
'// Version 1.0 //
'////////////////////////////////////////////
' API declarations ...
Private Declare Function CreateFileW Lib "kernel32" (ByVal lpFileName As Long, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CreateFileA Lib "kernel32" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As Long, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Any) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cbMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetMem2 Lib "msvbvm60" (src As Any, dst As Any) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (src As Any, dst As Any) As Long
' Constants ...
Private Const OPEN_EXISTING As Long = 3
Private Const FILE_SHARE_READ = &H1
Private Const GENERIC_READ As Long = &H80000000
Private Const CREATE_ALWAYS = 2
Private Const EndOFCentralDirSignature As Long = &H6054B50
Private Const CentralFileHeaderSigniature As Long = &H2014B50
Private Const CP_UTF8 As Long = 65001
Private Const CP_OEMCP = 1 ' default to OEM code page
Private Const MB64 As Long = 67108864
Public Enum AttributesInZip
zipFileAttr
zipFileDate
zipFileTime
zipFileDateAndTime
End Enum
Public Enum FileNameCodePageInZip
zipCodePageAutoDetect
zipCodePageCP866
zipCodePageUTF8
End Enum
' Variables to store inside an instance of a class
Dim EntriesInTheCentralDir As Integer
Dim zipCountFiles As Integer
Dim zipCountDirs As Integer
Dim zipListFiles As New Collection
Dim zipListFilesCP866 As New Collection
Dim zipListFilesUTF8 As New Collection
Dim zipFileAttributes As New Collection
Dim zipFileDosDate As New Collection
Dim zipFileDosTime As New Collection
' Open the ZIP file for reading
Public Function OpenZip(ByVal ZipFileName As String) As Boolean
Dim hFile As Long
Dim dwBytesReaded As Long
Dim nFileSize As Long
Dim bArray() As Byte
Dim i As Long
Dim signature As Long
Dim FileName As String
Dim FileNameCP866 As String
Dim FileNameUTF8 As String
Dim OffSet As Long
Dim FileNameLength As Integer
Dim LastModFileTime As Integer
Dim LastModFileDate As Integer
Dim ExtraFieldLength As Integer
Dim FileCommentLength As Integer
Dim ExternalFileAttributes As Long
Dim nOutputCharLen As Long
Dim numread As Long
Dim SetNewPosition As Long
Dim MajorWindowsVersion As Long
hFile = CreateFileW(StrPtr(ZipFileName), GENERIC_READ, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, 0, 0)
If hFile = 0 Then hFile = CreateFileA(ZipFileName, GENERIC_READ, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, 0, 0)
If hFile <> -1 And hFile <> 0 Then
nFileSize = GetFileSize(hFile, ByVal 0&)
If nFileSize <> -1 Then
If nFileSize <= MB64 Then ' If the file size is less than 64 MB, then read the entire file
ReDim bArray(nFileSize - 1)
ReadFile hFile, VarPtr(bArray(0)), nFileSize, dwBytesReaded, ByVal 0&
Else ' The file size is more than 64 MB
ReDim bArray(MB64 - 1)
' Read only the last 64 MB
SetNewPosition = nFileSize - MB64
SetFilePointer hFile, SetNewPosition, ByVal 0&, 1
ReadFile hFile, VarPtr(bArray(0)), MB64, dwBytesReaded, ByVal 0&
End If
If dwBytesReaded > 0 Then
For i = UBound(bArray) - 3 To LBound(bArray) Step -1
GetMem4 bArray(i), signature
If signature = EndOFCentralDirSignature Then
Exit For
End If
Next
' Load data from a file into variables (I decided not to use structures)
GetMem2 bArray(i + 10), EntriesInTheCentralDir
GetMem4 bArray(i + 16), OffSet
If SetNewPosition > 0 Then
OffSet = OffSet - SetNewPosition
End If
GetMem4 ByVal &H7FFE026C, MajorWindowsVersion
If zipListFiles.Count > 0 Then Set zipListFiles = Nothing
If zipListFilesCP866.Count > 0 Then Set zipListFilesCP866 = Nothing
If zipListFilesUTF8.Count > 0 Then Set zipListFilesUTF8 = Nothing
If zipFileAttributes.Count > 0 Then Set zipFileAttributes = Nothing
If zipFileDosDate.Count > 0 Then Set zipFileDosDate = Nothing
If zipFileDosTime.Count > 0 Then Set zipFileDosTime = Nothing
zipCountFiles = 0
zipCountDirs = 0
For i = 1 To EntriesInTheCentralDir
GetMem4 bArray(OffSet), signature
If signature = CentralFileHeaderSigniature Then
' Get all the necessary information about the file
GetMem2 bArray(OffSet + 12), LastModFileTime
GetMem2 bArray(OffSet + 14), LastModFileDate
GetMem2 bArray(OffSet + 28), FileNameLength
GetMem2 bArray(OffSet + 30), ExtraFieldLength
GetMem2 bArray(OffSet + 32), FileCommentLength
GetMem4 bArray(OffSet + 38), ExternalFileAttributes
OffSet = OffSet + 46
FileName = String$(FileNameLength, vbNullChar)
CopyMemory ByVal StrPtr(FileName), bArray(OffSet), FileNameLength
OffSet = OffSet + FileNameLength + ExtraFieldLength + FileCommentLength
FileNameCP866 = Space$(FileNameLength)
FileNameUTF8 = Space$(FileNameLength)
nOutputCharLen = MultiByteToWideChar(CP_OEMCP, 0&, StrPtr(FileName), -1, 0&, 0&) ' Get the buffer size in characters for DOS encoding
MultiByteToWideChar CP_OEMCP, 0&, StrPtr(FileName), -1, StrPtr(FileNameCP866), nOutputCharLen ' Convert Encodings
nOutputCharLen = 0
nOutputCharLen = MultiByteToWideChar(CP_UTF8, 0&, StrPtr(FileName), -1, 0&, 0&) ' Get the buffer size in characters for UTF8 encoding
MultiByteToWideChar CP_UTF8, 0&, StrPtr(FileName), -1, StrPtr(FileNameUTF8), nOutputCharLen ' Convert Encodings
FileNameUTF8 = Left$(FileNameUTF8, nOutputCharLen - 1)
FileNameCP866 = Replace$(FileNameCP866, "/", "\")
FileNameUTF8 = Replace$(FileNameUTF8, "/", "\")
If (ExternalFileAttributes And vbDirectory) <> 0 Then
zipCountDirs = zipCountDirs + 1
Else
zipCountFiles = zipCountFiles + 1
End If
If MajorWindowsVersion >= 6 And MajorWindowsVersion < 600 Then
If FileNameUTF8 Like "*[" & ChrW(-3) & "]*" Then ' Auto-detection of encodings
zipListFiles.Add FileNameCP866 ' DOS encoding
Else
zipListFiles.Add FileNameUTF8 ' UTF8 encoding
End If
Else ' Windows versions are smaller than Vista
zipListFiles.Add FileNameCP866 ' DOS encoding
End If
zipListFilesCP866.Add FileNameCP866
zipListFilesUTF8.Add FileNameUTF8
zipFileAttributes.Add ExternalFileAttributes
zipFileDosDate.Add LastModFileDate
zipFileDosTime.Add LastModFileTime
If OpenZip = False Then OpenZip = True
End If
Next
End If
End If
CloseHandle hFile
End If
End Function
' Returns the number of files and directories inside a ZIP
Public Property Get CountFilesAndDirs() As Long
CountFilesAndDirs = EntriesInTheCentralDir
End Property
' Returns the number of files inside the ZIP
Public Property Get CountFiles() As Long
CountFiles = zipCountFiles
End Property
' Returns the number of directories inside a ZIP
Public Property Get CountDirs() As Long
CountDirs = zipCountDirs
End Property
' Retrieves the list of files inside the ZIP
Public Function ListFiles(arrFileNames() As String, Optional ByVal CodePage As FileNameCodePageInZip) As Boolean
Dim i As Integer
If zipListFiles.Count > 0 Then
ReDim arrFileNames(zipListFiles.Count - 1)
For i = 1 To zipListFiles.Count
If CodePage = zipCodePageAutoDetect Then
arrFileNames(i - 1) = zipListFiles(i)
ElseIf CodePage = zipCodePageCP866 Then
arrFileNames(i - 1) = zipListFilesCP866(i)
ElseIf CodePage = zipCodePageUTF8 Then
arrFileNames(i - 1) = zipListFilesUTF8(i)
End If
Next
ListFiles = True
End If
End Function
' Returns the file attributes inside the ZIP, as well as the date and time the files were created
Public Function GetFileAttributesInZip(ByVal FileNameInZip As String, Optional ByVal AttrInZip As AttributesInZip) As Long
Dim i As Integer
If zipListFilesCP866.Count > 0 Then
For i = 1 To zipListFilesCP866.Count
If zipListFilesCP866(i) = FileNameInZip Then
GoTo Subroutine
Exit For
End If
Next
End If
If zipListFilesUTF8.Count > 0 Then
For i = 1 To zipListFilesUTF8.Count
If zipListFilesUTF8(i) = FileNameInZip Then
GoTo Subroutine
Exit For
End If
Next
End If
Exit Function
Subroutine:
If AttrInZip = zipFileAttr Then
GetFileAttributesInZip = zipFileAttributes(i)
ElseIf AttrInZip = zipFileDate Then
GetFileAttributesInZip = zipFileDosDate(i)
ElseIf AttrInZip = zipFileTime Then
GetFileAttributesInZip = zipFileDosTime(i)
ElseIf AttrInZip = zipFileDateAndTime Then
GetFileAttributesInZip = ((zipFileDosTime(i) And &H7FFF&) * &H10000) Or (zipFileDosDate(i) And &HFFFF&) Or (&H80000000 And zipFileDosTime(i) < 0)
End If
End FunctionCode:
Option Explicit
Private Declare Function DosDateTimeToFileTime Lib "kernel32" (ByVal wFatDateAndwFatTime As Integer, ByVal wFatTime As Integer, lpFileTime As Currency) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As Currency, lpSystemTime As SYSTEMTIME) As Long
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Dim zip As New clsZipReader
Private Function FileTimeToString(ByVal DosDate As Integer, ByVal DosTime As Integer) As String
Dim FILETIME As Currency
Dim ST As SYSTEMTIME
DosDateTimeToFileTime DosDate, DosTime, FILETIME
If FILETIME > 0 Then
FileTimeToSystemTime FILETIME, ST
FileTimeToString = Format(ST.wDay & "." & ST.wMonth & "." & ST.wYear & " " & ST.wHour & ":" & ST.wMinute & ":" & ST.wSecond, "yyyy-mm-dd hh:mm:ss")
End If
End Function
Private Sub ReadZip(ByVal FileName As String)
Dim i As Integer
Dim arrFileName() As String
If zip.OpenZip(FileName) = True Then
Cls
Print "CountFilesAndDirs: " & zip.CountFilesAndDirs
Print "CountFiles: " & zip.CountFiles
Print "CountDirs: " & zip.CountDirs
If zip.ListFiles(arrFileName) = True Then
If List1.ListCount > 0 Then List1.Clear
For i = 0 To UBound(arrFileName)
List1.AddItem arrFileName(i) & " Attr: " & zip.GetFileAttributesInZip(arrFileName(i))
Next
List1.Selected(0) = True
If Me.Visible = True Then List1.SetFocus
End If
Else
Beep
End If
End Sub
Private Sub Command1_Click()
Dim FileName As String
FileName = GetDialogFileName(OFEOpenForLoad, "All files" & vbNullChar & "*.*" & vbNullChar, hWnd, App.Path)
If Len(FileName) > 0 Then
ReadZip FileName
Text1.Text = FileName
End If
End Sub
Private Sub Form_Load()
ReadZip App.Path & "\test.zip"
Text1.Text = App.Path & "\test.zip"
End Sub
Private Sub List1_Click()
Dim str As String
Dim DosDate As Integer, DosTime As Integer
On Error Resume Next
str = Left$(List1.Text, InStr(1, List1.Text, " ") - 1)
DosDate = zip.GetFileAttributesInZip(str, zipFileDate)
DosTime = zip.GetFileAttributesInZip(str, zipFileTime)
Label1.Caption = FileTimeToString(DosDate, DosTime)
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
KeyAscii = 0
ReadZip Text1.Text
End If
End Sub