-
2 Attachment(s)
A module for reading CAB archives
I finally wrote a module for reading CAB archives today. With this module, you can read the list of files inside the CAB archives and which file takes up how many bytes. I did not add the date and time of the files, since I did not need it, but it is very easy to do it myself by slightly redesigning the module and the custom UDT array to get the file list data.
This is a very simple implementation, I tried to make as few lines of code as possible so that there would be. In fact, unpacking a CAB archive is generally done with just one line of code. To do this, you need to access the undocumented, but very useful, ExtractFiles function from the library advpack.dll which is available in all Windows.
Now you know how to get a list of files from the CAB archive and how to unpack the CAB archive with the program-code on VB6. However, the packaging feature is not implemented here, since this is a very complex code using the FCICreate function from the library cabinet.dll I was looking for a ready-made version of such code on the Internet, but I didn't find it for vb6, so I haven't written the packaging yet.
Last update: 2025-02-20, posted version 2.5
New module code
-
Re: A module for reading CAB archives
Yes, and I almost forgot the code of the module itself here:
Code:
Option Explicit
'////////////////////////////////////////////
'// A module for reading CAB archives //
'// Copyright (c) 11.11.2024 by HackerVlad //
'// e-mail: [email protected] //
'// Version 1.0 //
'////////////////////////////////////////////
Private Declare Function SetupIterateCabinet Lib "setupapi" Alias "SetupIterateCabinetA" (ByVal CabinetFile As String, ByVal Reserved As Long, ByVal MsgHandler As Long, ByVal Context As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, ByVal Source As Long, ByVal Length As Long)
Private Const MAXPATH = 260
Private Const NO_ERROR = 0
'
' Notification messages, handled in the callback
' procedure. This class doesn't handle them all.
'
Private Const SPFILENOTIFY_FILEINCABINET = &H11
Private Const SPFILENOTIFY_NEEDNEWCABINET = &H12
Private Const SPFILENOTIFY_FILEEXTRACTED = &H13
Private Const sicList = 568
Private Const sicCount = 569
Dim mstrFileToExtract As String
Dim mstrOutputPath As String
Dim mstrOutputFile As String
Dim mlngCount As Long
Dim mlngcnt As Long
Dim arrListFilesCab() As CabInfo
Public Type CabInfo
cabFileName As String
cabFileSize As Long
End Type
Private Type FileInCabinetInfo
NameInCabinet As Long
FileSize As Long
Win32Error As Long
DosDate As Integer
DosTime As Integer
DosAttribs As Integer
FullTargetName(0 To MAXPATH - 1) As Byte
End Type
Private Enum FILEOP
FILEOP_ABORT = 0
FILEOP_DOIT = 1
FILEOP_SKIP = 2
End Enum
Private Function CabinetCallback(ByVal Context As Long, ByVal Notification As Long, ByRef Param1 As FileInCabinetInfo, ByVal Param2 As Long) As Long
Select Case Notification
Case SPFILENOTIFY_NEEDNEWCABINET
CabinetCallback = NO_ERROR
Case SPFILENOTIFY_FILEINCABINET
Select Case Context
Case sicCount
mlngCount = mlngCount + 1
CabinetCallback = FILEOP_SKIP
Case sicList
' Add a position to the UDT array
ReDim Preserve arrListFilesCab(mlngcnt)
arrListFilesCab(mlngcnt).cabFileName = fStringFromPointer(Param1.NameInCabinet)
arrListFilesCab(mlngcnt).cabFileSize = Param1.FileSize
mlngcnt = mlngcnt + 1
CabinetCallback = FILEOP_SKIP ' Go through the list of files further
End Select
End Select
End Function
Private Function fStringFromPointer(ByVal ptr As Long) As String
Dim lngLen As Long
Dim strBuffer As String
'
' Given a string pointer, copy the value
' of the string into a new, safe location.
'
lngLen = lstrlen(ptr)
strBuffer = Space$(lngLen)
CopyMemory ByVal strBuffer, ptr, lngLen
fStringFromPointer = strBuffer
End Function
' Get a list of files inside the CAB archive
Public Function GetFilesListInCab(ByVal FileName As String, arrCabInfo() As CabInfo) As Long
mlngcnt = 0
If SetupIterateCabinet(FileName, 0, AddressOf CabinetCallback, sicList) Then
arrCabInfo = arrListFilesCab
GetFilesListInCab = mlngcnt
Erase arrListFilesCab
End If
End Function
' Find out the count of files inside the CAB archive
Public Function GetFilesCountInCab(ByVal FileName As String) As Long
mlngCount = 0
If SetupIterateCabinet(FileName, 0, AddressOf CabinetCallback, sicCount) Then
GetFilesCountInCab = mlngCount
End If
End Function
-
Re: A module for reading CAB archives
Today, testuser2 has slightly modified this module to support Unicode and 64-bit platforms. However, in order for this code to work in VB6, you will have to delete all the words "PtrSafe".
Code:
Option Explicit
'////////////////////////////////////////////
'// ?????? ??? ?????? CAB-??????? //
'// Copyright (c) 11.11.2024 by HackerVlad //
'// e-mail: [email protected] //
'// Testuser2 ??????? ????????? x64 //
'// ?????? 1.1 //
'////////////////////////////////////////////
Private Declare PtrSafe Function SetupIterateCabinet Lib "setupapi" Alias "SetupIterateCabinetW" ( _
ByVal CabinetFile As LongPtr, _
ByVal Reserved As Long, _
ByVal MsgHandler As LongPtr, _
ByVal Context As LongPtr) As Long
'WINSETUPAPI BOOL SetupIterateCabinetW(
' [in] PCWSTR CabinetFile,
' [in] DWORD Reserved,
' [in] PSP_FILE_CALLBACK_W MsgHandler,
' [in] PVOID Context
');
Private Declare PtrSafe Function lstrlenW Lib "kernel32" (ByVal lpString As LongPtr) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Const MAXPATH = 260
Private Const NO_ERROR = 0
'
' Notification messages, handled in the callback
' procedure. This class doesn't handle them all.
'
Private Const SPFILENOTIFY_FILEINCABINET = &H11
Private Const SPFILENOTIFY_NEEDNEWCABINET = &H12
Private Const SPFILENOTIFY_FILEEXTRACTED = &H13
Private Const sicList = 568
Private Const sicCount = 569
Private Type CabInfo
cabFileName As String
cabFileSize As Long
End Type
Private Type FileInCabinetInfo '_FILE_IN_CABINET_INFO_W
NameInCabinet As LongPtr ' PCWSTR
FileSize As Long ' DWORD
Win32Error As Long ' DWORD
DosDate As Integer ' WORD
DosTime As Integer ' WORD
DosAttribs As Integer ' WORD
FullTargetName(MAXPATH - 1) As Byte ' WCHAR
End Type
Private Enum FILEOP
FILEOP_ABORT = 0
FILEOP_DOIT = 1
FILEOP_SKIP = 2
End Enum
Private mstrFileToExtract As String
Private mstrOutputPath As String
Private mstrOutputFile As String
Private mlngCount As Long
Private arrListFilesCab() As CabInfo
'UINT PspFileCallbackW(PVOID Context, UINT Notification, UINT_PTR Param1, UINT_PTR Param2)
Private Function CabinetCallback(ByVal Context As LongPtr, ByVal Notification As Long, ByRef Param1 As FileInCabinetInfo, ByVal Param2 As LongPtr) As Long
Select Case Notification
Case SPFILENOTIFY_NEEDNEWCABINET
CabinetCallback = NO_ERROR
Case SPFILENOTIFY_FILEINCABINET
Select Case Context
Case sicCount
mlngCount = mlngCount + 1
CabinetCallback = FILEOP_SKIP
Case sicList
' ???????? ??????? ? ?????? UDT
ReDim Preserve arrListFilesCab(mlngCount)
arrListFilesCab(mlngCount).cabFileName = fStringFromPointer(Param1.NameInCabinet)
arrListFilesCab(mlngCount).cabFileSize = Param1.FileSize
mlngCount = mlngCount + 1
CabinetCallback = FILEOP_SKIP ' ?????????? ?????? ?????? ??????
End Select
End Select
End Function
Private Function fStringFromPointer(ByVal ptr As LongPtr) As String
Dim lngLen As Long
' Given a string pointer, copy the value of the string into a new, safe location.
lngLen = lstrlenW(ptr)
fStringFromPointer = Space$(lngLen)
CopyMemory ByVal StrPtr(fStringFromPointer), ByVal ptr, lngLen * 2
End Function
' ???????? ?????? ?????? ?????? ?????? CAB
Public Function GetFilesListInCab(ByRef FileName As String, arrCabInfo() As CabInfo) As Long
mlngCount = 0
If SetupIterateCabinet(StrPtr(FileName), 0, AddressOf CabinetCallback, sicList) Then
arrCabInfo = arrListFilesCab
GetFilesListInCab = mlngCount
Erase arrListFilesCab
End If
End Function
' ?????? ?????????? ?????? ?????? ?????? CAB
Public Function GetFilesCountInCab(ByRef FileName As String) As Long
mlngCount = 0
If SetupIterateCabinet(StrPtr(FileName), 0&, AddressOf CabinetCallback, sicCount) Then
GetFilesCountInCab = mlngCount
End If
End Function
-
Re: A module for reading CAB archives
-
Re: A module for reading CAB archives
So what!? And where do you see the virus here?
-
Re: A module for reading CAB archives
I don't see it, but antiviruses do.
People aren't going to use something like that.
-
Re: A module for reading CAB archives
What nonsense is this!? You can see the full source code in front of your eyes, which is 100% free of any virus! Is your antivirus blatantly lying to you and do you believe it? This is a false detect.
-
Re: A module for reading CAB archives
Quote:
Originally Posted by
yokesee
I don't see it, but antiviruses do.
People aren't going to use something like that.
You do realize it's impossible to produce an unsigned VB6 app that doesn't trigger false positives in at least 2-3 of the engines on VirusTotal, right?
-
Re: A module for reading CAB archives
Quote:
Originally Posted by
yokesee
I don't see it, but antiviruses do.
People aren't going to use something like that.
Of course they are going to use it. Anyone who has a basic understanding of how A/V tools flag up unknown binaries (or even unknown source code) as false positives and who has the source in front of them (and an understanding of the code is doing) is going to be completely confident.
IF you don't know this stuff then you MUST investigate deeper yourself.
-
Re: A module for reading CAB archives
Wow cool code works perfect. you just need a way to make the cabs now. can make an achiver then be cool. I remmber using a program to create and read cabs years ago called Cab2000 i think but was a trial. thanks for this code.
-
Re: A module for reading CAB archives
Quote:
Originally Posted by
BenJones
Wow cool code works perfect. you just need a way to make the cabs now. can make an achiver then be cool. I remmber using a program to create and read cabs years ago called Cab2000 i think but was a trial. thanks for this code.
Yes, you can write your own CAB archiver, but there is very complex code for packing files, so I haven't written it yet. There is simply no such code anywhere on the Internet for Visual Basic 6 and not even for VB.Net . Therefore, you will have to rewrite from other languages (Delphi, C++).
-
Re: A module for reading CAB archives
Quote:
Originally Posted by
HackerVlad
Yes, you can write your own CAB archiver, but there is very complex code for packing files, so I haven't written it yet. There is simply no such code anywhere on the Internet for Visual Basic 6 and not even for VB.Net . Therefore, you will have to rewrite from other languages (Delphi, C++).
True but I did find makecab in windows after reading your code I was thinking of makeing a shell for it, and maybe using your code for reading the cabs if that is ok, I did see some cab stuff in delphi cos I thought I have a quick look around the net I used to use delphi I may have a look at that to. anyway keep up the good work.
-
Re: A module for reading CAB archives
Quote:
Originally Posted by
BenJones
True but I did find makecab in windows after reading your code I was thinking of makeing a shell for it, and maybe using your code for reading the cabs if that is ok, I did see some cab stuff in delphi cos I thought I have a quick look around the net I used to use delphi I may have a look at that to. anyway keep up the good work.
Yes, I'm already working on rewriting the code from Delphi. But I face difficulties in understanding the data types of variables. There is a lot to know (ULONG, UINT, Integer, USHORT, AnsiChar and so on)...
-
Re: A module for reading CAB archives
If I had a useful table where each data type of Delphi variables would be indicated, how many bytes it takes up in memory. It would be easier for me.
-
Re: A module for reading CAB archives
Quote:
Originally Posted by
HackerVlad
If I had a useful table where each data type of Delphi variables would be indicated, how many bytes it takes up in memory. It would be easier for me.
Found this duno if it helps.
http://mc-computing.com/languages/DataTypes.htm
You should also get the size of the types using sizeof or Length if I remmber
-
Re: A module for reading CAB archives
this looks usefull i was thinking of maybe writeing a shell for it but it you can convert that delphi one that be good to.
https://learn.microsoft.com/en-us/wi...mmands/makecab
-
Re: A module for reading CAB archives
Quote:
Originally Posted by
BenJones
Yes, I'm already working on rewriting the Delphi code. So you'd better just wait for me to do the CAB packaging in VB6 myself. However, it should be understood that the packaging functions are very complex and use the CDecl convention.
-
Re: A module for reading CAB archives
I had to manage some cabs a few years ago... I started by wasting my time with some c++ code that was too strong for me found on codeproject,
https://www.codeproject.com/Articles...and-Extraction
then I found my happiness in c# on stackoverflow that I converted quite easily to vb.net (my final goal in vb.net)
https://stackoverflow.com/questions/...file-in-memory
(see post by Mr. Simon Mourier)
it must be quite easly to adapt to vb6 for the experts here
I should be able to find my code from that time, but it's vb.net, sorry for that
NB My goal was quite specific, to read into memory (without extracting the entire cab into a directory) the beginning of a file (whose name was known) in a funny *.xsn extension cab... and that quickly...
-
Re: A module for reading CAB archives
As I promised, I wrote the packaging of CAB files in VB6 code, here's a look at my work: https://www.vbforums.com/showthread....=1#post5668210
-
Re: A module for reading CAB archives
Quote:
Originally Posted by
BenJones
Wow cool code works perfect. you just need a way to make the cabs now. can make an achiver then be cool. I remmber using a program to create and read cabs years ago called Cab2000 i think but was a trial. thanks for this code.
Now we also have the code for packing files (creating cabinets). I've mastered this very complex code after all. In TwinBasic, this code will work without any dependencies, But in order for this code to work in VB6, you will have to download an add-in (a plugin for the VB6 environment) for CDecl functions to work.
You can download the add-on here: https://github.com/thetrik/VBCDeclFix
Topic on add-on VBCDeclFix: https://www.vbforums.com/showthread....ons-in-VB6-IDE
The most important thing is that now we have a code for packing and unpacking cabinets. Now you can safely write a program similar to Cab2000 yourself. You can call it Cab2025 or even Cab3000 :)
-
Re: A module for reading CAB archives
You don't really need that Add-in for VB6, "DispCallFunc" can call Cdecl functions if you want to be free of any external dependencies! ;)
-
Re: A module for reading CAB archives
Quote:
Originally Posted by
VanGoghGaming
You don't really need that Add-in for VB6, "DispCallFunc" can call Cdecl functions if you want to be free of any external dependencies! ;)
Thanks for telling me, I've thought about it too, but it's difficult for me. I do not know how to do this. Write me an example of such code.
Even if you can call the API, then what about the custom CDecl functions? You will notice the many callback functions in my module - they are all CDecl.
Although the dependence on this Add-in for vb6 does not bother me much, since now all people are switching to Twin Basic, and there are no dependencies there already.
-
Re: A module for reading CAB archives
Yeah, if the callback functions are also CDecl then you need the Add-in because it knows how to clear the stack after the function call.
-
Re: A module for reading CAB archives
BenJones, by the way, I have not found a program called "Cab2000" anywhere on the Internet.
-
Re: A module for reading CAB archives
Today I wrote version 2.0 of the module for reading and unpacking CAB files. What's new in this version?
- Support for unicode file names and paths, for cabinet names themselves, and for destination folder paths for unpacking files (but not for files inside cabinets)
- The ability to view the date and time of files inside the cabinets
- Extracting file attributes inside cabinets
- The ability to extract multiple files from a list (only some selected files) from cabinets
- Fully compatible with 64-bit systems
The first version of the module did not have a built-in mechanism for extracting files. The first version of my project used the undocumented ExtractFiles function, but unfortunately this function does not support unicode file names for cabinet files and for decompression paths, even if you use the ExtractFilesW function. Therefore, I decided to implement the unpacking mechanism with the SetupIterateCabinetW function. So now, to unpack the CAB files, you will need to use your own ExtractFilesInCab function.
How to unpack a CAB file with a program code on VB6 (How Do I Unzip a CAB file)
Code:
Option Explicit
'///////////////////////////////////////////////////
'// Module for reading and unpacking CAB archives //
'// Copyright (c) 2025-02-02 by HackerVlad //
'// e-mail: [email protected] //
'// Version 2.0 (32 and 64-bit compatible) //
'///////////////////////////////////////////////////
' API declarations ...
#If VBA7 = 0 Then
Private Declare Function SetupIterateCabinet Lib "setupapi" Alias "SetupIterateCabinetW" (ByVal CabinetFile As Long, ByVal Reserved As Long, ByVal MsgHandler As Long, ByVal Context As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
Private Declare Function GetFileAttributesEx Lib "kernel32" Alias "GetFileAttributesExW" (ByVal lpFileName As Long, ByVal fInfoLevelId As Long, ByRef lpFileInformation As Any) As Long
Private Declare Function SHCreateDirectory Lib "shell32" (ByVal hwnd As Long, ByVal pszPath As Long) As Long
Private Declare Function PathRemoveFileSpecW Lib "shlwapi" (ByVal pszPath As Long) As Long
Private Enum LongPtr
[_]
End Enum
#Else
Private Declare PtrSafe Function SetupIterateCabinet Lib "setupapi" Alias "SetupIterateCabinetW" (ByVal CabinetFile As LongPtr, ByVal Reserved As Long, ByVal MsgHandler As LongPtr, ByVal Context As Long) As Long
Private Declare PtrSafe Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As LongPtr) As Long
Private Declare PtrSafe Function lstrcpy Lib "kernel32" Alias "lstrcpyW" (ByVal lpString1 As LongPtr, ByVal lpString2 As LongPtr) As Long
Private Declare PtrSafe Function GetFileAttributesEx Lib "kernel32" Alias "GetFileAttributesExW" (ByVal lpFileName As LongPtr, ByVal fInfoLevelId As Long, ByRef lpFileInformation As Any) As Long
Private Declare PtrSafe Function SHCreateDirectory Lib "shell32" (ByVal hwnd As Long, ByVal pszPath As LongPtr) As Long
Private Declare PtrSafe Function PathRemoveFileSpecW Lib "shlwapi" (ByVal pszPath As LongPtr) As Long
#End If
' Constants ...
Private Const MAXPATH = 260
Private Const FILEOP_DOIT = 1
Private Const FILEOP_SKIP = 2
Private Const SPFILENOTIFY_FILEINCABINET = &H11
Private Const GetFileExInfoStandard As Long = 0
' Own fictional constants ...
Private Const sicList = 568
Private Const sicCount = 569
Private Const sicExtract = 570
' Variables for temporary data storage ...
Dim strFileToExtract As String, strOutputPath As String
Dim lngCount As Long, CountFilesSuccessfullyExtracted As Long
Dim arrListFilesCab() As CabInfo
Dim arrFilesToExtract() As String
Dim IsFilesList As Boolean
' Structures ...
Public Type CabInfo
cabFileName As String
cabFileSize As Long
cabDosDate As Integer
cabDosTime As Integer
cabDosAttribs As Integer
End Type
Private Type FileInCabinetInfoW
NameInCabinet As LongPtr
FileSize As Long
Win32Error As Long
DosDate As Integer
DosTime As Integer
DosAttribs As Integer
FullTargetName(MAXPATH - 1) As Integer ' WCHAR FullTargetName[MAX_PATH];
End Type
Private Type WIN32_FILE_ATTRIBUTE_DATA
dwFileAttributes As Long
ftCreationTime As Currency
ftLastAccessTime As Currency
ftLastWriteTime As Currency
nFileSizeHigh As Long
nFileSizeLow As Long
End Type
' Does the directory exist (IsDir)
Public Function cabIsDir(ByVal path As String) As Boolean
Dim tAttr As WIN32_FILE_ATTRIBUTE_DATA
If GetFileAttributesEx(StrPtr(path), GetFileExInfoStandard, tAttr) <> 0 Then
If (tAttr.dwFileAttributes And vbDirectory) <> 0 Then
cabIsDir = True
End If
End If
End Function
' Convert the full file path to the folder path (always returns "\" at the end)
Public Function cabExtractFilePath(ByVal FileName As String) As String
Dim lNullPos As Long
Dim pszPath As String
pszPath = FileName
PathRemoveFileSpecW StrPtr(pszPath)
lNullPos = InStr(1, pszPath, vbNullChar)
If lNullPos Then
pszPath = Left$(pszPath, lNullPos - 1)
If Right$(pszPath, 1) <> "\" Then pszPath = pszPath & "\"
cabExtractFilePath = pszPath
Else
cabExtractFilePath = FileName
End If
End Function
Private Function CabinetCallback(ByVal Context As Long, ByVal Notification As Long, ByRef Param1 As FileInCabinetInfoW, ByVal Param2 As Long) As Long
If Notification = SPFILENOTIFY_FILEINCABINET Then
Dim FileNameInCab As String
Select Case Context
Case sicCount
lngCount = lngCount + 1
CabinetCallback = FILEOP_SKIP ' Skip the file and go through the list of files next
Case sicList
FileNameInCab = Space$(MAXPATH)
lstrcpy StrPtr(FileNameInCab), Param1.NameInCabinet
FileNameInCab = Left$(FileNameInCab, lstrlen(StrPtr(FileNameInCab)))
' Add a position to the UDT array
ReDim Preserve arrListFilesCab(lngCount)
arrListFilesCab(lngCount).cabFileName = FileNameInCab
arrListFilesCab(lngCount).cabFileSize = Param1.FileSize
arrListFilesCab(lngCount).cabDosDate = Param1.DosDate
arrListFilesCab(lngCount).cabDosTime = Param1.DosTime
arrListFilesCab(lngCount).cabDosAttribs = Param1.DosAttribs
lngCount = lngCount + 1
CabinetCallback = FILEOP_SKIP ' Skip the file and go through the list of files next
Case sicExtract
Dim FileName As String, FilePath As String
Dim i As Long
FileNameInCab = Space$(MAXPATH)
lstrcpy StrPtr(FileNameInCab), Param1.NameInCabinet
FileNameInCab = Left$(FileNameInCab, lstrlen(StrPtr(FileNameInCab)))
FileName = strOutputPath & "\" & FileNameInCab
lstrcpy VarPtr(Param1.FullTargetName(0)), StrPtr(FileName) ' Filling in the structure value with the name of the extracted file
If IsFilesList = False Then
If strFileToExtract = FileNameInCab Or Len(strFileToExtract) = 0 Then
FilePath = cabExtractFilePath(FileName)
If cabIsDir(FilePath) = False Then SHCreateDirectory 0, StrPtr(FilePath)
CabinetCallback = FILEOP_DOIT ' Extract the file
CountFilesSuccessfullyExtracted = CountFilesSuccessfullyExtracted + 1
Else
CabinetCallback = FILEOP_SKIP ' Skip the file and go through the list of files next
End If
Else
Dim ExtractCurrentFile As Boolean
For i = 0 To UBound(arrFilesToExtract)
If arrFilesToExtract(i) = FileNameInCab Then
ExtractCurrentFile = True
Exit For
End If
Next
If ExtractCurrentFile = True Then
FilePath = cabExtractFilePath(FileName)
If cabIsDir(FilePath) = False Then SHCreateDirectory 0, StrPtr(FilePath)
CabinetCallback = FILEOP_DOIT ' Extract the file
CountFilesSuccessfullyExtracted = CountFilesSuccessfullyExtracted + 1
Else
CabinetCallback = FILEOP_SKIP ' Skip the file and go through the list of files next
End If
End If
End Select
End If
End Function
' Get a list of files inside the CAB archive
Public Function GetFilesListInCab(ByVal cabFileName As String, arrCabInfo() As CabInfo) As Long
lngCount = 0
If SetupIterateCabinet(StrPtr(cabFileName), 0, AddressOf CabinetCallback, sicList) Then
arrCabInfo = arrListFilesCab
GetFilesListInCab = lngCount
Erase arrListFilesCab
End If
End Function
' Get count of files inside the CAB archive
Public Function GetFilesCountInCab(ByVal cabFileName As String) As Long
lngCount = 0
If SetupIterateCabinet(StrPtr(cabFileName), 0, AddressOf CabinetCallback, sicCount) Then
GetFilesCountInCab = lngCount
End If
End Function
' Extract files from the CAB archive
' FileList - an extracted file from an archive (string) if there is one file, or an array of strings if there are several files to extract
' If the FileList parameter is omitted, all files from the archive will be extracted
Public Function ExtractFilesInCab(ByVal cabFileName As String, ByVal ExpandDir As String, Optional FileList As Variant) As Boolean
If Len(cabFileName) > 0 And Len(ExpandDir) > 0 Then
If Right$(ExpandDir, 1) = "\" Then
strOutputPath = Mid$(ExpandDir, 1, Len(ExpandDir) - 1)
Else
strOutputPath = ExpandDir
End If
If cabIsDir(strOutputPath) = False Then
If SHCreateDirectory(0, StrPtr(strOutputPath)) <> 0 Then Exit Function
End If
If VarType(FileList) = vbString Then
strFileToExtract = FileList
ElseIf VarType(FileList) = vbArray + vbString Then ' If it is an array of strings
strFileToExtract = ""
arrFilesToExtract = FileList
IsFilesList = True
Else
strFileToExtract = ""
End If
CountFilesSuccessfullyExtracted = 0
If SetupIterateCabinet(StrPtr(cabFileName), 0, AddressOf CabinetCallback, sicExtract) Then
If IsFilesList = False Then
If CountFilesSuccessfullyExtracted = 1 Or Len(strFileToExtract) = 0 Then ExtractFilesInCab = True
Else
If CountFilesSuccessfullyExtracted = UBound(arrFilesToExtract) + 1 Then ExtractFilesInCab = True
End If
End If
If IsFilesList = True Then
IsFilesList = False
Erase arrFilesToExtract
End If
End If
End Function
Download an example
-
Re: A module for reading CAB archives
Quote:
Originally Posted by
VanGoghGaming
Yeah, if the callback functions are also CDecl then you need the Add-in because it knows how to clear the stack after the function call.
By the way, I found a class module today that implements the ability to connect all CDecl functions, even if they are callback functions, without depending on the add-on.
Today, I just happened to stumble across the CAB packaging and unpacking code on the Internet. Right here: https://www.jsware.net/jsware/vbcode.html#cab1
Before that, I couldn't find such a code on the Internet for some reason, and it came to me to write everything myself. And then suddenly I found it. But the most important thing is that this project has a complete class module for working with CDecl. To do this, you can download the project "vbcab2.zip (20 KB)" from that site and there will be this class module.
There's a "cCDECL.cls" file inside. I really liked it, I've been looking for a way to implement CDecl without any dependencies for a long time.
The project there is very interesting, of course, it's a pity I didn't meet him earlier, but I still have a better project. Since I have implemented the highest compression ratio in LZX:21. But they don't. And my project does not create temporary files for me either.
-
Re: A module for reading CAB archives
Btw, go to https://github.com/Planet-Source-Code and you can search for cCDECL.cls in the org only.
It's a class by Paul Caton but the latest version can be found in some of LaVolpe's submissions.
cheers,
</wqw>
-
Re: A module for reading CAB archives
New update! I have released a new version 2.1. I only recently noticed that the SetupIterateCabinet function does not set attributes when unpacking files for some reason. I had to manually set the attributes for each file extracted from the archive myself, so I had to write a new version. For some reason, Microsoft did not take care of this, without any idea why they thought that the SetupIterateCabinet function should not set file attributes... Thank them for at least setting the date and time for the files! :)
Now all extracted files from the CAB archive have the correct attributes set!
New module code:
Code:
Option Explicit
'///////////////////////////////////////////////////
'// Module for reading and unpacking CAB archives //
'// Copyright (c) 2025-02-08 by HackerVlad //
'// e-mail: [email protected] //
'// Version 2.1 (32 and 64-bit compatible) //
'///////////////////////////////////////////////////
' API declarations ...
#If VBA7 = 0 Then
Private Declare Function SetupIterateCabinet Lib "setupapi" Alias "SetupIterateCabinetW" (ByVal CabinetFile As Long, ByVal Reserved As Long, ByVal MsgHandler As Long, ByVal Context As Long) As Long
Private Declare Function GetFileAttributesEx Lib "kernel32" Alias "GetFileAttributesExW" (ByVal lpFileName As Long, ByVal fInfoLevelId As Long, ByRef lpFileInformation As Any) As Long
Private Declare Function SHCreateDirectory Lib "shell32" (ByVal hwnd As Long, ByVal pszPath As Long) As Long
Private Declare Function PathRemoveFileSpec Lib "shlwapi" Alias "PathRemoveFileSpecW" (ByVal pszPath As Long) As Long
Private Declare Function SysReAllocString Lib "oleaut32" (ByVal pBSTR As Long, ByVal psz As Long) As Long
Private Declare Sub SysFreeString Lib "oleaut32" (ByVal bstr As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function SetFileAttributes Lib "kernel32" Alias "SetFileAttributesW" (ByVal lpFileName As Long, ByVal dwFileAttributes As Long) As Long
Private Enum LongPtr
[_]
End Enum
#Else
Private Declare PtrSafe Function SetupIterateCabinet Lib "setupapi" Alias "SetupIterateCabinetW" (ByVal CabinetFile As LongPtr, ByVal Reserved As Long, ByVal MsgHandler As LongPtr, ByVal Context As Long) As Long
Private Declare PtrSafe Function GetFileAttributesEx Lib "kernel32" Alias "GetFileAttributesExW" (ByVal lpFileName As LongPtr, ByVal fInfoLevelId As Long, ByRef lpFileInformation As Any) As Long
Private Declare PtrSafe Function SHCreateDirectory Lib "shell32" (ByVal hwnd As Long, ByVal pszPath As LongPtr) As Long
Private Declare PtrSafe Function PathRemoveFileSpec Lib "shlwapi" Alias "PathRemoveFileSpecW" (ByVal pszPath As LongPtr) As Long
Private Declare PtrSafe Function SysReAllocString Lib "oleaut32" (ByVal pBSTR As LongPtr, ByVal psz As LongPtr) As Long
Private Declare PtrSafe Sub SysFreeString Lib "oleaut32" (ByVal bstr As LongPtr)
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare PtrSafe Function SetFileAttributes Lib "kernel32" Alias "SetFileAttributesW" (ByVal lpFileName As LongPtr, ByVal dwFileAttributes As Long) As Long
#End If
' Constants ...
Private Const MAXPATH = 260
Private Const FILEOP_DOIT = 1
Private Const FILEOP_SKIP = 2
Private Const SPFILENOTIFY_FILEINCABINET = &H11
Private Const SPFILENOTIFY_FILEEXTRACTED = &H13
Private Const GetFileExInfoStandard As Long = 0
' Own fictional constants ...
Private Const sicList = 568
Private Const sicCount = 569
Private Const sicExtract = 570
' Variables for temporary data storage ...
Dim CountFilesSuccessfullyExtracted As Long, SetAttribsFile As Long, lngCount As Long
Dim strFileToExtract As String, strOutputPath As String
Dim arrFilesToExtract() As String
Dim arrListFilesCab() As CabInfo
Dim IsFilesList As Boolean
' Structures ...
Public Type CabInfo
cabFileName As String
cabFileSize As Long
cabDosDate As Integer
cabDosTime As Integer
cabDosAttribs As Integer
End Type
Private Type FileInCabinetInfoW
NameInCabinet As LongPtr
FileSize As Long
Win32Error As Long
DosDate As Integer
DosTime As Integer
DosAttribs As Integer
FullTargetName(MAXPATH - 1) As Integer ' WCHAR FullTargetName[MAX_PATH];
End Type
Private Type FILEPATHS
Target As LongPtr
Source As LongPtr
Win32Error As Integer
Flags As Long
End Type
Private Type WIN32_FILE_ATTRIBUTE_DATA
dwFileAttributes As Long
ftCreationTime As Currency
ftLastAccessTime As Currency
ftLastWriteTime As Currency
nFileSizeHigh As Long
nFileSizeLow As Long
End Type
' Does the directory exist (IsDir)
Public Function cabIsDir(ByVal path As String) As Boolean
Dim tAttr As WIN32_FILE_ATTRIBUTE_DATA
If GetFileAttributesEx(StrPtr(path), GetFileExInfoStandard, tAttr) <> 0 Then
If (tAttr.dwFileAttributes And vbDirectory) <> 0 Then
cabIsDir = True
End If
End If
End Function
' Convert the full file path to the folder path (always returns "\" at the end)
Public Function cabExtractFilePath(ByVal FileName As String) As String
Dim lNullPos As Long
Dim pszPath As String
pszPath = FileName
PathRemoveFileSpec StrPtr(pszPath)
lNullPos = InStr(1, pszPath, vbNullChar)
If lNullPos Then
pszPath = Left$(pszPath, lNullPos - 1)
If Right$(pszPath, 1) <> "\" Then pszPath = pszPath & "\"
cabExtractFilePath = pszPath
Else
cabExtractFilePath = FileName
End If
End Function
Private Function CabinetCallback(ByVal Context As Long, ByVal Notification As Long, Param1 As FileInCabinetInfoW, ByVal Param2 As Long) As Long
If Notification = SPFILENOTIFY_FILEINCABINET Then
Dim FileNameInCab As String
Select Case Context
Case sicCount
lngCount = lngCount + 1
CabinetCallback = FILEOP_SKIP ' Skip the file and go through the list of files next
Case sicList
SysReAllocString VarPtr(FileNameInCab), Param1.NameInCabinet
' Add a position to the UDT array
ReDim Preserve arrListFilesCab(lngCount)
arrListFilesCab(lngCount).cabFileName = FileNameInCab
arrListFilesCab(lngCount).cabFileSize = Param1.FileSize
arrListFilesCab(lngCount).cabDosDate = Param1.DosDate
arrListFilesCab(lngCount).cabDosTime = Param1.DosTime
arrListFilesCab(lngCount).cabDosAttribs = Param1.DosAttribs
lngCount = lngCount + 1
CabinetCallback = FILEOP_SKIP ' Skip the file and go through the list of files next
SysFreeString StrPtr(FileNameInCab)
Case sicExtract
Dim FileName As String, FilePath As String
Dim i As Long
SysReAllocString VarPtr(FileNameInCab), Param1.NameInCabinet
FileName = strOutputPath & "\" & FileNameInCab
' We fill in the value of the structure with the filename of the extracted file (+1 character at the end of the line is vbNullChar)
CopyMemory Param1.FullTargetName(0), ByVal StrPtr(FileName), LenB(FileName) + 1
If IsFilesList = False Then
If strFileToExtract = FileNameInCab Or Len(strFileToExtract) = 0 Then
FilePath = cabExtractFilePath(FileName)
If cabIsDir(FilePath) = False Then SHCreateDirectory 0, StrPtr(FilePath)
SetAttribsFile = Param1.DosAttribs ' Remember the attributes
CabinetCallback = FILEOP_DOIT ' Extract the file
CountFilesSuccessfullyExtracted = CountFilesSuccessfullyExtracted + 1
Else
CabinetCallback = FILEOP_SKIP ' Skip the file and go through the list of files next
End If
Else
Dim ExtractCurrentFile As Boolean
For i = 0 To UBound(arrFilesToExtract)
If arrFilesToExtract(i) = FileNameInCab Then
ExtractCurrentFile = True
Exit For
End If
Next
If ExtractCurrentFile = True Then
FilePath = cabExtractFilePath(FileName)
If cabIsDir(FilePath) = False Then SHCreateDirectory 0, StrPtr(FilePath)
SetAttribsFile = Param1.DosAttribs ' Remember the attributes
CabinetCallback = FILEOP_DOIT ' Extract the file
CountFilesSuccessfullyExtracted = CountFilesSuccessfullyExtracted + 1
Else
CabinetCallback = FILEOP_SKIP ' Skip the file and go through the list of files next
End If
End If
SysFreeString StrPtr(FileNameInCab)
End Select
ElseIf Notification = SPFILENOTIFY_FILEEXTRACTED Then
Dim fp As FILEPATHS
LSet fp = Param1
If fp.Win32Error = 0 Then ' If the file has been successfully extracted from the archive
' Manually set the attributes of the extracted file yourself,
' as Microsoft kindly refused to do this in the SetupIterateCabinet function
SetFileAttributes fp.Target, SetAttribsFile
End If
End If
End Function
' Get a list of files inside the CAB archive
Public Function GetFilesListInCab(ByVal cabFileName As String, arrCabInfo() As CabInfo) As Long
lngCount = 0
If SetupIterateCabinet(StrPtr(cabFileName), 0, AddressOf CabinetCallback, sicList) Then
arrCabInfo = arrListFilesCab
GetFilesListInCab = lngCount
Erase arrListFilesCab
End If
End Function
' Get count of files inside the CAB archive
Public Function GetFilesCountInCab(ByVal cabFileName As String) As Long
lngCount = 0
If SetupIterateCabinet(StrPtr(cabFileName), 0, AddressOf CabinetCallback, sicCount) Then
GetFilesCountInCab = lngCount
End If
End Function
' Extract files from the CAB archive
' FileList - an extracted file from an archive (string) if there is one file, or an array of strings if there are several files to extract
' If the FileList parameter is omitted, all files from the archive will be extracted
Public Function ExtractFilesInCab(ByVal cabFileName As String, ByVal ExpandDir As String, Optional FileList As Variant) As Boolean
If Len(cabFileName) > 0 And Len(ExpandDir) > 0 Then
If Right$(ExpandDir, 1) = "\" Then
strOutputPath = Mid$(ExpandDir, 1, Len(ExpandDir) - 1)
Else
strOutputPath = ExpandDir
End If
If cabIsDir(strOutputPath) = False Then
If SHCreateDirectory(0, StrPtr(strOutputPath)) <> 0 Then Exit Function
End If
If VarType(FileList) = vbString Then
strFileToExtract = FileList
ElseIf VarType(FileList) = vbArray + vbString Then ' If it is an array of strings
strFileToExtract = ""
arrFilesToExtract = FileList
IsFilesList = True
Else
strFileToExtract = ""
End If
CountFilesSuccessfullyExtracted = 0
If SetupIterateCabinet(StrPtr(cabFileName), 0, AddressOf CabinetCallback, sicExtract) Then
If IsFilesList = False Then
If CountFilesSuccessfullyExtracted = 1 Or Len(strFileToExtract) = 0 Then ExtractFilesInCab = True
Else
If CountFilesSuccessfullyExtracted = UBound(arrFilesToExtract) + 1 Then ExtractFilesInCab = True
End If
End If
If IsFilesList = True Then
IsFilesList = False
Erase arrFilesToExtract
End If
End If
End Function
Download an example
-
Re: A module for reading CAB archives
New version! Version 2.5.
Main changes:
- Fixed bug with an incorrect file name for files extracted from the archive, in some rare cases. The ZeroMemory function has been added for this purpose.
- Full support for 64-bit systems and unicode file names, project support in a modern Twin Basic development environment.
- Added compatibility with older versions of Windows, up to Windows 98. However, keep in mind that decompressing archives compressed with LZX21 only works starting with Windows Me+.
- In Windows 98, the SetupIterateCabinetA function is used, but in this system it allows you to extract archives only compressed using MSZIP.
New module code:
Code:
Option Explicit
'////////////////////////////////////////////////////////////////////
'// Module for reading and unpacking CAB archives //
'// Copyright (c) 2025-02-20 by HackerVlad //
'// e-mail: [email protected] //
'// Version 2.5 (32 and 64-bit compatible) & Windows 98 compatible //
'////////////////////////////////////////////////////////////////////
' API declarations ...
#If VBA7 = 0 Then
Private Declare Function SetupIterateCabinetW Lib "setupapi" (ByVal CabinetFile As Long, ByVal Reserved As Long, ByVal MsgHandler As Long, ByVal Context As Long) As Long
Private Declare Function SetupIterateCabinetA Lib "setupapi" (ByVal CabinetFile As String, ByVal Reserved As Long, ByVal MsgHandler As Long, ByVal Context As Long) As Long
Private Declare Function PathRemoveFileSpecW Lib "shlwapi" (ByVal pszPath As Long) As Long
Private Declare Function SHCreateDirectory Lib "shell32" (ByVal hwnd As Long, ByVal pszPath As Long) As Long
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp" (ByVal lpPath As String) As Long ' For old versions of Windows
Private Declare Function SysReAllocString Lib "oleaut32" (ByVal pBSTR As Long, ByVal psz As Long) As Long
Private Declare Sub SysFreeString Lib "oleaut32" (ByVal bstr As Long)
Private Declare Function GetFileAttributesEx Lib "kernel32" Alias "GetFileAttributesExW" (ByVal lpFileName As Long, ByVal fInfoLevelId As Long, ByRef lpFileInformation As Any) As Long
Private Declare Function lstrlenA Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Function SetFileAttributesW Lib "kernel32" (ByVal lpFileName As Long, ByVal dwFileAttributes As Long) As Long
Private Declare Function SetFileAttributesA Lib "kernel32" (ByVal lpFileName As Long, ByVal dwFileAttributes As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As Long)
Private Enum LongPtr
[_]
End Enum
#Else
Private Declare PtrSafe Function SetupIterateCabinetW Lib "setupapi" (ByVal CabinetFile As LongPtr, ByVal Reserved As Long, ByVal MsgHandler As LongPtr, ByVal Context As Long) As Long
Private Declare PtrSafe Function SetupIterateCabinetA Lib "setupapi" (ByVal CabinetFile As String, ByVal Reserved As Long, ByVal MsgHandler As LongPtr, ByVal Context As Long) As Long
Private Declare PtrSafe Function PathRemoveFileSpecW Lib "shlwapi" (ByVal pszPath As LongPtr) As Long
Private Declare PtrSafe Function SHCreateDirectory Lib "shell32" (ByVal hwnd As Long, ByVal pszPath As LongPtr) As Long
Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp" (ByVal lpPath As String) As Long ' For old versions of Windows
Private Declare PtrSafe Function SysReAllocString Lib "oleaut32" (ByVal pBSTR As LongPtr, ByVal psz As LongPtr) As Long
Private Declare PtrSafe Sub SysFreeString Lib "oleaut32" (ByVal bstr As LongPtr)
Private Declare PtrSafe Function GetFileAttributesEx Lib "kernel32" Alias "GetFileAttributesExW" (ByVal lpFileName As LongPtr, ByVal fInfoLevelId As Long, ByRef lpFileInformation As Any) As Long
Private Declare PtrSafe Function lstrlenA Lib "kernel32" (ByVal lpString As LongPtr) As Long
Private Declare PtrSafe Function SetFileAttributesW Lib "kernel32" (ByVal lpFileName As LongPtr, ByVal dwFileAttributes As Long) As Long
Private Declare PtrSafe Function SetFileAttributesA Lib "kernel32" (ByVal lpFileName As String, ByVal dwFileAttributes As Long) As Long
Private Declare PtrSafe Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As Any) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare PtrSafe Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As Long)
#End If
' Constants ...
Private Const MAXPATH = 260
Private Const FILEOP_DOIT = 1
Private Const FILEOP_SKIP = 2
Private Const SPFILENOTIFY_FILEINCABINET = &H11
Private Const SPFILENOTIFY_FILEEXTRACTED = &H13
Private Const GetFileExInfoStandard As Long = 0
' Own fictional constants ...
Private Const sicList = 568
Private Const sicCount = 569
Private Const sicExtract = 570
' Variables for temporary data storage ...
Dim CountFilesSuccessfullyExtracted As Long, SetAttribsFile As Long, lngCount As Long
Dim strFileToExtract As String, strOutputPath As String
Dim arrFilesToExtract() As String
Dim arrListFilesCab() As CabInfo
Dim IsFilesList As Boolean, WinANSI As Boolean
' Structures ...
Public Type CabInfo
cabFileName As String
cabFileSize As Long
cabDosDate As Integer
cabDosTime As Integer
cabDosAttribs As Integer
End Type
Private Type FileInCabinetInfoW
NameInCabinet As LongPtr
FileSize As Long
Win32Error As Long
DosDate As Integer
DosTime As Integer
DosAttribs As Integer
FullTargetName(MAXPATH - 1) As Integer ' WCHAR FullTargetName[MAX_PATH];
End Type
Private Type FILEPATHS
Target As LongPtr
Source As LongPtr
Win32Error As Integer
Flags As Long
End Type
Private Type WIN32_FILE_ATTRIBUTE_DATA
dwFileAttributes As Long
ftCreationTime As Currency
ftLastAccessTime As Currency
ftLastWriteTime As Currency
nFileSizeHigh As Long
nFileSizeLow As Long
End Type
' Does the directory exist (IsDir)
Public Function cabIsDir(ByVal path As String) As Boolean
Dim tAttr As WIN32_FILE_ATTRIBUTE_DATA
Dim DirAttr As Long
If GetFileAttributesEx(StrPtr(path), GetFileExInfoStandard, tAttr) <> 0 Then
If (tAttr.dwFileAttributes And vbDirectory) <> 0 Then ' ???? ??? ???????
cabIsDir = True
End If
Else
On Error Resume Next
If Dir(path, vbDirectory + 7) <> vbNullString Then
DirAttr = GetAttr(path)
If (DirAttr And vbDirectory) <> 0 Then cabIsDir = True
End If
End If
End Function
' Convert the full file path to the folder path (always returns "\" at the end)
Public Function cabExtractFilePath(ByVal FileName As String) As String
Dim lNullPos As Long
Dim pszPath As String
pszPath = FileName
PathRemoveFileSpecW StrPtr(pszPath)
lNullPos = InStr(1, pszPath, vbNullChar)
If lNullPos Then
pszPath = Left$(pszPath, lNullPos - 1)
If Right$(pszPath, 1) <> "\" Then pszPath = pszPath & "\"
cabExtractFilePath = pszPath
Else
cabExtractFilePath = FileName
End If
End Function
' Create multiple folders at once, for all versions of Windows (always requires a "\" at the end for systems less than WinXP)
Public Function MakeDir(ByVal path As String) As Boolean
Dim inf(36) As Long
Dim IsXPAndLater As Boolean
inf(0) = 148: GetVersionEx inf(0): IsXPAndLater = inf(4) = 2 And inf(1) >= 5 And inf(2) >= 1 ' Get the Windows version
If IsXPAndLater = True Then
If SHCreateDirectory(0, StrPtr(path)) = 0 Then MakeDir = True
Else
If MakeSureDirectoryPathExists(path) = 1 Then MakeDir = True
End If
End Function
Private Function CabinetCallback(ByVal Context As Long, ByVal Notification As Long, Param1 As FileInCabinetInfoW, ByVal Param2 As Long) As Long
If Notification = SPFILENOTIFY_FILEINCABINET Then
Dim FileNameInCab As String
Dim bytesLen As Long
Select Case Context
Case sicCount
lngCount = lngCount + 1
CabinetCallback = FILEOP_SKIP ' Skip the file and go through the list of files next
Case sicList
If WinANSI = False Then
SysReAllocString VarPtr(FileNameInCab), Param1.NameInCabinet
Else
bytesLen = lstrlenA(Param1.NameInCabinet)
FileNameInCab = Space$(bytesLen)
CopyMemory ByVal FileNameInCab, ByVal Param1.NameInCabinet, bytesLen + 1 ' Converts to Unicode using an implicit (hidden) conversion
End If
' Add a position to the UDT array
ReDim Preserve arrListFilesCab(lngCount)
arrListFilesCab(lngCount).cabFileName = FileNameInCab
arrListFilesCab(lngCount).cabFileSize = Param1.FileSize
arrListFilesCab(lngCount).cabDosDate = Param1.DosDate
arrListFilesCab(lngCount).cabDosTime = Param1.DosTime
arrListFilesCab(lngCount).cabDosAttribs = Param1.DosAttribs
lngCount = lngCount + 1
CabinetCallback = FILEOP_SKIP ' Skip the file and go through the list of files next
If WinANSI = False Then SysFreeString StrPtr(FileNameInCab)
Case sicExtract
Dim FileName As String, FilePath As String, FillFileName As String
Dim i As Long
If WinANSI = False Then
SysReAllocString VarPtr(FileNameInCab), Param1.NameInCabinet
Else
bytesLen = lstrlenA(Param1.NameInCabinet)
FileNameInCab = Space$(bytesLen)
CopyMemory ByVal FileNameInCab, ByVal Param1.NameInCabinet, bytesLen + 1 ' Converts to Unicode using an implicit (hidden) conversion
End If
FileName = strOutputPath & "\" & FileNameInCab
' We fill in the value of the structure with the filename of the extracted file (+1 character at the end of the line is vbNullChar)
If Not WinANSI Then FillFileName = FileName Else FillFileName = StrConv(FileName, vbFromUnicode) ' Convert to ANSI
If Not WinANSI Then ZeroMemory Param1.FullTargetName(0), 520 Else ZeroMemory Param1.FullTargetName(0), 260
CopyMemory Param1.FullTargetName(0), ByVal StrPtr(FillFileName), LenB(FillFileName) + 1
If IsFilesList = False Then
If strFileToExtract = FileNameInCab Or Len(strFileToExtract) = 0 Then
FilePath = cabExtractFilePath(FileName)
If cabIsDir(FilePath) = False Then MakeDir FilePath
SetAttribsFile = Param1.DosAttribs ' Remember the attributes
CabinetCallback = FILEOP_DOIT ' Extract the file
CountFilesSuccessfullyExtracted = CountFilesSuccessfullyExtracted + 1
Else
CabinetCallback = FILEOP_SKIP ' Skip the file and go through the list of files next
End If
Else
Dim ExtractCurrentFile As Boolean
For i = 0 To UBound(arrFilesToExtract)
If arrFilesToExtract(i) = FileNameInCab Then
ExtractCurrentFile = True
Exit For
End If
Next
If ExtractCurrentFile = True Then
FilePath = cabExtractFilePath(FileName)
If cabIsDir(FilePath) = False Then MakeDir FilePath
SetAttribsFile = Param1.DosAttribs ' Remember the attributes
CabinetCallback = FILEOP_DOIT ' Extract the file
CountFilesSuccessfullyExtracted = CountFilesSuccessfullyExtracted + 1
Else
CabinetCallback = FILEOP_SKIP ' Skip the file and go through the list of files next
End If
End If
If WinANSI = False Then SysFreeString StrPtr(FileNameInCab)
End Select
ElseIf Notification = SPFILENOTIFY_FILEEXTRACTED Then
Dim fp As FILEPATHS
LSet fp = Param1
If fp.Win32Error = 0 Then ' If the file has been successfully extracted from the archive
' Manually set the attributes of the extracted file yourself,
' as Microsoft kindly refused to do this in the SetupIterateCabinet function
If SetFileAttributesW(fp.Target, SetAttribsFile) = 0 Then
SetFileAttributesA fp.Target, SetAttribsFile
End If
End If
End If
End Function
' Get a list of files inside the CAB archive
Public Function GetFilesListInCab(ByVal cabFileName As String, arrCabInfo() As CabInfo) As Long
lngCount = 0
WinANSI = False
If SetupIterateCabinetW(StrPtr(cabFileName), 0, AddressOf CabinetCallback, sicList) Then
arrCabInfo = arrListFilesCab
GetFilesListInCab = lngCount
Erase arrListFilesCab
Else
WinANSI = True
If SetupIterateCabinetA(cabFileName, 0, AddressOf CabinetCallback, sicList) Then
arrCabInfo = arrListFilesCab
GetFilesListInCab = lngCount
Erase arrListFilesCab
End If
End If
End Function
' Get count of files inside the CAB archive
Public Function GetFilesCountInCab(ByVal cabFileName As String) As Long
lngCount = 0
If SetupIterateCabinetW(StrPtr(cabFileName), 0, AddressOf CabinetCallback, sicCount) Then
GetFilesCountInCab = lngCount
Else
If SetupIterateCabinetA(cabFileName, 0, AddressOf CabinetCallback, sicCount) Then GetFilesCountInCab = lngCount
End If
End Function
' Extract files from the CAB archive
' Extracting archives compressed using MSZIP works in Windows 95+
' Extracting archives compressed using LZX21 works in Windows Me+
' FileList - an extracted file from an archive (string) if there is one file, or an array of strings if there are several files to extract
' If the FileList parameter is omitted, all files from the archive will be extracted
Public Function ExtractFilesInCab(ByVal cabFileName As String, ByVal ExpandDir As String, Optional FileList As Variant) As Boolean
If Len(cabFileName) > 0 And Len(ExpandDir) > 0 Then
If Right$(ExpandDir, 1) = "\" Then
strOutputPath = Mid$(ExpandDir, 1, Len(ExpandDir) - 1)
Else
strOutputPath = ExpandDir
End If
If cabIsDir(strOutputPath) = False Then
If MakeDir(strOutputPath) = False Then Exit Function
End If
If VarType(FileList) = vbString Then
strFileToExtract = FileList
ElseIf VarType(FileList) = vbArray + vbString Then ' If it is an array of strings
strFileToExtract = ""
arrFilesToExtract = FileList
IsFilesList = True
Else
strFileToExtract = ""
End If
CountFilesSuccessfullyExtracted = 0
WinANSI = False
If SetupIterateCabinetW(StrPtr(cabFileName), 0, AddressOf CabinetCallback, sicExtract) Then
If IsFilesList = False Then
If CountFilesSuccessfullyExtracted = 1 Or Len(strFileToExtract) = 0 Then ExtractFilesInCab = True
Else
If CountFilesSuccessfullyExtracted = UBound(arrFilesToExtract) + 1 Then ExtractFilesInCab = True
End If
Else
WinANSI = True
If SetupIterateCabinetA(cabFileName, 0, AddressOf CabinetCallback, sicExtract) Then
If IsFilesList = False Then
If CountFilesSuccessfullyExtracted = 1 Or Len(strFileToExtract) = 0 Then ExtractFilesInCab = True
Else
If CountFilesSuccessfullyExtracted = UBound(arrFilesToExtract) + 1 Then ExtractFilesInCab = True
End If
End If
End If
If IsFilesList = True Then
IsFilesList = False
Erase arrFilesToExtract
End If
End If
End Function
Download an example
