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
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
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.