VB and VBA Users Source Code: Compress/uncompress an file or directory
[
Home
|
Contents
|
Search
|
Reply
| Previous | Next ]
VB/VBA Source Code
Compress/uncompress an file or directory
By:
Andrew Baker
Email (spam proof):
Email the originator of this post
Date:
Tuesday, November 05, 2002
Hits:
1248
Category:
Windows API
Article:
The following code demonstrates how to compress/uncompress files and directories. Option Explicit Private Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long Private Declare Function DeviceIoControl Lib "kernel32" (ByVal hDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As Integer, ByVal nInBufferSize As Integer, lpOutBuffer As Long, ByVal nOutBufferSize As Long, lpBytesReturned As Long, ByVal lpOverlapped As Any) As Long Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long Private Const FILE_ATTRIBUTE_COMPRESSED As Long = &H800 'Purpose : Compress or uncompress a NT/Win2k file/directory 'Inputs : sFilename The file name or directory to compress/uncompress. ' bCompressFile If True compresses the file/directory else uncompresses it. 'Outputs : Returns True if the function succeeded 'Author : Andrew Baker 'Date : 13/11/2000 10:14 'Notes : 'Revisions : Function CompressFile(sFilename As String, bCompressFile As Boolean) As Boolean Dim lFileHwnd As Long, lBytesRtn As Long Dim FSCTL_SET_COMPRESSION As Long, FSCTL_GET_COMPRESSION As Long Const FILE_FLAG_BACKUP_SEMANTICS As Long = &H2000000, FILE_READ_DATA As Long = &H1& Const FILE_WRITE_DATA As Long = &H2&, FILE_DEVICE_FILE_SYSTEM As Long = &H9& Const METHOD_BUFFERED As Long = 0&, FILE_ANY_ACCESS As Long = 0& Const COMPRESSION_FORMAT_NONE As Long = 0&, COMPRESSION_FORMAT_DEFAULT As Long = 1& Const GENERIC_READ As Long = &H80000000, GENERIC_WRITE As Long = &H40000000 Const GENERIC_EXECUTE As Long = &H20000000, GENERIC_ALL As Long = &H10000000 Const FILE_SHARE_READ As Long = &H1&, FILE_SHARE_WRITE As Long = &H2& Const FILE_SHARE_DELETE As Long = &H4&, CREATE_NEW As Long = 1& Const CREATE_ALWAYS As Long = 2&, OPEN_EXISTING As Long = 3& Const OPEN_ALWAYS As Long = 4&, TRUNCATE_EXISTING As Long = 5& Const INVALID_HANDLE_VALUE As Long = -1& On Error GoTo ErrFailed FSCTL_SET_COMPRESSION = (CLng(FILE_DEVICE_FILE_SYSTEM) * (2 ^ 16)) Or (CLng(FILE_READ_DATA Or FILE_WRITE_DATA) * (2 ^ 14)) Or (CLng(16) * (2 ^ 2)) Or METHOD_BUFFERED 'Note, FSCTL_GET_COMPRESSION = (CLng(FILE_DEVICE_FILE_SYSTEM) * (2 ^ 16)) Or (CLng(FILE_ANY_ACCESS) * (2 ^ 14)) Or (CLng(15) * (2 ^ 2)) Or METHOD_BUFFERED lFileHwnd = CreateFile(sFilename, GENERIC_ALL, FILE_SHARE_WRITE And FILE_SHARE_READ, 0&, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0&) If lFileHwnd = INVALID_HANDLE_VALUE Then 'Failed to get file handle Debug.Print "Error opening " & sFilename & ". Error = " & ErrorDescriptionDLL Else 'Got file handle If bCompressFile Then 'Compress file CompressFile = DeviceIoControl(lFileHwnd, FSCTL_SET_COMPRESSION, COMPRESSION_FORMAT_DEFAULT, 2&, 0&, 0&, lBytesRtn, 0&) Else 'Uncompress file CompressFile = DeviceIoControl(lFileHwnd, FSCTL_SET_COMPRESSION, COMPRESSION_FORMAT_NONE, 2&, 0&, 0&, lBytesRtn, 0&) End If End If Call CloseHandle(lFileHwnd) Exit Function ErrFailed: Debug.Print Err.Description Debug.Assert False End Function 'Purpose : Tests to see if a file has been compressed. 'Inputs : sFilename The file name to test the compressed state. 'Outputs : Returns True if the file has been compressed 'Author : Andrew Baker 'Date : 13/11/2000 10:14 'Notes : 'Revisions : Public Function FileIsCompressed(ByVal sFilename As String) As Boolean Dim lAttrib As Long On Error GoTo ErrFailed lAttrib = GetFileAttributes(sFilename) If lAttrib And FILE_ATTRIBUTE_COMPRESSED Then FileIsCompressed = True Else FileIsCompressed = False End If Exit Function ErrFailed: Debug.Print Err.Description Debug.Assert False End Function 'Purpose : Tests to see if a drive is using NTFS file system. 'Inputs : sDriveName The drive name to test the file system of. 'Outputs : Returns True if the drive is an NTFS drive, else returns false 'Author : Andrew Baker 'Date : 13/11/2000 10:14 'Notes : 'Revisions : Public Function FileIsNTFS(ByVal sDriveName As String) As Boolean Dim sBufVolume As String, sBufSystemName As String, sVolume As String * 3 Dim lSerialNum As Long, lSystemFlags As Long, lComponentLen As Long Dim lRet As Long On Error Resume Next sBufVolume = String$(256, 0) sBufSystemName = String$(256, 0) sVolume = UCase$(sDriveName) lRet = GetVolumeInformation(sVolume, sBufVolume, Len(sBufVolume) - 1, lSerialNum, lComponentLen, lSystemFlags, sBufSystemName, Len(sBufSystemName) - 1) If lRet = 0 Then FileIsNTFS = False Else If UCase$(Mid$(sBufSystemName, 1, 4)) = "NTFS" Then FileIsNTFS = True Else FileIsNTFS = False End If End If On Error GoTo 0 End Function 'Demonstration routine Sub Test() CompressFile "C:\test.log", True MsgBox "C:\test.log compressed = " & FileIsCompressed("C:\test.log"), vbInformation CompressFile "C:\test.log", False MsgBox "C:\test.log compressed = " & FileIsCompressed("C:\test.log"), vbInformation End Sub
Terms and Conditions
Support this site
Download a trial version of the Excel Workbook Rebuilder
