Moving emails into shared mailbox

Question

I need some help with a problem, we have a shared mailbox at work and I have some VBA that will modify the subject line of the email once it has been read and at the press of a button.

This issue is the current code wont move the email to a sub folder within that mailbox.

Attached is the code I have, I'm not very good at VBA so this has been developed with help from others.

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

0m3r · Accepted Answer · 2019-05-02T00:12:45.023

You have lot more errors on your code then simply moving emails, to fix the moving part I see you have Declared variable Dim ns As Outlook.NameSpace but I don't see you assigning to object reference so fix the following

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

Replace Mailbox - New Orders with email address & 01 Assigned Tickets should be the subfolder name under Inbox.

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

you should also wanna remove On Error Resume Next and use Option Explicit Statement

Move to shared mailbox

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

Moving emails into shared mailbox

1 Answers1