关于 vba:Outlook 只保存 pdf 附件


Outlook save only pdf attachments

您好，我已经找到了这段代码并使用了一段时间，但我希望添加一条规则来仅保存 PDF 附件并计算已保存的 PDF 文件的数量。

我已经保存了所有文件，它循环了重复的文件，但我只想保存 pdf 文件。

有人可以帮忙吗？

谢谢

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
' ######################################################
'  Returns the number of attachements in the selection.
' ######################################################
Public Function SaveAttachmentsFromSelection() As Long
    Dim objFSO              As Object       ' Computer's file system object.
    Dim objShell            As Object       ' Windows Shell application object.
    Dim objFolder           As Object       ' The selected folder object from Browse for Folder dialog box.
    Dim objItem             As Object       ' A specific member of a Collection object either by position or by key.
    Dim selItems            As Selection    ' A collection of Outlook item objects in a folder.
    Dim Atmt                As Attachment   ' A document or link to a document contained in an Outlook item.
    Dim strAtmtPath         As String       ' The full saving path of the attachment.
    Dim strAtmtFullName     As String       ' The full name of an attachment.
    Dim strAtmtName(1)      As String       ' strAtmtName(0): to save the name; strAtmtName(1): to save the file extension. They are separated by dot of an attachment file name.
    Dim strAtmtNameTemp     As String       ' To save a temporary attachment file name.
    Dim intDotPosition      As Integer      ' The dot position in an attachment name.
    Dim atmts               As Attachments  ' A set of Attachment objects that represent the attachments in an Outlook item.
    Dim lCountEachItem      As Long         ' The number of attachments in each Outlook item.
    Dim lCountAllItems      As Long         ' The number of attachments in all Outlook items.
    Dim strFolderpath       As String       ' The selected folder path.
    Dim blnIsEnd            As Boolean      ' End all code execution.
    Dim blnIsSave           As Boolean      ' Consider if it is need to save.
    Dim oItem               As Object
    Dim iAttachments        As Integer


    blnIsEnd = False
    blnIsSave = False
    lCountAllItems = 0

    On Error Resume Next

    Set selItems = ActiveExplorer.Selection

    If Err.Number = 0 Then

        ' Get the handle of Outlook window.
        lHwnd = FindWindow(olAppCLSN, vbNullString)

        If lHwnd <> 0 Then

            ' /* Create a Shell application object to pop-up BrowseForFolder dialog box. */
            Set objShell = CreateObject("Shell.Application")
            Set objFSO = CreateObject("Scripting.FileSystemObject")
            Set objFolder = objShell.BrowseForFolder(lHwnd,"Select folder to save attachments:", _
                                                     BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN, CSIDL_DESKTOP)

            ' /* Failed to create the Shell application. */
            If Err.Number <> 0 Then
                MsgBox"Run-time error '" & CStr(Err.Number) &" (0x" & CStr(Hex(Err.Number)) &")':" & vbNewLine & _
                       Err.Description &".", vbCritical,"Error from Attachment Saver"
                blnIsEnd = True
                GoTo PROC_EXIT
            End If

            If objFolder Is Nothing Then
                strFolderpath =""
                blnIsEnd = True
                GoTo PROC_EXIT
            Else
                strFolderpath = CGPath(objFolder.Self.Path)


                ' /* Go through each item in the selection. */
                For Each objItem In selItems
                    lCountEachItem = objItem.Attachments.Count

                    ' /* If the current item contains attachments. */
                    If lCountEachItem > 0 Then
                        Set atmts = objItem.Attachments

                        ' /* Go through each attachment in the current item. */
                        For Each Atmt In atmts

                            ' Get the full name of the current attachment.
                            strAtmtFullName = Atmt.FileName

                            ' Find the dot postion in atmtFullName.
                            intDotPosition = InStrRev(strAtmtFullName,".")

                            ' Get the name.
                            strAtmtName(0) = Left$(strAtmtFullName, intDotPosition - 1)
                            ' Get the file extension.
                            strAtmtName(1) = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition)
                            ' Get the full saving path of the current attachment.
                            strAtmtPath = strFolderpath & Atmt.FileName

                            ' /* If the length of the saving path is not larger than 260 characters.*/
                            If Len(strAtmtPath) <= MAX_PATH Then
                                ' True: This attachment can be saved.
                                blnIsSave = True

                                ' /* Loop until getting the file name which does not exist in the folder. */
                                Do While objFSO.FileExists(strAtmtPath)
                                    strAtmtNameTemp = strAtmtName(0) & _
                                                      Format(Now,"_mmddhhmmss") & _
                                                      Format(Timer * 1000 Mod 1000,"000")
                                    strAtmtPath = strFolderpath & strAtmtNameTemp &"." & strAtmtName(1)

                                    ' /* If the length of the saving path is over 260 characters.*/
                                    If Len(strAtmtPath) > MAX_PATH Then
                                        lCountEachItem = lCountEachItem - 1
                                        ' False: This attachment cannot be saved.
                                        blnIsSave = False
                                        Exit Do
                                    End If
                                Loop

                                ' /* Save the current attachment if it is a valid file name. */
                                If blnIsSave Then Atmt.SaveAsFile strAtmtPath
                            Else
                                lCountEachItem = lCountEachItem - 1
                            End If
                        Next
                    End If

                    ' Count the number of attachments in all Outlook items.
                    lCountAllItems = lCountAllItems + lCountEachItem
                Next
            End If
        Else
            MsgBox"Failed to get the handle of Outlook window!", vbCritical,"Error from Attachment Saver"
            blnIsEnd = True
            GoTo PROC_EXIT
        End If

    ' /* For run-time error:
    '    The Explorer has been closed and cannot be used for further operations.
    '    Review your code and restart Outlook. */
    Else
        MsgBox"Please select an Outlook item at least.", vbExclamation,"Message from Attachment Saver"
        blnIsEnd = True
    End If

PROC_EXIT:
    SaveAttachmentsFromSelection = lCountAllItems

    ' /* Release memory. */
    If Not (objFSO Is Nothing) Then Set objFSO = Nothing
    If Not (objItem Is Nothing) Then Set objItem = Nothing
    If Not (selItems Is Nothing) Then Set selItems = Nothing
    If Not (Atmt Is Nothing) Then Set Atmt = Nothing
    If Not (atmts Is Nothing) Then Set atmts = Nothing

    ' /* End all code execution if the value of blnIsEnd is True. */
    If blnIsEnd Then End
End Function

' #####################
' Convert general path.
' #####################
Public Function CGPath(ByVal Path As String) As String
    If Right(Path, 1) <>"" Then Path = Path &""
    CGPath = Path
End Function

' ######################################
' Run this macro for saving attachments.
' ######################################
Public Sub ExecuteSaving()
    Dim oItem As Object
    Dim iAttachments As Integer

    For Each oItem In ActiveExplorer.Selection
    iAttachments = oItem.Attachments.Count + iAttachments
    Next
    MsgBox"Selected" & ActiveExplorer.Selection.Count &" messages with" & iAttachments &" attachements"
End Sub

只需使用 Select Case Statement 即可更快地执行且更易于理解......并且更灵活地添加其他文件类型

之后

1
2
' /* Go through each attachment in the current item. */
For Each Atmt In atmts

只需添加

1
2
3
4
5
6
7
8
Dim sFileType As String
' Last 4 Characters in a Filename
sFileType = LCase$(Right$(Atmt.FileName, 4))
Debug.Print sFileType

Select Case sFileType
    ' Add additional file types below".doc","docx",".xls"
    Case".pdf"

和Next

之前

添加

1
  End Select
相关讨论

只需改变

1
If Len(strAtmtPath) <= MAX_PATH Then

到

1
If Len(strAtmtPath) <= MAX_PATH And LCase(strAtmtName(1)) ="pdf" Then

完整代码：

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
' ######################################################
'  Returns the number of attachements in the selection.
' ######################################################
Public Function SaveAttachmentsFromSelection() As Long
    Dim objFSO              As Object       ' Computer's file system object.
    Dim objShell            As Object       ' Windows Shell application object.
    Dim objFolder           As Object       ' The selected folder object from Browse for Folder dialog box.
    Dim objItem             As Object       ' A specific member of a Collection object either by position or by key.
    Dim selItems            As Selection    ' A collection of Outlook item objects in a folder.
    Dim Atmt                As Attachment   ' A document or link to a document contained in an Outlook item.
    Dim strAtmtPath         As String       ' The full saving path of the attachment.
    Dim strAtmtFullName     As String       ' The full name of an attachment.
    Dim strAtmtName(1)      As String       ' strAtmtName(0): to save the name; strAtmtName(1): to save the file extension. They are separated by dot of an attachment file name.
    Dim strAtmtNameTemp     As String       ' To save a temporary attachment file name.
    Dim intDotPosition      As Integer      ' The dot position in an attachment name.
    Dim atmts               As Attachments  ' A set of Attachment objects that represent the attachments in an Outlook item.
    Dim lCountEachItem      As Long         ' The number of attachments in each Outlook item.
    Dim lCountAllItems      As Long         ' The number of attachments in all Outlook items.
    Dim strFolderpath       As String       ' The selected folder path.
    Dim blnIsEnd            As Boolean      ' End all code execution.
    Dim blnIsSave           As Boolean      ' Consider if it is need to save.
    Dim oItem               As Object
    Dim iAttachments        As Integer


    blnIsEnd = False
    blnIsSave = False
    lCountAllItems = 0

    On Error Resume Next

    Set selItems = ActiveExplorer.Selection

    If Err.Number = 0 Then

        ' Get the handle of Outlook window.
        lHwnd = FindWindow(olAppCLSN, vbNullString)

        If lHwnd <> 0 Then

            ' /* Create a Shell application object to pop-up BrowseForFolder dialog box. */
            Set objShell = CreateObject("Shell.Application")
            Set objFSO = CreateObject("Scripting.FileSystemObject")
            Set objFolder = objShell.BrowseForFolder(lHwnd,"Select folder to save attachments:", _
                                                     BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN, CSIDL_DESKTOP)

            ' /* Failed to create the Shell application. */
            If Err.Number <> 0 Then
                MsgBox"Run-time error '" & CStr(Err.Number) &" (0x" & CStr(Hex(Err.Number)) &")':" & vbNewLine & _
                       Err.Description &".", vbCritical,"Error from Attachment Saver"
                blnIsEnd = True
                GoTo PROC_EXIT
            End If

            If objFolder Is Nothing Then
                strFolderpath =""
                blnIsEnd = True
                GoTo PROC_EXIT
            Else
                strFolderpath = CGPath(objFolder.Self.Path)


                ' /* Go through each item in the selection. */
                For Each objItem In selItems
                    lCountEachItem = objItem.Attachments.Count

                    ' /* If the current item contains attachments. */
                    If lCountEachItem > 0 Then
                        Set atmts = objItem.Attachments

                        ' /* Go through each attachment in the current item. */
                        For Each Atmt In atmts

                            ' Get the full name of the current attachment.
                            strAtmtFullName = Atmt.FileName

                            ' Find the dot postion in atmtFullName.
                            intDotPosition = InStrRev(strAtmtFullName,".")

                            ' Get the name.
                            strAtmtName(0) = Left$(strAtmtFullName, intDotPosition - 1)
                            ' Get the file extension.
                            strAtmtName(1) = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition)
                            ' Get the full saving path of the current attachment.
                            strAtmtPath = strFolderpath & Atmt.FileName

                            ' /* If the length of the saving path is not larger than 260 characters.*/
                            If Len(strAtmtPath) <= MAX_PATH And LCase(strAtmtName(1)) ="pdf" Then
                                ' True: This attachment can be saved.
                                blnIsSave = True

                                ' /* Loop until getting the file name which does not exist in the folder. */
                                Do While objFSO.FileExists(strAtmtPath)
                                    strAtmtNameTemp = strAtmtName(0) & _
                                                      Format(Now,"_mmddhhmmss") & _
                                                      Format(Timer * 1000 Mod 1000,"000")
                                    strAtmtPath = strFolderpath & strAtmtNameTemp &"." & strAtmtName(1)

                                    ' /* If the length of the saving path is over 260 characters.*/
                                    If Len(strAtmtPath) > MAX_PATH Then
                                        lCountEachItem = lCountEachItem - 1
                                        ' False: This attachment cannot be saved.
                                        blnIsSave = False
                                        Exit Do
                                    End If
                                Loop

                                ' /* Save the current attachment if it is a valid file name. */
                                If blnIsSave Then Atmt.SaveAsFile strAtmtPath
                            Else
                                lCountEachItem = lCountEachItem - 1
                            End If
                        Next
                    End If

                    ' Count the number of attachments in all Outlook items.
                    lCountAllItems = lCountAllItems + lCountEachItem
                Next
            End If
        Else
            MsgBox"Failed to get the handle of Outlook window!", vbCritical,"Error from Attachment Saver"
            blnIsEnd = True
            GoTo PROC_EXIT
        End If

    ' /* For run-time error:
    '    The Explorer has been closed and cannot be used for further operations.
    '    Review your code and restart Outlook. */
    Else
        MsgBox"Please select an Outlook item at least.", vbExclamation,"Message from Attachment Saver"
        blnIsEnd = True
    End If

PROC_EXIT:
    SaveAttachmentsFromSelection = lCountAllItems

    ' /* Release memory. */
    If Not (objFSO Is Nothing) Then Set objFSO = Nothing
    If Not (objItem Is Nothing) Then Set objItem = Nothing
    If Not (selItems Is Nothing) Then Set selItems = Nothing
    If Not (Atmt Is Nothing) Then Set Atmt = Nothing
    If Not (atmts Is Nothing) Then Set atmts = Nothing

    ' /* End all code execution if the value of blnIsEnd is True. */
    If blnIsEnd Then End
End Function

' #####################
' Convert general path.
' #####################
Public Function CGPath(ByVal Path As String) As String
    If Right(Path, 1) <>"" Then Path = Path &""
    CGPath = Path
End Function

' ######################################
' Run this macro for saving attachments.
' ######################################
Public Sub ExecuteSaving()
    Dim oItem As Object
    Dim iAttachments As Integer

    For Each oItem In ActiveExplorer.Selection
    iAttachments = oItem.Attachments.Count + iAttachments
    Next
    MsgBox"Selected" & ActiveExplorer.Selection.Count &" messages with" & iAttachments &" attachements"
End Sub

相关讨论