Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire
Veuillez sélectionner un problème
Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Michel Angelosanto
J'ai trouvé, voici le code: Sub Zip_ActiveWorkbook() 'compression du classeur actif Dim strDate As String, DefPath As String Dim FileNameZip, FileNameXls Dim oApp As Object DefPath = "C:temp" '<< Change If Right(DefPath, 1) <> "" Then DefPath = DefPath & ""
'Create date/time string and the temporary xls and zip file name strDate = Format(Now, " dd-mmm-yy h-mm-ss") FileNameZip = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".zip" FileNameXls = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".xls" If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then 'crée une copie du classeur actif ActiveWorkbook.SaveCopyAs FileNameXls 'Crée un fichier zip vide NewZip (FileNameZip) 'Copie le fichier dans le dossier compressé Set oApp = CreateObject("Shell.Application") oApp.Namespace(FileNameZip).CopyHere FileNameXls 'on attend la fin de la compression On Error Resume Next Do Until oApp.Namespace(FileNameZip).items.Count = 1 Application.Wait (Now + TimeValue("0:00:01")) Loop On Error GoTo 0 'on efface le fichier excel temporaire Kill FileNameXls MsgBox "Votre fichier est sauvé ici: " & FileNameZip Else MsgBox "FileNameZip ou/et FileNameXls existe déja!" End If End Sub Sub NewZip(sPath) 'Crée un fichier zip vide If Len(Dir(sPath)) > 0 Then Kill sPath Open sPath For Output As #1 Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0) Close #1 End Sub
"Michel Angelosanto" a écrit dans le message de news:
Bonjour,
sauriez vous comment je peux utiliser la fonction native de compression de fichiers de Windows XP ou Vista en VBA sous Excel ?
Merci d'avance.
-- Michel Angelosanto, Bordeaux http://angelosa.free.fr/
-- Michel Angelosanto, Bordeaux http://angelosa.free.fr/
J'ai trouvé, voici le code:
Sub Zip_ActiveWorkbook()
'compression du classeur actif
Dim strDate As String, DefPath As String
Dim FileNameZip, FileNameXls
Dim oApp As Object
DefPath = "C:temp" '<< Change
If Right(DefPath, 1) <> "" Then DefPath = DefPath & ""
'Create date/time string and the temporary xls and zip file name
strDate = Format(Now, " dd-mmm-yy h-mm-ss")
FileNameZip = DefPath & Left(ActiveWorkbook.Name,
Len(ActiveWorkbook.Name) - 4) & strDate & ".zip"
FileNameXls = DefPath & Left(ActiveWorkbook.Name,
Len(ActiveWorkbook.Name) - 4) & strDate & ".xls"
If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then
'crée une copie du classeur actif
ActiveWorkbook.SaveCopyAs FileNameXls
'Crée un fichier zip vide
NewZip (FileNameZip)
'Copie le fichier dans le dossier compressé
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameZip).CopyHere FileNameXls
'on attend la fin de la compression
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).items.Count = 1
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
'on efface le fichier excel temporaire
Kill FileNameXls
MsgBox "Votre fichier est sauvé ici: " & FileNameZip
Else
MsgBox "FileNameZip ou/et FileNameXls existe déja!"
End If
End Sub
Sub NewZip(sPath)
'Crée un fichier zip vide
If Len(Dir(sPath)) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
"Michel Angelosanto" <angelosa@free.fr> a écrit dans le message de
news:OinaM4NxIHA.4560@TK2MSFTNGP03.phx.gbl...
Bonjour,
sauriez vous comment je peux utiliser la fonction native de compression de
fichiers de Windows XP ou Vista en VBA sous Excel ?
Merci d'avance.
--
Michel Angelosanto, Bordeaux
http://angelosa.free.fr/
--
Michel Angelosanto, Bordeaux
http://angelosa.free.fr/
J'ai trouvé, voici le code: Sub Zip_ActiveWorkbook() 'compression du classeur actif Dim strDate As String, DefPath As String Dim FileNameZip, FileNameXls Dim oApp As Object DefPath = "C:temp" '<< Change If Right(DefPath, 1) <> "" Then DefPath = DefPath & ""
'Create date/time string and the temporary xls and zip file name strDate = Format(Now, " dd-mmm-yy h-mm-ss") FileNameZip = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".zip" FileNameXls = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".xls" If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then 'crée une copie du classeur actif ActiveWorkbook.SaveCopyAs FileNameXls 'Crée un fichier zip vide NewZip (FileNameZip) 'Copie le fichier dans le dossier compressé Set oApp = CreateObject("Shell.Application") oApp.Namespace(FileNameZip).CopyHere FileNameXls 'on attend la fin de la compression On Error Resume Next Do Until oApp.Namespace(FileNameZip).items.Count = 1 Application.Wait (Now + TimeValue("0:00:01")) Loop On Error GoTo 0 'on efface le fichier excel temporaire Kill FileNameXls MsgBox "Votre fichier est sauvé ici: " & FileNameZip Else MsgBox "FileNameZip ou/et FileNameXls existe déja!" End If End Sub Sub NewZip(sPath) 'Crée un fichier zip vide If Len(Dir(sPath)) > 0 Then Kill sPath Open sPath For Output As #1 Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0) Close #1 End Sub
"Michel Angelosanto" a écrit dans le message de news:
Bonjour,
sauriez vous comment je peux utiliser la fonction native de compression de fichiers de Windows XP ou Vista en VBA sous Excel ?
Merci d'avance.
-- Michel Angelosanto, Bordeaux http://angelosa.free.fr/
-- Michel Angelosanto, Bordeaux http://angelosa.free.fr/