Перемещение писем в общий почтовый ящик

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