Question

我需要一个问题的帮助，我们有一个共享的邮箱在工作，我有一些VBA，一旦阅读并按一下按钮，它就会修改电子邮件的主题行。

此问题是当前代码无法将电子邮件移动到该邮箱内的子文件夹中。

附带的代码是我所拥有的，我不太擅长VBA，因此已在其他人的帮助下进行了开发。

Sub ForAction()

'Declaration
Dim myOlApp As New Outlook.Application
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
Dim strRawSubj
Dim strNewSubj1
Dim strNewSubj2
Dim strNewSubj3
Dim ns As Outlook.NameSpace
Dim moveToFolder As Outlook.MAPIFolder
Dim myItems, myItem As Object
'Dim MyData As Object

'On Error Resume Next

'work on selected items
Set myOlExp = myOlApp.ActiveExplorer
Set myOlSel = myOlExp.Selection
Set ns = Application.GetNamespace("MIPI")
Set moveToFolder = ns.Folders("new.orders@domain.com.au").Folders("Inbox").Folders("01 Assigned Tickets")

'for all items do...
For Each myItem In myOlSel

  strDate = myItem.SentOn
  If strDate = "" Then
    strDate = "0"
    Else
       If strDate = "4501/01/01" Then
       moddate = myItem.LastModificationTime
    mod2date = Format(moddate, "yyyymmdd:hhmm")
    newdate = mod2date & "-UNSENT"
    Else
 ' DE - date format of yyyymmdd:hhmm - includes minutes and seconds - eg 20100527:1215
   strNewDate = Format(strDate, "yyyymmdd:hhmm")
    End If
  End If
  ' DE - Strip the [SEC= from the Subject line, remove RE: and FW:, then trim to max 50 char
  strRawSubj = myItem.Subject
  If strRawSubj = "" Then
    strRawSubj = "Receipt"
    Else
     ' GP - Check for Id
If InStr(strRawSubj, "ForActionEmail-") > 0 Then GoTo Terminate

     strNewSubj1 = Left(strRawSubj, NumA)
        ' DE - Headers with no Email Id were being eaten, so a workaround for that
        If strNewSubj1 = "" Then
        strNewSubj1 = strRawSubj
        End If
    ' DE - Remove FW and RE prefixes
    strNewSubj2 = Replace(strNewSubj1, "FW: ", "", , 1, vbTextCompare)
    strNewSubj3 = Replace(strNewSubj2, "RE: ", "", , 1, vbTextCompare)
    ' DE - Trim subject to 150 chars to be reasonable - should be plenty unless people are writing a book
    strShortSubj = Left(strNewSubj3, 150)
  End If

  strname = strNewDate & "-" & "ForActionEmail-" & strShortSubj 

Set MyData = NewObject
MyData.SetText strname
'MyData.PutInClipboard
myItem.Subject = strname
myItem.Save
myItem.move moveToFolder


Next

SaveMessagesEnd:

'free variables
Set myItems = Nothing
Set myItem = Nothing
Set myOlApp = Nothing
Set myOlExp = Nothing
Set myOlSel = Nothing

Exit Sub

ErrorHandler:
Exit Sub

Terminate:
End Sub

Answer 1

您的代码中有更多错误，然后仅移动电子邮件，即可修复移动部分。我看到您有声明的变量Dim ns As Outlook.NameSpace，但我看不到您分配给对象引用，因此请修复以下问题

Set ns = Application.GetNamespace("MAPI")
Set moveToFolder = ns.Folders("Mailbox - New Orders").Folders("Inbox").Folders("01 Assigned Tickets")

用电子邮件地址和Mailbox - New Orders替换01 Assigned Tickets应该是收件箱下的subfolder名称。

Set ns = Application.GetNamespace("MAPI")
    Set moveToFolder = ns.Folders("0m3r@email.com").Folders("Inbox").Folders("SubfolderName")

您还应该删除 On Error Resume Next 并使用 Option Explicit Statement

移动到共享邮箱

Option Explicit
Public Sub Example()
    Dim olNs As Outlook.NameSpace
    Set olNs = Application.GetNamespace("MAPI")

    Dim Recip As Outlook.Recipient
    Set Recip = olNs.CreateRecipient("new.orders@domain.com.au") 'update email

    Dim SharedInbox As Outlook.folder
    Set SharedInbox = olNs.GetSharedDefaultFolder(Recip, _
                                         olFolderInbox) 'Inbox

    Dim i As Long
    Dim Item As Outlook.MailItem

    For i = ActiveExplorer.selection.Count To 1 Step -1
        Set Item = ActiveExplorer.selection.Item(i)
        Debug.Print Item.Subject

        Item.Move SharedInbox.Folders("01 Assigned Tickets") ' update

    Next

End Sub

将电子邮件移至共享邮箱

1 个答案: