我们有一个共享邮箱，并且每个人都分配有一个文件夹。个人完成电子邮件的工作后，他/她将其拖到完成的文件夹中，这将触发ItemAdd代码，该代码将收件箱中的下一封邮件分配给该文件夹。
这在Office 2016中有效。在Office 365中，它第一次有效，第二次中断。
我尝试重新选择OLE Automation。我还尝试更改声明的变量。
GetFolderPath函数在模块中。
我发现objinbox.Folders.Count第一次返回收件箱（6）下的文件夹数。第二次objinbox.Folders.Count为0，因此它没有运行For Each olFolder In objinbox.Folders循环。还选中了objinbox.parent，它将返回GL测试。
Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace
Dim objWatchFolder As Outlook.Folder
Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set objWatchFolder = GetFolderPath("gl testing\Completed")
End Sub
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
'On Error GoTo ErrorHandler:
Dim objinbox As Outlook.MAPIFolder
Dim olFolder As Outlook.MAPIFolder
Dim objSubfolder As Outlook.MAPIFolder
Dim objEmail As Outlook.MailItem
Dim objCopy As Outlook.MailItem
Dim oMail As Outlook.MailItem
Dim moveFolder As String
Set objinbox = GetFolderPath("gl testing\Inbox")
For Each olFolder In objinbox.Folders
If olFolder.Items.Count = 0 Then moveFolder = olFolder.Name Else
Next olFolder
Set objSubfolder = objinbox.Folders(moveFolder)
restart:
For Each oMail In objinbox.Items
If oMail.Sender = "GL Testing" Then
oMail.Move GetFolderPath("gl testing\WIP")
GoTo restart
End If
On Error Resume Next
If UCase(oMail.Subject) Like "*URGENT*" Then
Set objEmail = oMail
GoTo urgent
End If
On Error GoTo 0
Next oMail
If objEmail Is Nothing Then
Set objEmail = objinbox.Items.GetFirst
End If
urgent:
Set objCopy = objEmail.Copy
objCopy.Move GetFolderPath("gl testing\Track")
objEmail.Move objSubfolder
Exit Sub
'ErrorHandler:MsgBox "No e-mail has been moved to your folder either inbox is empty or you already have another mail in your folder"
End Sub
获取文件夹路径功能。
' Use the GetFolderPath function to find a folder in non-default mailboxes
Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
Dim oFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set oFolder = Application.Session.Folders(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function
GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function