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
| #If VBA7 Then
Private Declare PtrSafe Function OpenProcess Lib "kernel32" ( _
ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As LongPtr
Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" ( _
ByVal hHandle As LongPtr, _
ByVal dwMilliseconds As Long) As Long
Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" ( _
ByVal hProcess As LongPtr, _
lpExitCode As Long) As Long
Private Declare PtrSafe Function CloseHandle Lib "kernel32" ( _
ByVal hObject As LongPtr) As Long
#Else
Private Declare Function OpenProcess Lib "kernel32" ( _
ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" ( _
ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" ( _
ByVal hProcess As Long, _
lpExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
ByVal hObject As Long) As Long
#End If
Private Const SYNCHRONIZE = &H100000
Private Const PROCESS_QUERY_INFORMATION = &H400
Private Const WAIT_TIMEOUT = &H102&
Private Const INFINITE = &HFFFFFFFF
'Fonction qui permet de Zip un fichier et de le renvoyer
Function ZipFiles(ParamArray Listefic() As Variant) As String
Dim cmd As String, CheminZIP As String, fichiers As String
'Définition le chemin du ZIP final
CheminZIP = "C:\Temp\ArchiveDebug_MacroControle_" & Format(Now, "yyyymmdd_hhmmss") & ".zip"
' Liste des fichiers
fichiers = "'" & Join(Listefic, "','") & "'"
'Ecriture de la ligne de commande SHELL
cmd = "powershell -command ""Compress-Archive -Path " & fichiers & _
" -DestinationPath '" & CheminZIP & "' -CompressionLevel Fastest -Force"""
Debug.Print cmd
If Not ShellAndWait(cmd, vbHide, 5000) Then
ZipFiles = "ERREUR"
Exit Function
End If
MsgBox ("Fichiers trop lourds ! Compression et création d'un fichier .ZIP terminée.")
ZipFiles = CheminZIP
End Function
Function ShellAndWait(cmd, windowStyle, timeOutMs As Long) As Boolean
Dim taskID As Long, exitCode As Long, waitResult As Long
#If VBA7 Then
Dim hProc As LongPtr
#Else
Dim hProc As Long
#End If
ShellAndWait = False
On Error GoTo ErrHandler
'Exécution de la commande SHELL , récupération du PID
taskID = Shell(cmd, vbHide)
' Ouverture du Processus
hProc = OpenProcess(SYNCHRONIZE Or PROCESS_QUERY_INFORMATION, 0, taskID)
If hProc = 0 Then
Err.Raise vbObjectError + 2, , "Impossible d'ouvrir le processus."
End If
' Attendre avec timeout
waitResult = WaitForSingleObject(hProc, timeOutMs)
If waitResult = WAIT_TIMEOUT Then
MsgBox "Le programme n'a pas terminé dans le délai imparti (" & timeOutMs & " ms).", vbExclamation
Exit Function
Else
' Récupérer le code de sortie
GetExitCodeProcess hProc, exitCode
End If
Sub TestZipFiles()
Dim Fic1, Fic2, Fic3, FicZip
Fic1 = "D:\temp\test.html"
Fic2 = "D:\temp\PDF\testepure.pdf"
Fic3 = "D:\Dev\Office\Excel\ClasseurN.xlsm"
Debug.Print "ZipFiles : " & ZipFiles(Fic1, Fic2, Fic3)
End Sub |
Dev VBA - Compression de fichier .xlsm
Répondre avec citation
Envoyé par jurassic pork
Partager