我有两个电子邮件帐户。
我的主要电子邮件帐户的容量上限为4GB，而我的辅助电子邮件帐户的容量上限为100GB。
由于坐在服务器上时容易发生损坏，因此我们强烈不鼓励使用PST存档文件。
我经常收到附有大型excel文件的电子邮件，该文件可以为10-15Mb。
我通过Outlook访问这些电子邮件帐户。
我已经将我的主帐户（限制为4GB的文件结构设置为我的辅助帐户（直接流量很少）。
如何根据接收日期选择从我的主帐户复制到我的辅助电子邮件帐户的所有电子邮件...例如在1st April 2018之前说？
如何在不手动复制和粘贴的情况下将这些电子邮件从主帐户转移到辅助帐户？
可以通过VBA完成吗？
请，我不能切换哪个帐户是我的主要电子邮件帐户或辅助电子邮件帐户。
答案 0 :(得分：0)
健康警告
这些年来，我已经多次将电子邮件从一家商店转移到另一家商店，并且从未遭受过任何破坏。但这并不意味着它不可能发生。我建议您先复制两个商店的副本，然后再尝试使用我的宏。
在测试过程中，有时宏会在Move语句处停止并报告未知错误。我重新启动了宏。它成功移动了出现错误的邮件，并继续移动了其余邮件。我以前在VBA宏中遇到过这样的短暂错误。您可能不会遇到这样的错误。如果确实遇到错误，请尝试（1）通过单击 F5 重新启动宏，（2）停止宏并重新运行它，以及（3）拖放麻烦的邮件项目。
假设
我假设您知道如何访问和使用Outlook VB编辑器。如有必要，我可以提供说明。
常规例程
我编写VBA宏已有15年以上。我创建了能够再次使用的子例程和函数，您不会感到惊讶。如果将这些子例程和函数用于单个Office软件包，则将其存储在名为“ ModOutlook”和“ ModExcel”的模块中，如果将其用于任何Office软件包，则将其存储在名为“ ModVBA”的模块中。
请创建一个新模块。单击 F4 将打开“属性”窗口。模块只有一个属性：名称。请重命名新模块“ ModOutlook”。这不是必须的，但是我发现给模块有意义的名称很有帮助。
将以下代码复制到新模块中：
Public Sub GetChildEmailFolderList(ByRef FldrPrnt As Folder, _
ByRef FldrsChild As Collection)
' * On Exit, FldrsChild will contain a list of references to
' all the email folders within FldrPrnt
' * FldrPrnt references a store or a folder within a store.
' * On entry, FldrsChild is initialised to an empty collection.
' * GetChildEmailFolderListSub is called to add the details of every descendant,
' email folder of FldrPrnt to FldrsChild
' * An email folder is a folder with property DefaultItemType = OlMailItem
' 28Jul18 Created by adapting code from earlier routines
Set FldrsChild = Nothing
Set FldrsChild = New Collection
Call GetChildEmailFolderListSub(FldrPrnt, FldrsChild)
End Sub
Sub GetChildEmailFolderListSub(ByRef FldrPrnt As Folder, _
ByRef FldrsChild As Collection)
' GetChildEmailFolderList initialises FldrsChild and then calls this
' routine to fill FldrsChild.
' This routine is recursive. It is called with FldrPrnt referencing
' the root of the folder hierarchy of interest. It records the children
' that root folder in FldrsChild and calls itself for each of those
' children to find their children. It will call itself as many times
' as necessary to reach the bottom of the hierarchy.
Dim FldrCrnt As Folder
Dim InxFldrChild As Long
For InxFldrChild = 1 To FldrPrnt.Folders.Count
Set FldrCrnt = FldrPrnt.Folders(InxFldrChild)
If FldrCrnt.DefaultItemType = olMailItem Then
FldrsChild.Add FldrCrnt
Call GetChildEmailFolderListSub(FldrCrnt, FldrsChild)
End If
Next
End Sub
Public Function GetCreateFldr(ByRef Store As Folder, _
ByRef FldrNameFull() As String) As Folder
' * Store identifies the store, which must exist, in which the folder is
' wanted.
' * FldrNameFull identifies a folder which is or is wanted within Store.
' Find the folder if it exists otherwise create it. Either way, return
' a reference to it.
' * If LB is the lower bound of FldrNameFull:
' * FldrNameFull(LB) is the name of a folder that is wanted within Store.
' * FldrNameFull(LB+1) is the name of a folder that is wanted within
' FldrNameFull(LB).
' * FldrNameFull(LB+2) is the name of a folder that is wanted within
' FldrNameFull(LB+1).
' * And so on until the full name of the wanted folder is specified.
' 17Oct16 Date coded not recorded but must be before this date
Dim FldrChld As Folder
Dim FldrCrnt As Folder
Dim ChildExists As Boolean
Dim InxC As Long
Dim InxFN As Long
Set FldrCrnt = Store
For InxFN = LBound(FldrNameFull) To UBound(FldrNameFull)
ChildExists = True
' Is FldrNameFull(InxFN) a child of FldrCrnt?
On Error Resume Next
Set FldrChld = Nothing ' Ensure value is Nothing if following statement fails
Set FldrChld = FldrCrnt.Folders(FldrNameFull(InxFN))
On Error GoTo 0
If FldrChld Is Nothing Then
' Child does not exist
ChildExists = False
Exit For
End If
Set FldrCrnt = FldrChld
Next
If ChildExists Then
' Folder already exists
Else
' Folder does not exist. Create it and any children
Set FldrCrnt = FldrCrnt.Folders.Add(FldrNameFull(InxFN))
For InxFN = InxFN + 1 To UBound(FldrNameFull)
Set FldrCrnt = FldrCrnt.Folders.Add(FldrNameFull(InxFN))
Next
End If
Set GetCreateFldr = FldrCrnt
End FunctionPublic Function GetFldrNameFull(ByRef Fldr As Folder) As String()
' * Fldr is a folder. It could be a store, the child of a store,
' the grandchild of a store or more deeply nested.
' * Return the name of that folder as a string array in the sequence:
' (0)=StoreName (1)=Level1FolderName (2)=Level2FolderName ...
' 12Oct16 Coded
' 20Oct16 Renamed from GetFldrNameStr and amended to return a string array
' rather than a string
' 28Jul18 Converted FldrNamesRev from string array to collection
Dim FldrCrnt As Folder
Dim FldrNames() As String
Dim FldrNamesRev As New Collection
Dim FldrPrnt As Folder
Dim InxFN As Long
Dim InxFnR As Long
Set FldrCrnt = Fldr
FldrNamesRev.Add Fldr.Name
' Loop getting parents until FldrCrnt has no parent.
' Add names of Fldr and all its parents to FldrNamesRev as they are found
Do While True
On Error Resume Next ' Stop reporting errors
Set FldrPrnt = Nothing ' Ensure value is Nothing if following statement fails
Set FldrPrnt = FldrCrnt.Parent
On Error GoTo 0 ' Restart reporting errors
If FldrPrnt Is Nothing Then
' FldrCrnt has no parent
Exit Do
End If
FldrNamesRev.Add FldrPrnt.Name
Set FldrCrnt = FldrPrnt
Loop
' Copy names to FldrNames in reverse sequence so they end up in the correct sequence
ReDim FldrNames(0 To FldrNamesRev.Count - 1)
InxFN = 0
For InxFnR = FldrNamesRev.Count To 1 Step -1
FldrNames(InxFN) = FldrNamesRev(InxFnR)
InxFN = InxFN + 1
Next
GetFldrNameFull = FldrNames
End Function
我相信我已经包括了我所使用的所有常规程序。如果由于缺少例程而出错，请告诉我，我将添加缺失的例程。
这些例程需要了解Outlook对象模型和递归。我建议您花些时间研究它们，但是直到您了解宏MoveEmails为止。
CtrlMoveEmails
使用三个参数调用宏MoveEmails。下面的宏将初始化这些参数并调用MoveEmails。 “ tony存档2015”和“ tony存档”是我系统上用于测试的两个存储。您必须用电子邮件帐户的名称替换我的名字。我已经在与我的测试商店相关的宏中编码了日期和时间。您必须将日期更改为与您的帐户相关的日期。您可以修改宏以要求操作员输入日期，但是我认为这是最简单的方法。
Option Explicit
Sub CtrlMoveEmails()
' Create parameters for MoveEmails and call it.
Dim LatestTimeToMove As Date
Dim StoreDest As Folder ' Destination store
Dim StoreSrc As Folder ' Source store:
With Application.Session
Set StoreDest = .Folders("tony archive 2015")
Set StoreSrc = .Folders("tony archive")
End With
LatestTimeToMove = DateSerial(2015, 7, 3) + TimeSerial(23, 59, 59)
Call MoveEmails(StoreSrc, StoreDest, LatestTimeToMove)
End Sub
移动电子邮件
这个宏与我的测试存储区大约需要一分钟。您的系统需要花费多长时间取决于它必须检查多少电子邮件以及必须移动多少电子邮件。我通常会使用表单来显示进度，但是很难解释如何创建表单。如果您知道如何创建表格，我将修改答案以更好地报告进度。当前的宏使用Debug.Print来报告进度，这不是很令人满意，但是比使用表单
更简单Sub MoveEmails(ByRef StoreSrc As Folder, _
ByRef StoreDest As Folder, _
ByVal LatestTimeToMove As Date)
' Move every email in StoreSrc or one of its children, with a
' ReceivedTime before LatestTimeToMove, to the same folder in
' StoreDest.
' If an email is found in FolderA11 of FolderA1 of StoreSrc, this routine
' creates FolderA11 of FolderA1 of StoreDest, if it does not exist, and
' moves the email to this destination folder.
' Both ScrRoot and StoreDest must be stores since this routine does not
' contain the code to handle the source and destination folders not being
' stores.
' 28Jul18 Coded
Dim FldrDestCrnt As Folder
Dim FldrDestNameFull() As String
Dim FldrSrcCrnt As Folder
Dim FldrSrcNameFull() As String
Dim FldrsSrcChild As Collection
Dim InxFldrsSrc As Long
Dim InxItemCrnt As Long
Dim InxName As Long
Dim MailItemCrnt As MailItem
' Validate Src and Dest are stores
FldrSrcNameFull = GetFldrNameFull(StoreSrc)
If UBound(FldrSrcNameFull) > LBound(FldrSrcNameFull) Then
Call MsgBox("Folder StoreSrc is not a store. I have no code " & _
"to handle this situation", vbOKOnly)
Exit Sub
End If
FldrDestNameFull = GetFldrNameFull(StoreDest)
If UBound(FldrDestNameFull) > LBound(FldrDestNameFull) Then
Call MsgBox("Folder StoreDest is not a store. I have no code " & _
"to handle this situation", vbOKOnly)
Exit Sub
End If
Debug.Print "Get list of all email folders in source store"
DoEvents
' Get list of all email folders in StoreSrc
Call GetChildEmailFolderList(StoreSrc, FldrsSrcChild)
' Process each email folder in FldrsSrcChild
For InxFldrsSrc = 1 To FldrsSrcChild.Count
Debug.Print "Processing folder " & InxFldrsSrc & " of " & _
FldrsSrcChild.Count
DoEvents
Set FldrSrcCrnt = FldrsSrcChild(InxFldrsSrc)
Set FldrDestCrnt = Nothing ' Only set if there is email to move to it
' FldrSrcCrnt.Items is a collection with items numbered 1 up to N by
' their position. If Item 1 is moved, Item 2 becomes Item 1. Processing
' items from the end of the collection first, ensures that the position of
' items not yet examined does not change.
For InxItemCrnt = FldrSrcCrnt.Items.Count To 1 Step -1
Debug.Print " Item " & InxItemCrnt
DoEvents
On Error Resume Next ' Stop reporting errors
Set MailItemCrnt = Nothing
Set MailItemCrnt = FldrSrcCrnt.Items(InxItemCrnt)
On Error GoTo 0 ' Restart reporting errors
If MailItemCrnt Is Nothing Then
' Current item is not a mail item. Ignore mail item.
ElseIf MailItemCrnt.ReceivedTime > LatestTimeToMove Then
' Too recent to move. Ignore mail item.
Else
' Move this email
If FldrDestCrnt Is Nothing Then
' This is first email for this folder. Create destination
' folder unless it already exists.
FldrSrcNameFull = GetFldrNameFull(FldrSrcCrnt)
' FldrNameFull is an array containing the full name of the source
' folder:
' FldrNameFull(0) is name of store
' FldrNameFull(1) is name of folder within store
' FldrNameFull(2) is name of folder within FldrNameFull(1)
' and so on until full name is specified.
' GetCreateFldr() requires an array like FldrNameFull but without
' the name of the store so discard element containng store name
ReDim FldrDestNameFull(1 To UBound(FldrSrcNameFull))
For InxName = 1 To UBound(FldrSrcNameFull)
FldrDestNameFull(InxName) = FldrSrcNameFull(InxName)
Next
' Check existence of destination folder. Create folder if it does not exist
Set FldrDestCrnt = GetCreateFldr(StoreDest, FldrDestNameFull)
End If
MailItemCrnt.Move FldrDestCrnt
End If
Next InxItemCrnt
Next InxFldrsSrc
End Sub
最后
如果有问题，请回来。