我的目标是:在收到的电子邮件中,将任何PDF附件移动到硬盘驱动器文件夹中,并将日期附加到其末尾。
我有一个运行规则的宏,但规则经常出错并关闭,所以我将把它放在这个Outlook会话中。
我修改了这个我发现做我需要的宏,但它给了我编译错误:Next没有For。
感谢您对此的帮助。
Option Explicit
Private WithEvents olInboxItems As Items
Private Sub Application_Startup()
Dim objNS As NameSpace
Set objNS = Application.Session
' instantiate objects declared WithEvents
Set olInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items
Set objNS = Nothing
End Sub
Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
On Error Resume Next
If Item.Attachments.Count > 0 Then
Dim objAttachments As Outlook.Attachments
Dim lngCount As Long
Dim strFile As String
Dim sFileType As String
Dim i As Long
Dim dtDate As Date
Dim sName As String
Dim objMsg As Outlook.MailItem
Dim lcount As Integer
Dim pre As String
Dim ext As String
Dim strFolderpath As String
Set objAttachments = Item.Attachments
lngCount = objAttachments.Count
For i = lngCount To 1 Step -1
If lngCount > 0 Then
dtDate = objMsg.SentOn
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, vbUseSystem)
' Get the file name.
strFile = sName & objAttachments.Item(i).FileName
If LCase(Right(strFile, 4)) = ".pdf" Then
lcount = InStrRev(strFile, ".") - 1
pre = Left(strFile, lcount)
ext = Right(strFile, Len(strFile) - lcount)
' Combine with the path to make the final path
strFile = strFolderpath & pre & "_" & sName & ext
' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%USERPROFILE%")
strFolderpath = strFolderpath & "\1 Inbox\"
' Combine with the path to the folder.
strFile = strFolderpath & strFile
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
Next i
End If
End If
End Sub
答案 0 :(得分:0)
您不需要规则,请尝试将其添加到OutlookSession,然后重新启动Outlook
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
Save_PDF Item
End If
End Sub
Private Sub Save_PDF(ByVal Item As Object)
Dim Atmts As Outlook.Attachments
Dim intCount As Long
Dim sFileName As String
Dim i As Long
Dim sDate As String
Dim Frmt_Date As String
Dim FolderPath As String
If Item.Attachments.Count > 0 Then
Set Atmts = Item.Attachments
intCount = Atmts.Count
For i = intCount To 1 Step -1
If intCount > 0 Then
sDate = Item.SentOn
Frmt_Date = Format(sDate, "yyyymmdd", vbUseSystemDayOfWeek, vbUseSystem)
' Get the file name.
sFileName = Atmts.Item(i).FileName
If LCase(Right(sFileName, 4)) = ".pdf" Then
' Get the path to your My Documents folder
FolderPath = Environ("USERPROFILE") & "\Documents\1 Inbox\"
' Combine with the FolderPath and FileName_DateSentOn
sFileName = FolderPath & Frmt_Date & "_" & sFileName
' Save the attachment as a file.
Atmts.Item(i).SaveAsFile sFileName
End If
End If
Next i
End If
Set Items = Nothing
Set Atmts = Nothing
End Sub