Zipper un fichier excel en VBS

Signaler
Messages postés
61
Date d'inscription
mercredi 1 mars 2006
Statut
Membre
Dernière intervention
6 août 2009
-
Messages postés
61
Date d'inscription
mercredi 1 mars 2006
Statut
Membre
Dernière intervention
6 août 2009
-
Bonjour,

J'ai récupérer un code afin de zipper un repertoire afin de créer une archive zip. Cela fonctionne parfaitement.

Je souhaiterai modifier ce code afin de ziper un fichier excel et non plus un repertoire. Pourriez vous m'indiquer les modifications a y apporter ?

Merci d'avance pour votre coup de mains, ci dessous mon code.
@+
ydu

'*******************************************************
'Source
'http://www.codecomments.com/archive299-2006-2-295877.html
'Const ForReading 1, ForWriting 2, ForAppending = 8
 
Dim Source, Destination, MyHex, MyBinary, i
Dim oShell, oApp, oFolder, oCTF, oFile
Dim oFileSys
 
Source = "C:\Documents and Settings\ydu\Bureau\test"
Destination = "C:\Documents and Settings\ydu\Bureau\maSauvegarde.zip"
 
MyHex = _
Array(80, 75, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
 
For i = 0 To UBound(MyHex)
    MyBinary = MyBinary & Chr(MyHex(i))
Next
 
Set oShell = CreateObject("WScript.Shell")
Set oFileSys = CreateObject("Scripting.FileSystemObject")
 
'Creation du zip
Set oCTF = oFileSys.CreateTextFile(Destination, True)
oCTF.Write MyBinary
oCTF.Close
Set oCTF = Nothing
 
Set oApp = CreateObject("Shell.Application")
 
Set oFolder = oApp.NameSpace(Source)
If Not oFolder Is Nothing Then _
    oApp.NameSpace(Destination).CopyHere oFolder.Items
 
wScript.Sleep 5000
 
Set oFile = Nothing
On Error Resume Next
 
Do While (oFile Is Nothing)
    'Attention: provoque une erreur 70 si un des fichiers à zipper
    'est toujours ouvert.
    Set oFile = oFileSys.OpenTextFile(Destination, ForAppending, False)
   
    If Err.Number <> 0 Then
        Err.Clear
        wScript.Sleep 3000
    End If
Loop
 
Set oFile = Nothing
Set oFileSys = Nothing

1 réponse

Messages postés
61
Date d'inscription
mercredi 1 mars 2006
Statut
Membre
Dernière intervention
6 août 2009

Bonjour,

Je viens metter mon article à jour car j'ai trouver un code en VBA qui fonctionne très bien dans une macro mais je voudrai le faire en VBS quelqu'un peut il m'aider svp ?

ci dessous le code
@+

Sub ZipFichier()
    Dim oShell As Object, Fso As Object
    Dim i As Long
    Dim Fichier As String, MyBinary As String
    Dim LeZip As Variant
    Dim MyHex As Variant
   
    Fichier = "C:\le classeur.xls"
    LeZip = "C:\Ma sauvegarde.zip"
    
    Set Fso = CreateObject("Scripting.FileSystemObject")
    MyHex = _
        Array(80, 75, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
   
    For i = 0 To UBound(MyHex)
        MyBinary = MyBinary & Chr(MyHex(i))
    Next
   
    With Fso.CreateTextFile(LeZip, True)
        .Write MyBinary
        .Close
    End With
   
    Set oShell = CreateObject("Shell.Application")
    oShell.NameSpace(LeZip).CopyHere (Fichier)
   
    Set oShell = Nothing
End Sub

ydu