Question

我的目标是：在收到的电子邮件中，将任何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

Answer 1

您不需要规则，请尝试将其添加到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

Outlook宏将PDF附件移动到硬盘驱动器

1 个答案: