使用大小过滤器将 Outlook 附件保存到磁盘

Question

指的是在这里找到的神奇脚本 Save Outlook attachment to disk

我想按大小过滤附件。我现在使用该脚本有一段时间了，但该脚本还保存了公司徽标等。这提供了许多 1kb 文件并更改了邮件布局。

我希望脚本忽略小于 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
 
' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next
 
' Set the Attachment folder.
strFolderpath = "\path\"
 
' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
 
If lngCount > 0 Then
 
' We need to use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
 
' 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 Temp 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
     
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

Answer 1

Attachment.Size 属性可能会有帮助。

你可以做到

For i = lngCount To 1 Step -1
   if objAttachments.Item(i).Size >= 10240 then
       ...
   end if
Next i

使用大小过滤器将 Outlook 附件保存到磁盘

Save Outlook attachment to disk with size filter

size

outlook

vba

attachment