您好我已经找到了这段代码并且已经使用了一段时间但是我希望添加一条规则来保存PDF附件并计算已保存的PDF文件数量。
我已经保存了所有文件并且循环了重复的文件，但我只是想保存它们。
有人可以协助吗？
感谢
swap答案 0 :(得分：2)
只需更快地使用 Select Case Statement 执行并更易于理解..并且可以更灵活地添加其他文件类型
之后
' /* Go through each attachment in the current item. */
For Each Atmt In atmts
只需添加
即可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
添加的
End Select
答案 1 :(得分：1)
只需更改
If Len(strAtmtPath) <= MAX_PATH Then
到
If Len(strAtmtPath) <= MAX_PATH And LCase(strAtmtName(1)) = "pdf" Then
完整代码：
' ######################################################
' 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