Fehler Excel 2003

Sub NewZip(sPath)
'Create empty Zip File
Dim oFSO, arrHex, sBin, i, Zip
Set oFSO = CreateObject("Scripting.FileSystemObject")
arrHex = 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(arrHex)
sBin = sBin & Chr(arrHex(i))
Next
With oFSO.CreateTextFile(sPath, True)
.Write sBin
.Close
End With
End Sub

Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Rob Bovey
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function

Function Split97(sStr As Variant, sdelim As String) As Variant
'Tom Ogilvy
Split97 = Evaluate("{""" & _
Application.Substitute(sStr, sdelim, """,""") & """}")
End Function

Sub Zip_All_Files_in_Folder_Browse()
Dim FileNameZip, FolderName, oFolder
Dim strDate As String, DefPath As String
Dim oApp As Object
'DefPath = Application.DefaultFilePath
DefPath = ThisWorkbook.Path & "\export\"
'Admin setzen
Dim ADM As Worksheet
Set ADM = Workbooks(admin_datei).Sheets("bt_admin")
If Right(DefPath, 1)  "\" Then
DefPath = DefPath & "\"
End If
'strDate = Format(Now, " dd-mmm-yy h-mm-ss")
FileNameZip = DefPath & ADM.Range("C8").Value & ".zip"
'Create empty Zip File
NewZip (FileNameZip)
Set oApp = CreateObject("Shell.Application")
'Verzeichnis setzen
FolderName = ThisWorkbook.Path & "\betriebe\" & ADM.Range("C8").Value & "\"
'Kopieren und packen der Dateien
  oApp.NameSpace(FileNameZip).CopyHere oApp.NameSpace(FolderName).items
Set oApp = Nothing
Set oFolder = Nothing
End Sub

Unter Excel 2000 funktioniert er einwandfrei.
Unter 2003 bringt Excel folgende Fehlermeldung (fette hervorgehobene Zeile im Code)
Die Methode Space für das Opjekt IShellDispatch4 ist fehlgeschlagen.
Woran kann dies liegen.
Danke Euch schonmal
Steffen Schmerler