如何为Outlook附件保存至磁盘的VBA脚本添加10KB大小过滤规则

我完全理解你的困扰——那些小附件不仅占空间还打乱邮件布局，确实很烦人。下面是修改后的脚本，已经加入了忽略小于10KB附件的功能，你直接替换原代码就行：

Public Sub SaveAttachments()
 Dim objOL As Outlook.Application
 Dim pobjMsg As Outlook.MailItem 'Object
 Dim objSelection As Outlook.Selection
 ' Get the path to your My Documents folder
 strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
 On Error Resume Next
 ' Instantiate an Outlook Application object.
 Set objOL = CreateObject("Outlook.Application") ' 修正原代码的对象创建错误
 ' Get the collection of selected objects.
 Set objSelection = objOL.ActiveExplorer.Selection
 For Each pobjMsg In objSelection
 SaveAttachments_Parameter pobjMsg
 Next
ExitSub:
 Set pobjMsg = Nothing
 Set objSelection = Nothing
 Set objOL = Nothing
End Sub

Public Sub SaveAttachments_Parameter(objMsg As MailItem)
 Dim objAttachments As Outlook.Attachments
 Dim i As Long
 Dim lngCount As Long
 Dim strFile As String
 Dim strFolderpath As String
 Dim strDeletedFiles As String
 Const MIN_ATTACHMENT_SIZE As Long = 10240 ' 定义10KB的字节数（10*1024）
 ' Get the path to your My Documents folder
 strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
 On Error Resume Next
 ' Set the Attachment folder. 请替换为你的实际保存路径
 strFolderpath = "\your\actual\save\path\"
 ' Get the Attachments collection of the item.
 Set objAttachments = objMsg.Attachments
 lngCount = objAttachments.Count
 If lngCount > 0 Then
 ' 倒序循环避免集合遍历混乱
 For i = lngCount To 1 Step -1
 ' 新增：检查附件大小，小于10KB则跳过处理
 If objAttachments.Item(i).Size < MIN_ATTACHMENT_SIZE Then
 GoTo NextAttachment
 End If
 
 ' Save attachment before deleting from item.
 ' Get the file name.
 strFile = objAttachments.Item(i).FileName
 '=======================================================
 tempstr = strFile 'strtoclean
 charArray = Array("?", "/", "\", ":", "*", """", "<", ">", ",", "&", "#", "~", "%", "{", "}", "+", "_")
 For Each tmpChar In charArray
 Select Case tmpChar
 Case "&"
 changeTo = " and "
 Case ":"
 changeTo = "-"
 Case Else
 changeTo = " "
 End Select
 tempstr = Replace(tempstr, tmpChar, changeTo)
 Next
 strFile = tempstr
 '==========================================================
 ' Combine with the path to the save folder.
 strFile = strFolderpath & Format(objMsg.ReceivedTime, "yyyy-MM-dd h-mm-ss") & "." & strFile
 ' Save the attachment as a file.
 objAttachments.Item(i).SaveAsFile strFile
 ' Delete the attachment.
 objAttachments.Item(i).Delete
 'write the save as path to a string to add to the message
 'check for html and use html tags in link
 If objMsg.BodyFormat <> olFormatHTML Then
 strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
 Else
 strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & strFile & "'>" & strFile & "</a>"
 End If
NextAttachment: ' 跳过小附件的标签
 Next i
 End If
 ' Adds the filename string to the message body and save it
 ' Check for HTML body
 If objMsg.BodyFormat <> olFormatHTML Then
 objMsg.Body = objMsg.Body & vbCrLf & _
 "The file(s) were saved to " & strDeletedFiles
 Else
 objMsg.HTMLBody = objMsg.HTMLBody & "" & _
 "The file(s) were saved to " & strDeletedFiles & ""
 End If
 objMsg.Save
ExitSub:
 Set objAttachments = Nothing
 Set objMsg = Nothing
 Set objOL = Nothing
End Sub

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
End Sub

关键修改说明： #

• 添加大小过滤常量：定义了MIN_ATTACHMENT_SIZE为10240字节（即10KB），你可以根据需求直接修改这个数值调整过滤阈值。
• 新增大小检查逻辑：在处理每个附件前，先判断附件大小，小于设定值就跳过保存和删除操作，避免处理小文件。
• 修正对象创建错误：原代码中Set objOL = CreateObject("WScript.Shell")是错误的，改成Outlook.Application才能正常获取Outlook对象。
• 提示路径修改：记得把strFolderpath = "\your\actual\save\path\"替换成你自己的附件保存文件夹路径。

这样修改后，脚本就只会处理10KB及以上的附件，那些烦人的小Logo文件就会被自动忽略啦！

内容的提问来源于stack exchange，提问作者kshesq