vba - 将电子邮件移动到共享邮箱
问题描述
我需要一些帮助来解决一个问题,我们有一个共享邮箱在工作,我有一些 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
解决方案
你的代码有更多错误,然后只是移动电子邮件,修复移动部分我看到你有声明的变量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
推荐阅读
- python - 有没有办法加速这个 Python 脚本?
- mysql - mysqladmin:警告在命令行界面上使用密码可能不安全
- excel - 将过滤后的值插入表中而不会出现溢出错误
- javascript - 如何选择具有自定义属性的元素?
- c# - 使用 C# 通过串行发送 Ctrl+Shift+6
- java - java.lang.IllegalArgumentException:纹理必须为非空(CanvasJs 和 JavaFX)
- python-3.x - Tkinter:不需要第二个脚本打开一个新窗口?
- reactjs - 注册用户时将管理员保存到数据库时出错
- oracle-adf - 位置:ADF Essentials 中的多行 af:inputText 问题
- javascript - EventListener 应用于上一行