Binaryworld - Taking advantage of NTFS inbuilt compression using APIs (Only for NTFS ... [ VB -> ZIP-Unzip ]

Windows NT/2000 supports compression on individual files, folders, and entire NTFS volumes. Files compressed on an NTFS volume can be read and written by any Windows-based application without first being decompressed by another program.

Decompression occurs automatically when the file is read. The file is compressed again when it is closed or saved. Compressed files and folders have an attribute of C when viewed in Windows Explorer.

Only NTFS can read the compressed form of the data. When an application such as Microsoft® Word or an operating system command such as copy requests access to the file, the compression filter driver decompresses the file before making it available. For example, if you copy a compressed file from another Windows NT/2000–based computer to a compressed folder on your hard disk, the file is decompressed when read, copied, and then recompressed when saved.

In this article you will learn how to use DeviceIoControl API to set or remove compression on a specified file/folder. The DeviceIoControl function sends a control code directly to a specified device driver, causing the corresponding device to perform the corresponding operation.

Here we have used FSCTL_SET_COMPRESSION to set/remove compression on a specified file/folder on NTFS volume.

To set compression call DeviceIoControl with lpInBuffer parameter set to COMPRESSION_FORMAT_DEFAULT or COMPRESSION_FORMAT_LZNT1. To remove compression set lpInBuffer to COMPRESSION_FORMAT_NONE

You can check status of compression on a file or folder by calling GetFileAttributes and do logical AND of return flag with FILE_ATTRIBUTE_COMPRESSED. Here is the example

Click here to copy the following block

p_lngRtn = GetFileAttributes(strFullPath)

If p_lngRtn And FILE_ATTRIBUTE_COMPRESSED Then
IsCompressed = True
Else
IsCompressed = False
End If

To get the actual size on disk (compressed size) of a file/folder on a compressed volume call GetCompressedFileSize and if you want Actual size without compression then call GetFileSize API or VB inbuilt function FileLen

Step-By-Step Example

- Create a standard exe project
- Add two command button controls and one label control on the form1
- Add one drive control, one dir control and one file control on the form1
- Add the following code in form1

Click here to copy the following block

Private FSCTL_GET_COMPRESSION     As Long
Private FSCTL_SET_COMPRESSION     As Long

Private Const FILE_FLAG_BACKUP_SEMANTICS As Long = &H2000000
Private Const FILE_ATTRIBUTE_COMPRESSED As Long = &H800
Private Const FILE_READ_DATA       As Long = &H1&
Private Const FILE_WRITE_DATA       As Long = &H2&
Private Const FILE_DEVICE_FILE_SYSTEM   As Long = &H9&
Private Const METHOD_BUFFERED       As Long = 0&
Private Const FILE_ANY_ACCESS       As Long = 0&
Private Const COMPRESSION_FORMAT_NONE   As Long = 0&
Private Const COMPRESSION_FORMAT_DEFAULT As Long = 1&
Private Const GENERIC_READ       As Long = &H80000000
Private Const GENERIC_WRITE      As Long = &H40000000
Private Const GENERIC_EXECUTE     As Long = &H20000000
Private Const GENERIC_ALL       As Long = &H10000000
Private Const FILE_SHARE_READ     As Long = &H1&
Private Const FILE_SHARE_WRITE     As Long = &H2&
Private Const FILE_SHARE_DELETE    As Long = &H4&
Private Const CREATE_NEW        As Long = 1&
Private Const CREATE_ALWAYS      As Long = 2&
Private Const OPEN_EXISTING      As Long = 3&
Private Const OPEN_ALWAYS       As Long = 4&
Private Const TRUNCATE_EXISTING    As Long = 5&
Private Const INVALID_HANDLE_VALUE   As Long = -1&

Private Const FO_DELETE As Long = &H3

Private Type SHFILEOPSTRUCT
  hWnd As Long
  wFunc As Long
  pFrom As String
  pTo As String
  fFlags As Integer
  fAborted As Long
  hNameMaps As Long
  sProgress As String
End Type

Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" ( _
    ByRef lpFileOp As SHFILEOPSTRUCT) As Long

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 GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" ( _
    ByVal lpFileName As String) 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 GetCompressedFileSize Lib "kernel32.dll" Alias "GetCompressedFileSizeA" ( _
    ByVal lpFileName As String, _
    ByRef lpFileSizeHigh As Long) As Long

Private Declare Function GetFileSize Lib "kernel32.dll" ( _
    ByVal hFile As Long, _
    ByRef lpFileSizeHigh As Long) As Long

Const mFolder = "C:\TestDir"
Const mFile = "APIDemo.txt"
Dim ret As Long, hFile As Long
Dim iFile As Long, FilePath As String

Private Sub DoDemo()
  SetCompression True, FilePath
  CompressionStatus FilePath
End Sub

Function CompressionStatus(strPath As String, Optional ShowMsg As Boolean = True) As String
  Dim strmsg As String
  If IsCompressed(strPath) Then
    strmsg = "The file/folder is compressed" & vbCrLf
    strmsg = strmsg & "Actual Size : " & Round(FileLen(strPath) / 1024, 2) & " KB" & vbCrLf
    strmsg = strmsg & "Compressed Size : " & Round(GetCompressedFileSize(strPath, ByVal 0&) / 1024, 2) & " KB" & vbCrLf
  Else
    strmsg = "The file/folder is not compressed."
  End If
  CompressionStatus = strmsg
  If ShowMsg Then MsgBox strmsg
End Function

Private Sub Command1_Click()
  If File1.ListIndex < 0 Then MsgBox "Please select a file to compress/decompress", vbExclamation: Exit Sub

  If Command1.Caption = "Compress Selected File" Then
    SetCompression True, File1.Path & "\" & File1.FileName
  Else
    SetCompression False, File1.Path & "\" & File1.FileName
  End If
  Label1.Caption = CompressionStatus(File1.Path & "\" & File1.FileName, False)
  RefreshStatus
End Sub

Private Sub Command2_Click()
  If Dir1.Path = "" Then MsgBox "Please select a directory to compress/decompress", vbExclamation: Exit Sub

  If Command2.Caption = "Compress Selected Folder" Then
    SetCompression True, Dir1.Path
  Else
    SetCompression False, Dir1.Path
  End If
  Label1.Caption = CompressionStatus(Dir1.Path, False)
  RefreshStatus
End Sub

Private Sub Dir1_Change()
  File1.Path = Dir1.Path
  Label1.Caption = CompressionStatus(Dir1.Path, False)
  RefreshStatus
End Sub

Private Sub Drive1_Change()
  Dir1.Path = Drive1.Drive
  RefreshStatus
End Sub

Private Sub File1_Click()
  Label1.Caption = CompressionStatus(File1.Path & "\" & File1.FileName, False)
  RefreshStatus
End Sub

Private Sub Form_Load()
  On Error Resume Next
  '//Create new folder for demo
  MkDir mFolder
  MsgBox "Created new dir " & mFolder

  '//Create new file for demo
  FilePath = mFolder & "\" & mFile
  iFile = FreeFile

  MsgBox "Created new file " & FilePath

  Dim i

  '//write some sample data to the file
  Open FilePath For Output As #iFile
  For i = 0 To 10000
    Print #iFile, "This is test" & vbCrLf
  Next
  Close #iFile

  Command1.Caption = "Compress Selected File"
  Command2.Caption = "Decompress Selected Folder"
  Drive1.Drive = "C:"

  '//Quick Demo
  DoDemo
  RefreshStatus

  Dir1.Path = mFolder
  File1.ListIndex = 0

End Sub

Sub RefreshStatus()
  If IsNTFS(Dir1.Path) = False Then
    Command1.Caption = "N/A": Command1.Enabled = False
    Command2.Caption = "N/A": Command2.Enabled = False
    Label1.Caption = "NTFS Compression is only available in NTFS File system"
    Exit Sub
  End If

  If IsCompressed(File1.Path & "\" & File1.FileName) Then
    Command1.Caption = "Decompress Selected File"
  Else
    Command1.Caption = "Compress Selected File"
  End If

  If IsCompressed(Dir1.Path) Then
    Command2.Caption = "Decompress Selected Folder"
  Else
    Command2.Caption = "Compress Selected Folder"
  End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
  Dim SHDirOp As SHFILEOPSTRUCT

  With SHDirOp
    .wFunc = FO_DELETE
    .pFrom = mFolder
    '.fFlags = FOF_NOCONFIRMATION Or FOF_SILENT
  End With

  'Delete the directory
  SHFileOperation SHDirOp
End Sub

Private Sub SetCompression(ByVal bCompressed As Boolean, ByVal strFileName As String)
  Dim p_lngRtn            As Long
  Dim p_lngFileHwnd          As Long
  Dim p_lngBytesRtn          As Long

  ' NOTE: If you do only files, not directories,
  '    then the dwFlagsAndAttributes can be
  '    set to 0&

  'if folder to be compressed is opened or being accessed by some process then
  'CreateFile may fail to open the directory handle
  p_lngFileHwnd = CreateFile(strFileName, _
      GENERIC_ALL, _
      FILE_SHARE_WRITE And FILE_SHARE_READ, _
      0&, _
      OPEN_EXISTING, _
      FILE_FLAG_BACKUP_SEMANTICS, _
      0&)
  If p_lngFileHwnd <> INVALID_HANDLE_VALUE Then
    ' Everything is OK
    '//Now prepare Code for DeviceIO
    FSCTL_GET_COMPRESSION = GetCtlCode(FILE_DEVICE_FILE_SYSTEM, _
        15, _
        METHOD_BUFFERED, _
        FILE_ANY_ACCESS)

    FSCTL_SET_COMPRESSION = GetCtlCode(FILE_DEVICE_FILE_SYSTEM, _
        16, _
        METHOD_BUFFERED, _
        FILE_READ_DATA Or _
        FILE_WRITE_DATA)
  Else
    Err.Raise "Could not open file/directory name: " & strFileName & vbCrLf & "Error: " & Err.LastDllError, _
        9999, "SetCompression"
  End If

  If bCompressed = True Then
    '//Set Compression
    p_lngRtn = DeviceIoControl(p_lngFileHwnd, _
        FSCTL_SET_COMPRESSION, _
        COMPRESSION_FORMAT_DEFAULT, _
        2&, _
        0&, _
        0&, _
        p_lngBytesRtn, _
        0&)

  Else
    '//Remove Compression
    p_lngRtn = DeviceIoControl(p_lngFileHwnd, _
        FSCTL_SET_COMPRESSION, _
        COMPRESSION_FORMAT_NONE, _
        2&, _
        0&, _
        0&, _
        p_lngBytesRtn, _
        0&)
  End If

  If p_lngRtn = 0 Then
    If bCompressed = True Then
      Err.Raise "Compression failed for: " & strFileName, 9999, "SetCompression"
    Else
      Err.Raise "Decompression failed for: " & strFileName, 9999, "SetCompression"
    End If
  End If

  p_lngRtn = CloseHandle(p_lngFileHwnd)

End Sub

Private Function GetCtlCode(ByVal lngDeviceType As Long, _
              ByVal lngFunction As Long, _
              ByVal lngMethod As Long, _
              ByVal lngAccess As Long) As Long
  GetCtlCode = (CLng(lngDeviceType) * (2 ^ 16)) Or _
      (CLng(lngAccess) * (2 ^ 14)) Or _
      (CLng(lngFunction) * (2 ^ 2)) Or lngMethod
End Function

Private Function IsCompressed(ByVal strFullPath As String) As Boolean
  Dim p_lngRtn As Long

  p_lngRtn = GetFileAttributes(strFullPath)

  If p_lngRtn And FILE_ATTRIBUTE_COMPRESSED Then
    IsCompressed = True
  Else
    IsCompressed = False
  End If

End Function

Private Function IsNTFS(ByVal strFilePath As String) As Boolean
  Dim p_strVolBuffer         As String
  Dim p_strSystemName         As String
  Dim p_strVol            As String
  Dim p_lngSerialNum         As Long
  Dim p_lngSystemFlags        As Long
  Dim p_lngComponentLen        As Long
  Dim p_lngRtn            As Long

  p_strVolBuffer = String$(256, 0)
  p_strSystemName = String$(256, 0)
  p_strVol = UCase$(Mid$(strFilePath, 1, 3))

  p_lngRtn = GetVolumeInformation(p_strVol, _
      p_strVolBuffer, _
      Len(p_strVolBuffer) - 1, _
      p_lngSerialNum, _
      p_lngComponentLen, _
      p_lngSystemFlags, _
      p_strSystemName, _
      Len(p_strSystemName) - 1)
  If p_lngRtn = 0 Then
    IsNTFS = False
  Else
    If UCase$(Mid$(p_strSystemName, 1, 4)) = "NTFS" Then
      IsNTFS = True
    Else
      IsNTFS = False
    End If
  End If

End Function