Thanks for your advice. I already hoped that Sue will help me ;-)
Ok, I wrote a code snipet in VBScript
0.Don't smile about my programming style ;-)
1.You should have Exchange admin rights on your account
2.Make a profile with your mailbox and a additional other users mailbox
3.fire the script under Outlook 2000 - you get *.pst for each mailbox in the
profile in c:\
4.fire the script under Outlook 2002 - you will fail
' RBMergeToPstShort.vbs
' (c) 2001 by Rudolf Boettcher
' eMail: (e-mail address removed)
' http:
www.rbware.net
'
Function CopyFolder (oNameSpace, oSourceFolder, backupPath, tempPstName,
additionalName)
Dim oRootFolder
Dim oNameSpaceFolders
Dim oDestFolder
Dim oSubFolder
Dim fileName
Dim fso
Dim normalizeIni
Dim oTmpFolder
Dim alreadyHere
Dim oTmpItem
Dim oCopyItem
CopyFolder = True
fileName = backupPath & "Backup" & additionalName & oSourceFolder.Name &
".pst"
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(fileName) Then
On Error Resume Next
fso.DeleteFile fileName, true
If Err.number <> 0 Then
MsgBox "can not delete pst file >" & fileName & "< . Is the file still
opened in Outlook ?"
CopyFolder = False
Exit Function
End If
On Error Goto 0
End If
oNameSpace.AddStore fileName
Set oNameSpaceFolders = oNameSpace.Folders
For Each oRootFolder In oNameSpaceFolders
If oRootFolder.Name = tempPstName Then
Set oDestFolder = oRootFolder
oDestFolder.Name = "Backup" & additionalName & oSourceFolder.Name
Exit For
End If
Next
If VarType(oDestFolder) = 8 Then
On Error Resume Next
For Each oSubFolder In oSourceFolder.Folders ' private folders folder by
folder for a better import possibility
alreadyHere = false
For Each oTmpFolder In oDestFolder.Folders ' try to find the folder
If oTmpFolder.Name = oSubFolder.Name Then
alreadyHere = true
For Each oTmpItem In oSubFolder.Items ' copy item by item
Set oCopyItem = oTmpItem.Copy
oCopyItem.Move oTmpFolder
Next
End If
Next
If alreadyHere = false Then
oSubFolder.CopyTo (oDestFolder)
If Err.number <> 0 Then
MsgBox "copy problem during folder " & oSubFolder.Name & " permission
problems ?"
End If
End If
Next
If Err.number <> 0 Then
MsgBox "copy problem during folder " & oSourceFolder.Name & " permission
problems ?"
End If
On Error Goto 0
MsgBox "remove folder " & oDestFolder.Name & " from the profile"
oNameSpace.RemoveStore oDestFolder
Else
MsgBox vbCrLf & "error: wrong TempPstName in settings file, found >" &
tempPstName & "<" & vbCrLf
CopyFolder = False
End If
End Function
Sub main()
Dim oOL
Dim oApplication
Dim oNameSpace
Dim oNameSpaceFolders
Dim oRootFolder
Dim tempPstName
Dim backupPath
Dim i
Dim tmpFolder
Set oOL = WScript.CreateObject("Outlook.Application") ' open outlook
Set oApplication = oOL.Application
Set oNameSpace = oApplication.GetNameSpace("MAPI")
Set oNameSpaceFolders = oNameSpace.Folders
backupPath = "c:\"
tempPstName = "Personal Folders"
i = 0
For Each oRootFolder In oNameSpaceFolders
If isObject (oRootFolder) Then
If InStr(oRootFolder.Name,"Public") = 0 AND
InStr(oRootFolder.Name,"ffentliche") = 0 Then
i = i + 1
If CopyFolder (oNameSpace, oRootFolder, backupPath, tempPstName," Test"
& i & " ") = False Then
Exit For
End If
End If
End If
Next
oOL.Quit
Set oOL = Nothing
MsgBox ("End of line")
End Sub
main
Do you have sample code we can use to test this?
--
Sue Mosher, Outlook MVP
Outlook and Exchange solutions at
http://www.slipstick.com
Author of
Microsoft Outlook Programming: Jumpstart
for Administrators, Power Users, and Developers
