Ordner-Komprimierung

Imports System.IO
   .............

   Private Const COMPRESSION_FORMAT_NONE As Short = 0
   Private Const COMPRESSION_FORMAT_LZNT1 As Short = 2

   Private Const FSCTL_SET_COMPRESSION As Integer = 639040

   Private Const FILE_SHARE_NONE As Short = 0
   Private Const OPEN_EXISTING As Short = 3
   Private Const INVALID_HANDLE_VALUE As Short = -1
   Private Const GENERIC_READ As Integer = &H80000000
   Private Const GENERIC_WRITE As Integer = &H40000000
   Private Const FILE_FLAG_BACKUP_SEMANTICS As Integer = &H2000000

   Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" _
             (ByVal lpFileName As String, _
              ByVal dwDesiredAccess As Integer, _
              ByVal dwShareMode As Integer, _
              ByVal lpSecurityAttributes As IntPtr, _
              ByVal dwCreationDisposition As Integer, _
              ByVal dwFlagsAndAttributes As Integer, _
              ByVal hTemplateFile As IntPtr) As IntPtr

   Private Declare Function CloseHandle Lib "kernel32" _
             (ByVal hObject As IntPtr) As Boolean

   Private Declare Function DeviceIoControl Lib "kernel32" _
             (ByVal hDevice As IntPtr, _
              ByVal dwIoControlCode As Integer, _
              ByRef lpInBuffer As Short, _
              ByVal nInBufferSize As Short, _
              ByVal lpOutBuffer As Integer, _
              ByVal nOutBufferSize As Integer, _
              ByRef lpBytesReturned As Integer, _
              ByVal lpOverlapped As IntPtr) As Boolean

   Private Sub CompressFolder(ByVal fullpath As String)
      Dim Files() As FileInfo
      Dim Subfolders() As DirectoryInfo
      Dim CurrentFolder As DirectoryInfo

      SetCompressionState(fullpath)
      CurrentFolder = New DirectoryInfo(fullpath)

      Try
         Files = CurrentFolder.GetFiles()

         For Each CurrentFile As FileInfo In Files
            With CurrentFile
               If .Attributes And FileAttributes.ReadOnly Then
                  ' Schreibschutzattribut vorübergehend entfernen
                  .Attributes = .Attributes And Not FileAttributes.ReadOnly
                  .Refresh()

                  CompressFile(.FullName)

                  ' Schreibschutzattribut wieder setzen
                  .Attributes = .Attributes Or FileAttributes.ReadOnly
                  .Refresh()
               Else
                  CompressFile(.FullName)
               End If
            End With
         Next

      Catch
         '
      End Try

      Try
         Subfolders = CurrentFolder.GetDirectories()

         For Each Subfolder As DirectoryInfo In Subfolders
            fullpath = Subfolder.FullName & ""

Alte URL: /snippet/ordner-komprimierung/563