vba - 从 PST 文件中移动所有项目

Question

它最终达到了我不得不寻求帮助的地步。

由于电子邮件服务器的空间限制，我们公司的常见做法是将邮件/日历等从 Outlook 备份到 PST 文件。

我们现在在电子邮件服务器上不再有阻止这种情况的空间限制，因此我们希望将 PST 文件中的所有信息放入用户邮箱。

最终我们希望运行一个 vbscript 或类似的脚本来搜索用户的本地驱动器，发现任何 PST 文件，然后将所有数据传输到名为“导入”的文件夹下的交换邮箱，然后删除 PST。

理想情况下，我们会在没有用户的情况下通过 PShell 直接对 Exchange 执行此操作，但由于大多数用户都有“许多”PST 文件，其中大部分都不需要，如果我们全部执行这些文件，将会填满我们的交换。

我根本不懂 Outlook VBA，所以这是我唯一需要帮助的部分。我花了一段时间浏览搜索结果，希望看到我可以让它工作，但无法让它工作。

我对此进行了几次不同的尝试。这是我当前的代码:

' Get the main Inbox folder
Const OLInbox = 6    'Inbox Items folder
Set objOutlook = CreateObject( "Outlook.Application" )
Set objNameSpace = objOutlook.GetNamespace( "MAPI" )

Set objInbox = objNameSpace.GetDefaultFolder( OLInbox ) 'sets objFolder to the Inbox for it's reference 

' Create the Imported folder in the main inbox
On Error Resume Next
Set objDestFolder = objInbox.Folders( "Imported" )
If Err.Number <> 0 Then
    Set objNewFolder = objInbox.Folders.Add("Imported")
End If
On Error Goto 0



' Add the PST to Outlook
objNamespace.AddStore ("d:\backup.pst")

' Select the new store
Set objPST = objNamespace.Folders.GetLast
' Rename the Store To be easier To use
objPST.Name = "PSTImport"

' disconnect and reconnect the store to force a refresh of the folder list
objNamespace.RemoveStore objPST
objNamespace.AddStore ("d:\backup.pst")


Set objPSTInbox = objOutlook.Session.Folders("PSTImport").Folders("Inbox")

'Set objPSTFolder = objNameSpace.Folders("PSTImport").Folders("Inbox")
Set objPSTItems = objPSTInbox.Items

While TypeName(objPSTItems) <> "Nothing"
    objPSTItems.Move objDestFolder
    Set objPSTItems = objPSTItems.FindNext
Wend

---

目前完整的脚本是这样的

Set objShell = WScript.CreateObject ("WScript.Shell")

' Get the main Inbox folder
Const OLInbox = 6    'Inbox Items folder
Set objOutlook = CreateObject( "Outlook.Application" )
Set objNameSpace = objOutlook.GetNamespace( "MAPI" )

Set objInbox = objNameSpace.GetDefaultFolder( OLInbox ) 'sets objFolder to the Inbox for it's reference 

' Create the Imported folder in the main inbox
On Error Resume Next
Set objDestFolder = objInbox.Folders("Imported")
If Err.Number <> 0 Then
    Set objNewFolder = objInbox.Folders.Add("Imported")
    Set objDestFolder = objInbox.Folders("Imported")
End If
On Error Goto 0



' Add the PST to Outlook
objNamespace.AddStore ("d:\backup.pst")

' Select the new store
Set objPST = objNamespace.Folders.GetLast
' Rename the Store To be easier To use
objPST.Name = "PSTImport"

' disconnect and reconnect the store to force a refresh of the folder list
objNamespace.RemoveStore objPST
objNamespace.AddStore ("d:\backup.pst")


Set objPSTInbox = objOutlook.Session.Folders("PSTImport").Folders("Inbox")

Set objPSTInboxItems = objPSTInbox.Items
PSTInboxItemsCount = objPSTInboxItems.count

For i = PSTInboxItemsCount To 1 Step -1
    objPSTInboxItems(i).Move objDestFolder
Next 

经测试，Imported文件夹在收件箱中创建成功。

PST 作为商店添加，重命名也正常。

但是，它似乎是失败的脚本的循环/下一部分。没有项目被移到导入文件夹。

我认为我们可能没有选择邮箱中的项目。我们是否需要在其中指定另一个“folders()”部分？

理想情况下，我们希望移动 PST 中的所有办公内容。有谁知道日历条目是否会作为其中的一部分被复制。

我们是否需要指定，例如，获取所有邮件并移动，然后获取所有联系人并移动，获取所有日历条目并移动？

Answer 1

“无法正常工作”您没有描述问题，但这里有一些建议。

创建文件夹时添加一行设置objDestFolder。

On Error Resume Next
Set objDestFolder = objInbox.Folders("Imported")
If Err.Number <> 0 Then
    Set objNewFolder = objInbox.Folders.Add("Imported")
    Set objDestFolder = objInbox.Folders("Imported")
End If
On Error Goto 0

或者始终尝试在主收件箱中创建 Imported 文件夹

' Bypass the error if the folder exists
On Error Resume Next
Set objDestFolder = objInbox.Folders.add("Imported")
On Error GoTo 0
Set objDestFolder = objInbox.Folders("Imported")

用这样的东西替换 While Wend。

For i = PSTInboxItemsCount To 1 Step -1
    objPSTInboxItems(i).Move objDestFolder
Next i