ZIP a la racine d'un répertoire

Bonjour à tous

J'aurais besoin d'un petit coup de pouce ...
je dois zipper un répertoire (C:\01) et son contenu (sous répertoire et
fichier) et l'envoyer en ftp.
Mon vbs fonctionne presque comme je veux sauf que il ne prends pas en
compte le répertoire racine 01 qui doit compris dans le zip, et là je
galère ...
par ex:
c:\01\20080529\101\010101.tif
c:\01\20080529\101\010102.tif
c:\01\20080529\201\010201.tif

le zip doit être de la forme 01AAAAMMJJ.zip et il doit contenir tous le
contenu du répertoire 01 avec le 01.

Merci d'avance voilà
mon vbs (beaucoup de pêche à la google)

Option Explicit
Dim ZipFile, SrcFldrs, Fldr, cde1, cde2, cde3, cde4, oShell
Dim Z, DA, DM, DJ
Const FOF_CREATEPROGRESSDLG = &H0&
SrcFldrs = Array("C:\01")
DA=Year(Now)
DM=Month(Now)
If DM < 10 Then DM="0" & DM 'Pour fabriquer le mois sur 2 caractères
DJ=Day(Now)
If DJ < 10 Then DJ="0" & DJ 'Pour fabriquer le jour sur 2 caractères
Z="01"&DA&DM&DJ
ZipFile = "C:\"&Z&".zip"

'Create empty Zip File
CreateObject("Scripting.FileSystemObject") _
.CreateTextFile(ZipFile, True) _
.Write "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)
With CreateObject("Shell.Application")
For each Fldr in SrcFldrs
'Copy the files to the compressed folder
.NameSpace(ZipFile).CopyHere .NameSpace(Fldr).Items,
FOF_CREATEPROGRESSDLG
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until .NameSpace(ZipFile).Items.Count =
.NameSpace(Fldr).Items.Count
wScript.Sleep 3000
Loop
On Error GoTo 0
Next
End With

msgbox "Le fichier Zip "& ZipFile & " a ete cree"

call FTP("open 192.168.15.150^toto^toto^hash^bin^put
C:\01.zip^close^bye")

msgbox "Le fichier Zip a ete envoye en ftp"

cde1 = "%comspec% /C xcopy c:\01\*.* c:\BKUP\ /S /Y"
cde2 = "%comspec% /C del c:\01????????.zip /Q"
cde3 = "%comspec% /C rd c:\01\ /S /Q"
cde4 = "%comspec% /C md c:\01\"
Set oShell = CreateObject ("WScript.Shell")
oShell.run cde1, 0, True
oShell.run cde2, 0, True
oShell.run cde3, 0, True
oShell.run cde4, 0, True

msgbox "Le fichier Zip " & ZipFile & " a ete suprime et l'archivage de
la journee a ete effectuee dans:"&vbcrlf&vbcrlf&_
" C:\BCKUP"

Function FTP(command)
Const cFTP = "FTP.txt"
Const cLOG = "FTP.log"
Const cWSS = "%comspec% /C FTP -i -s:"
Dim strOTF
strOTF = Replace(command,"^",vbCrLf)
Dim objFSO
Dim objOTF
Dim objWSS
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objOTF = objFSO.OpenTextFile(cFTP,2,True)
objOTF.Write(strOTF)
Set objOTF = Nothing
Set objFSO = Nothing
Set objWSS = CreateObject("WScript.Shell")
objWSS.Run cWSS & cFTP & " > " & cLOG,2,True
Set objWSS = Nothing
' pour debug MsgBox strOTF,vbInformation,cFTP
End Function