将电子邮件移动到共享邮箱

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

您的代码有更多错误，然后只是移动电子邮件，修复移动部分em>

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