Compresser un fichier par macro

Option Explicit

Sub ZipFichier()
'
'Source
'http://www.codecomments.com/archive299-2006-2-295877.html
'
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:\Base.xls"
    LeZip = "D:\Base.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