Public Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" _
(ByVal lpAppName As String, ByVal lpKeyName As String, _
ByVal lpDefault As String, ByVal lpReturnedString As String, _
ByVal nSize As Long) As Long
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Sub MessageAndAttachmentProcessor(Item As Outlook.MailItem, _
Optional bolPrintMsg As Boolean, _
Optional bolSaveMsg As Boolean, _
Optional bolPrintAtt As Boolean, _
Optional bolSaveAtt As Boolean, _
Optional bolInsertLink As Boolean, _
Optional strAttFileTypes As String, _
Optional strFolderPath As String, _
Optional varMsgFormat As OlSaveAsType, _
Optional strPrinter As String)
Dim olkAttachment As Outlook.Attachment, _
objFSO As FileSystemObject, _
strMyPath As String, _
strExtension As String, _
strFileName As String, _
strOriginalPrinter As String, _
strLinkText As String, _
strRootFolder As String, _
strTempFolder As String, _
varFileType As Variant, _
intCount As Integer, _
intIndex As Integer, _
arrFileTypes As Variant
Set objFSO = CreateObject("Scripting.FileSystemObject")
strTempFolder = Environ("TEMP") & "\"
If strAttFileTypes = "" Then
arrFileTypes = Array("*")
Else
arrFileTypes = Split(strAttFileTypes, ",")
End If
If bolPrintMsg Or bolPrintAtt Then
If strPrinter <> "" Then
strOriginalPrinter = GetDefaultPrinter()
SetDefaultPrinter strPrinter
End If
End If
If bolSaveMsg Or bolSaveAtt Then
If strFolderPath = "" Then
strRootFolder = Environ("USERPROFILE") & "\My Documents\"
Else
strRootFolder = strFolderPath & IIf(Right(strFolderPath, 1) = "\", "", "\")
End If
End If
If bolSaveMsg Then
Select Case varMsgFormat
Case olHTML
strExtension = ".html"
Case olMSG
strExtension = ".msg"
Case olRTF
strExtension = ".rtf"
Case olDoc
strExtension = ".doc"
Case olTXT
strExtension = ".txt"
Case Else
strExtension = ".msg"
End Select
Item.SaveAs strRootFolder & RemoveIllegalCharacters(Item.Subject) & strExtension, varMsgFormat
End If
For intIndex = Item.Attachments.count To 1 Step -1
Set olkAttachment = Item.Attachments.Item(intIndex)
'Print the attachments if requested'
If bolPrintAtt Then
If olkAttachment.Type <> olEmbeddeditem Then
For Each strFileType In arrFileTypes
If (strFileType = "*") Or (LCase(objFSO.GetExtensionName(olkAttachment.FileName)) = LCase(strFileType)) Then
olkAttachment.SaveAsFile strTempFolder & olkAttachment.FileName
ShellExecute 0&, "print", strTempFolder & olkAttachment.FileName, 0&, 0&, 0&
End If
Next
End If
End If
'Save the attachments if requested'
If bolSaveAtt Then
strFileName = olkAttachment.FileName
intCount = 0
Do While True
strMyPath = strRootFolder & strFileName
If objFSO.FileExists(strMyPath) Then
intCount = intCount + 1
strFileName = "Copy (" & intCount & ") of " & olkAttachment.FileName
Else
Exit Do
End If
Loop
olkAttachment.SaveAsFile strMyPath
If bolInsertLink Then
If Item.BodyFormat = olFormatHTML Then
strLinkText = strLinkText & "<a href=""file://" & strMyPath & """>" & olkAttachment.FileName & "</a><br>"
Else
strLinkText = strLinkText & strMyPath & vbCrLf
End If
olkAttachment.Delete
End If
End If
Next
If bolPrintMsg Then
Item.PrintOut
End If
If bolPrintMsg Or bolPrintAtt Then
If strOriginalPrinter <> "" Then
SetDefaultPrinter strOriginalPrinter
End If
End If
If bolInsertLink Then
If Item.BodyFormat = olFormatHTML Then
Item.HTMLBody = Item.HTMLBody & "<br><br>Removed Attachments<br><br>" & strLinkText
Else
Item.Body = Item.Body & vbCrLf & vbCrLf & "Removed Attachments" & vbCrLf & vbCrLf & strLinkText
End If
Item.Save
End If
Set objFSO = Nothing
Set olkAttachment = Nothing
End Sub
Function GetDefaultPrinter() As String
Dim strPrinter As String, _
intReturn As Integer
strPrinter = Space(255)
intReturn = GetProfileString("Windows", ByVal "device", "", strPrinter, Len(strPrinter))
If intReturn Then
strPrinter = UCase(Left(strPrinter, InStr(strPrinter, ",") - 1))
End If
GetDefaultPrinter = strPrinter
End Function
Function RemoveIllegalCharacters(strValue As String) As String
' Purpose: Remove characters that cannot be in a filename from a string.'
' Written: 4/24/2009'
' Author: BlueDevilFan'
' Outlook: All versions'
RemoveIllegalCharacters = strValue
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "<", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ">", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ":", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, Chr(34), "'")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "/", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "\", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "|", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "?", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "*", "")
End Function
Sub SetDefaultPrinter(strPrinterName As String)
Dim objNet As Object
Set objNet = CreateObject("Wscript.Network")
objNet.SetDefaultPrinter strPrinterName
Set objNet = Nothing
End Sub
‘Change MySubroutineName to a unique name on the next line’
Sub MySubroutineName(Item As Outlook.MailItem)
MessageAndAttachmentProcessor Item, P1, P2, P3, P4, P5, P6, P7, P8, P9
End Sub
Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.
Comments (296)
Commented:
Commented:
Open in new window
in the VbaProject.OTM - ThisOutlookSession (Code). I placed this:
Open in new window
in Module 1. What should I do different?
Commented:
This is a great article but clicking on the macro does not do anything. I would like to save all incoming/outcoming messages in a folder on my server or desktop. Would you be able to help me understand what`s I am doing wrong?
Thanks
Commented:
I would like to save the attachments in a subfolder called like the yearname of the incoming mail and then a subfolder called like the emailsenderdomain.
Something like this
C:\Project X\2018\Telekom\
Would this be possible?
Thanks a lot for your help!
Commented:
Any help would be appreciated.
View More