1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
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 & "\"
CompressFolder(fullpath)
Next
Catch
'
End Try
End Sub
Private Sub SetCompressionState(ByVal folder As String)
Dim Size As Short = 2
Dim ReturnedBytes As Integer
Dim Result As Boolean
Dim Handle As IntPtr
Handle = CreateFile(folder, _
GENERIC_READ Or GENERIC_WRITE, _
FILE_SHARE_NONE, _
IntPtr.Zero, _
OPEN_EXISTING, _
FILE_FLAG_BACKUP_SEMANTICS, _
IntPtr.Zero)
If Handle.ToInt32 <> INVALID_HANDLE_VALUE Then
Result = DeviceIoControl(Handle, _
FSCTL_SET_COMPRESSION, _
COMPRESSION_FORMAT_LZNT1, _
Size, _
0, _
0, _
ReturnedBytes, _
IntPtr.Zero)
CloseHandle(Handle)
End If
End Sub
Private Sub CompressFile(ByVal file As String)
Dim Size As Short = 2
Dim ReturnedBytes As Integer
Dim Result As Boolean
Dim Stream As FileStream
Try
Stream = New FileStream(file, FileMode.Open, _
FileAccess.ReadWrite, FileShare.None)
Result = DeviceIoControl(Stream.Handle, _
FSCTL_SET_COMPRESSION, _
COMPRESSION_FORMAT_LZNT1, _
Size, _
0, _
0, _
ReturnedBytes, _
IntPtr.Zero)
Stream.Close()
Catch
If Not Stream Is Nothing Then
Stream.Close()
End If
End Try
End Sub
-------------------------------------------------
Beispiel : CompressFolder("C:\Temp")
|