Outlook Adressbuch - Import per vbs

Hallo zusammen

Folgendes Script macht nichts weiter als ein PST mounten bestimmten inhalt kopieren und wieder trennen.
Grund: Wir haben keinen Exchange und ich will ein globales adressbuch...

Bisher scheint das auch ganz gut zu klappen... nur bei einem user werden die adressbücher nicht sauber deaktivert... Wenn Sie gelöscht werden bleiben Sie
anschliessen als leichen in der adressbuchübersicht.

Kennt jemand ne möglichkeit alle aktiven adressbücher per vbs zu deaktivieren?

Bin für jeden tipp zu dem script dankbar... Outlook Steuerung per vbs ist nicht meine Welt...
Nehme also auch gerne bessere ideen entgegen ;)

Set oWSHNetwork = CreateObject("WScript.Network")  
sUser = oWSHNetwork.UserName

If sUser = "test" Then  


'Deklarationen  
'-------------------------------------------------------------------------------------------------  
Set oOutlook = CreateObject("Outlook.Application")  
Set oNameSpace = oOutlook.GetNamespace("MAPI")  
Set oFolderpath = oOutlook.GetNamespace("MAPI")  
Set oListFolder = oNameSpace.Folders("Persönliche Ordner")  

Dim arrbooks(1)
arrbooks(0) = ("Adressbuch")  


pstpath = "X:\adressbook.pst"  

lcount = 0

'Funktion zum erstellen des Pfades in dem das Adressbuch liegt.  
'-------------------------------------------------------------------------------------------------  
Function cpath(itemname, pathname)

For Each item In oListFolder.Folders
    pos=Instr(item, itemname)
    if pos > 0 Then
    fpath = (item.folderpath)
    Exit for
    end If
Next

If fpath = "" Then  
exit Function
End If

fpath = Right(fpath, Len(fpath) - 2)
parray = Split(fpath, "\")  

For Each item In parray
Set oFolderpath = oFolderpath.folders(item)
Next

Set pathname = oFolderpath

Set oFolderpath = oOutlook.GetNamespace("MAPI")  
Set parray = Nothing

End Function

Do Until lcount = 1
Set fs = CreateObject("Scripting.FileSystemObject")  
If fs.DriveExists("P:") Then  
lcount = 1
End If
Set fs = Nothing
loop

'Bestehende Adressbücher deaktivieren & löschen  
'-------------------------------------------------------------------------------------------------  
cpath "Adressbuch", bbgab  

If Not bbgab = "" Then  

bookcount = bbgab.folders.count
If bookcount < 12 Then
MsgBox ("Die Struktur des Adressbuches wurde verändert. Melden Sie sich beim Support!")  
WScript.Quit
End if

bbgab.showasoutlookab = False

For count = 1 To UBound(arrbooks,1) -1
bbgab.folders(arrbooks(count)).showasoutlookab = False
Next

bbgab.delete()
oNameSpace.Folders("Persönliche Ordner").Folders("Gelöschte Objekte").Folders("Adressbuch").delete()  

End if

'Import von Adressbuch aus PST  
'-------------------------------------------------------------------------------------------------  
oNameSpace.AddStore(pstpath)

Set oKontaktordner = oNameSpace.Folders("Adressbuch").Folders("Adressbuch")  
Set oDestination = oNameSpace.Folders("Persönliche Ordner")  
oKontaktordner.CopyTo(oDestination)

oNameSpace.RemoveStore oNameSpace.Folders("Adressbuch")  

'Aktivieren der Adressbücher  
'-------------------------------------------------------------------------------------------------  
cpath "Adressbuch", bbgab  
bbgab.showasoutlookab = True
For count = 1 To UBound(arrbooks,1) -1
bbgab.folders(arrbooks(count)).showasoutlookab = True
Next

End if