Folder.CopyTo Problem with Outlook 2002 (MVP question)

[Rudolf Boettcher]

I wrote some scripts in Outlook. If I use Folder.CopyTo under Outlook 2000
or 98 it works not so under Outlook 2002 if the source folder is not from
the current users mailbox. I got "no permissions" error with the same
settings!
I found 2 similar questions in newsgroups, but no answer.
I think this is a outtlok bug.
Is the any MVP here to give me a hint ?

Thanks

Rudi (freeware author www.rbware.net)

Here is a sample:

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-2003 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