Visual Basic Codes
Visual Basic > Files Directories Drives sample source codes

Compress-uncompress an file or directory

Compress-uncompress an file or directory

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
'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
'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
'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