Outlook VBA code to save email in the shared drive

[aman]

Hi Guys,

The following code opens up a dialog window before emails and attachments get saved down on the network. I want this to be automated so that no dialog save as window will open up and the emails and attachments will be saved down on the network automatically. Any help will be much appreciated .

Public Sub MergeMailAndAttachsToPDF_New()
'Update by Extendoffice 2018/3/5
Dim xSelMails As MailItem
Dim xFSysObj As FileSystemObject
Dim xOverwriteBln As Boolean
Dim xLooper As Integer
Dim xEntryID As String
Dim xNameSpace As Outlook.NameSpace
Dim xMail As Outlook.MailItem
Dim xExt As String
Dim xSendEmailAddr, xCompanyDomain As String
Dim xWdApp As Word.Application
Dim xDoc, xNewDoc As Word.Document
Dim I As Integer
Dim xPDFSavePath As String
Dim xPath As String
Dim xFileArr() As String
Dim xExcel As Excel.Application
Dim xWb As Workbook
Dim xWs As Worksheet
Dim xTempDoc As Word.Document
Dim strFileName As String

On Error Resume Next
If (Outlook.ActiveExplorer.Selection.Count > 1) Or (Outlook.ActiveExplorer.Selection.Count = 0) Then
    MsgBox "Please Select a email.", vbInformation + vbOKOnly
    Exit Sub
End If
Set xSelMails = Outlook.ActiveExplorer.Selection.Item(1)
xEntryID = xSelMails.EntryID
Set xNameSpace = Application.GetNamespace("MAPI")
Set xMail = xNameSpace.GetItemFromID(xEntryID)
 
xSendEmailAddr = xMail.SenderEmailAddress
xCompanyDomain = Right(xSendEmailAddr, Len(xSendEmailAddr) - InStr(xSendEmailAddr, "@"))
xOverwriteBln = False
Set xExcel = New Excel.Application
xExcel.Visible = False
Set xWdApp = New Word.Application
xExcel.DisplayAlerts = False
strSaveFldr = GetPrivateProfileString32("U:\test.ini", "SaveFolder", "FolderName")
strFileName = MortANo & "-" & DocType_Col1 & "-" & email & "-" & Environ("Username")
xPDFSavePath = xExcel.Application.GetSaveAsFilename(InitialFileName:=strSaveFldr & strFileName, FileFilter:="PDF Files(*.pdf),*.pdf")
If xPDFSavePath = "False" Then
    xExcel.DisplayAlerts = True
    xExcel.Quit
    xWdApp.Quit
    Exit Sub
End If
xPath = Left(xPDFSavePath, InStrRev(xPDFSavePath, "\"))
cPath = xPath & xCompanyDomain & "\"
yPath = cPath & Format(Now(), "yyyy") & "\"
mPath = yPath & Format(Now(), "MMMM") & "\"

[Gasman]

I *think* all you would need to do is surround your code with the loop for selected items.? The items still need to be selected though?

Something along these lines.

HTH

Sub GetSelectedItems()
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
    Dim mySender As Outlook.AddressEntry
    Dim oMail As Outlook.MailItem
    Dim oAppt As Outlook.AppointmentItem
    Dim oPA As Outlook.PropertyAccessor
    Dim strSenderID As String
    Const PR_SENT_REPRESENTING_ENTRYID As String = _
          "https://schemas.microsoft.com/mapi/proptag/0x00410102"
    Dim MsgTxt As String
    Dim x As Long

    MsgTxt = "Senders of selected items:"
    Set myOlExp = Application.ActiveExplorer
    Set myOlSel = myOlExp.Selection
    For x = 1 To myOlSel.Count
        If myOlSel.Item(x).Class = OlObjectClass.olMail Then
            ' For mail item, use the SenderName property.
            Set oMail = myOlSel.Item(x)
            MsgTxt = MsgTxt & oMail.SenderName & ";"
        ElseIf myOlSel.Item(x).Class = OlObjectClass.olAppointment Then
            ' For appointment item, use the Organizer property.
            Set oAppt = myOlSel.Item(x)
            MsgTxt = MsgTxt & oAppt.Organizer & ";"
        Else
            ' For other items, use the property accessor to get sender ID,
            ' then get the address entry to display the sender name.
            Set oPA = myOlSel.Item(x).PropertyAccessor
            strSenderID = oPA.GetProperty(PR_SENT_REPRESENTING_ENTRYID)
            Set mySender = Application.Session.GetAddressEntryFromID(strSenderID)
            MsgTxt = MsgTxt & mySender.Name & ";"
        End If
    Next x
    Debug.Print MsgTxt
End Sub

[aman]

Hi Gasman, They can only select one email at a time. So basically instead of opening that saveas dialog window , I just want it to be saved down automatically. Thanks

[aman]

Also not sure why xExcel object is being used in the code? Why do we need to open excel to merge email and attachments into one PDF ?

Public Sub MergeMailAndAttachsToPDF_New()
'Update by Extendoffice 2018/3/5
Dim xSelMails As MailItem
Dim xFSysObj As FileSystemObject
Dim xOverwriteBln As Boolean
Dim xLooper As Integer
Dim xEntryID As String
Dim xNameSpace As Outlook.NameSpace
Dim xMail As Outlook.MailItem
Dim xExt As String
Dim xSendEmailAddr, xCompanyDomain As String
Dim xWdApp As Word.Application
Dim xDoc, xNewDoc As Word.Document
Dim I As Integer
Dim xPDFSavePath As String
Dim xPath As String
Dim xFileArr() As String
Dim xExcel As Excel.Application
Dim xWb As Workbook
Dim xWs As Worksheet
Dim xTempDoc As Word.Document
Dim strFileName As String

On Error Resume Next
If (Outlook.ActiveExplorer.Selection.Count > 1) Or (Outlook.ActiveExplorer.Selection.Count = 0) Then
    MsgBox "Please Select a email.", vbInformation + vbOKOnly
    Exit Sub
End If
Set xSelMails = Outlook.ActiveExplorer.Selection.Item(1)
xEntryID = xSelMails.EntryID
Set xNameSpace = Application.GetNamespace("MAPI")
Set xMail = xNameSpace.GetItemFromID(xEntryID)
 
xSendEmailAddr = xMail.SenderEmailAddress
xCompanyDomain = Right(xSendEmailAddr, Len(xSendEmailAddr) - InStr(xSendEmailAddr, "@"))
xOverwriteBln = False
Set xExcel = New Excel.Application
xExcel.Visible = False
Set xWdApp = New Word.Application
xExcel.DisplayAlerts = False
strSaveFldr = GetPrivateProfileString32("U:\test.ini", "SaveFolder", "FolderName")
strFileName = MortANo & "-" & DocType_Col1 & "-" & email & "-" & Environ("Username")
xPDFSavePath = xExcel.Application.GetSaveAsFilename(InitialFileName:=strSaveFldr & strFileName, FileFilter:="PDF Files(*.pdf),*.pdf")
If xPDFSavePath = "False" Then
    xExcel.DisplayAlerts = True
    xExcel.Quit
    xWdApp.Quit
    Exit Sub
End If
xPath = Left(xPDFSavePath, InStrRev(xPDFSavePath, "\"))
cPath = xPath & xCompanyDomain & "\"
yPath = cPath & Format(Now(), "yyyy") & "\"
mPath = yPath & Format(Now(), "MMMM") & "\"

[Minty]

I think the fact you pasted that code suggested that you were using it ?

What is your objective here, to simply save Outlook attachments to a specific folder via Outlook VBA ?

Edit: If yes then have a read here https://www.rondebruin.nl/win/s1/outlook/saveatt.htm

[Gasman]

It appears it is just using Excel as the app to save as PDF.?
You also have Word in there.?

That is not all of the code and I do not see any mention of attachments?

Here is some code that I use to save attachments from email messages, and remove them from those messages.

HTH

Public Sub ReplaceAttachmentsToLink()
    Dim objApp As Outlook.Application
    Dim aMail As Outlook.MailItem    'Object
    Dim oAttachments As Outlook.Attachments
    Dim oSelection As Outlook.Selection
    Dim oPA As PropertyAccessor
    Dim i As Long
    Dim iCount As Long
    Dim sFile As String
    Dim sFolderPath As String
    Dim sDeletedFiles As String
    Dim sDate As String, sTime As String

    Const PR_ATTACHMENT_HIDDEN = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
    
    ' Get the path to your My Documents folder
    sFolderPath = CreateObject("WScript.Shell").SpecialFolders(16)
    On Error Resume Next

    ' Instantiate an Outlook Application object.
    Set objApp = CreateObject("Outlook.Application")

    ' Get the collection of selected objects.
    Set oSelection = objApp.ActiveExplorer.Selection

    ' Set the Attachment folder.
    sFolderPath = sFolderPath & "\OLAttachments"

    'If folder does not exist create it
    If Dir(sFolderPath, vbDirectory) = "" Then
        MkDir sFolderPath
    End If

    ' Check each selected item for attachments. If attachments exist,
    ' save them to the Temp folder and strip them from the item.
    For Each aMail In oSelection

        ' This code only strips attachments from mail items.
        ' If aMail.class=olMail Then
        ' Get the Attachments collection of the item.
        Set oAttachments = aMail.Attachments
        iCount = oAttachments.Count

        If iCount > 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 = iCount To 1 Step -1
                Set oPA = oAttachments.Item(i).PropertyAccessor
                If oPA.GetProperty(PR_ATTACHMENT_HIDDEN) = False Then
                    ' Save attachment before deleting from item.
                    ' Get the file name.
                    sFile = oAttachments.Item(i).FileName

                    'Now get Date & Time as strings to use in filename, but use received date & time
                    sDate = Format(aMail.ReceivedTime, "yyyymmdd")
                    sTime = Format(aMail.ReceivedTime, "hhmmss")

                    ' Combine with the path to the Temp folder.
                    sFile = sFolderPath & "\" & sDate & "_" & sTime & "_" & sFile

                    ' Save the attachment as a file.
                    oAttachments.Item(i).SaveAsFile sFile

                    ' Delete the attachment.
                    oAttachments.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 aMail.BodyFormat <> olFormatHTML Then
                        sDeletedFiles = sDeletedFiles & vbCrLf & "<file://" & sFile & ">"
                    Else
                        sDeletedFiles = sDeletedFiles & "<br>" & "<a href='file://" & _
                                        sFile & "'>" & sFile & "</a>"
                    End If
                End If
            Next i

            ' Adds the filename string to the message body and save it
            ' Check for HTML body
            If aMail.BodyFormat <> olFormatHTML Then
                aMail.Body = aMail.Body & vbCrLf & _
                             "The file(s) were saved to " & sDeletedFiles
            Else
                aMail.HTMLBody = aMail.HTMLBody & "<p>" & _
                                 "The file(s) were saved to " & sDeletedFiles & "</p>"
            End If

            aMail.Save
            'sets the attachment path to nothing before it moves on to the next message.
            sDeletedFiles = ""

        End If
    Next    'end aMail

ExitSub:

    Set oAttachments = Nothing
    Set aMail = Nothing
    Set oSelection = Nothing
    Set objApp = Nothing
End Sub

[aman]

My objective is to merge email body and attachments of the selected email into one PDF and save it down on shared drive. It does work but just opens up the dialog box so I need to click save manually. I want this to be automated . I think its a matter of replacing the function xExcel.Application.GetSaveAsFilename(InitialFileNa me:=strSaveFldr & strFileName, FileFilter:="PDF Files(*.pdf),*.pdf") with something else??

[Gasman]

Have you tried SaveAs instead of GetSaveAsFilename ?

[aman]

I just got rid of GetSaveAsFileName function and it didn't display the dialog box. Please see below the amended code. It works perfectly fine but I think there is unnecessary code in there and I am not sure why we are using both excel and word document to perform conversion and merging ????

Can anyone please tidy up the code ? Thanks

Public Sub MergeMailAndAttachsToPDF_New(MortANo As String)
Dim xSelMails As MailItem
Dim xFSysObj As FileSystemObject
Dim xOverwriteBln As Boolean
Dim xLooper As Integer
Dim xEntryID As String
Dim xNameSpace As Outlook.NameSpace
Dim xMail As Outlook.MailItem
Dim xExt As String
Dim xSendEmailAddr, xCompanyDomain As String
Dim xWdApp As Word.Application
Dim xDoc, xNewDoc As Word.Document
Dim I As Integer
Dim xPDFSavePath As String
Dim xPath As String
Dim xFileArr() As String
'Dim xExcel As Excel.Application
Dim xWb As Workbook
Dim xWs As Worksheet
Dim xTempDoc As Word.Document
Dim strFileName As String

On Error Resume Next
If (Outlook.ActiveExplorer.Selection.Count > 1) Or (Outlook.ActiveExplorer.Selection.Count = 0) Then
    MsgBox "Please Select a email.", vbInformation + vbOKOnly
    Exit Sub
End If
Set xSelMails = Outlook.ActiveExplorer.Selection.Item(1)
xEntryID = xSelMails.EntryID
Set xNameSpace = Application.GetNamespace("MAPI")
Set xMail = xNameSpace.GetItemFromID(xEntryID)
 
xSendEmailAddr = xMail.SenderEmailAddress
xCompanyDomain = Right(xSendEmailAddr, Len(xSendEmailAddr) - InStr(xSendEmailAddr, "@"))
xOverwriteBln = False
Set xExcel = New Excel.Application
xExcel.Visible = False
Set xWdApp = New Word.Application
xExcel.DisplayAlerts = False
strSaveFldr = GetPrivateProfileString32("U:\test.ini", "SaveFolder", "FolderName")
strFileName = MortANo & "-" & DocType_Col1 & "-" & email & "-" & Environ("Username")
xPDFSavePath = strSaveFldr & strFileName & ".pdf"
If xPDFSavePath = "False" Then
   xExcel.DisplayAlerts = True
   xExcel.Quit
   xWdApp.Quit
   Exit Sub
End If
xPath = Left(xPDFSavePath, InStrRev(xPDFSavePath, "\"))
cPath = xPath & xCompanyDomain & "\"
yPath = cPath & Format(Now(), "yyyy") & "\"
mPath = yPath & Format(Now(), "MMMM") & "\"
If Dir(xPath, vbDirectory) = vbNullString Then
   MkDir xPath
End If
EmailSubject = CleanFileName(xMail.Subject)
xSaveName = Format(xMail.ReceivedTime, "yyyymmdd") & "_" & EmailSubject & ".doc"
Set xFSysObj = CreateObject("Scripting.FileSystemObject")
If xOverwriteBln = False Then
   xLooper = 0
  Do While xFSysObj.FileExists(yPath & xSaveName)
      xLooper = xLooper + 1
      xSaveName = Format(xMail.ReceivedTime, "yyyymmdd") & "_" & EmailSubject & "_" & xLooper & ".doc"
   Loop
Else
   If xFSysObj.FileExists(yPath & xSaveName) Then
      xFSysObj.DeleteFile yPath & xSaveName
   End If
End If
xMail.SaveAs xPath & xSaveName, olDoc
If xMail.Attachments.Count > 0 Then
   For Each Atmt In xMail.Attachments
      xExt = SplitPath(Atmt.FileName, 2)
      If (xExt = ".docx") Or (xExt = ".doc") Or (xExt = ".docm") Or (xExt = ".dot") Or (xExt = ".dotm") Or (xExt = ".dotx") _
      Or (xExt = ".xlsx") Or (xExt = ".xls") Or (xExt = ".xlsm") Or (xExt = ".xlt") Or (xExt = ".xltm") Or (xExt = ".xltx") Then
        atmtName = CleanFileName(Atmt.FileName)
        atmtSave = strSaveFldr & Format(xMail.ReceivedTime, "yyyymmdd") & "_" & atmtName
        Atmt.SaveAsFile atmtSave
      End If
   Next
End If
Set xNewDoc = xWdApp.Documents.Add("Normal", False, wdNewBlankDocument, False)
Set xFilesFld = xFSysObj.GetFolder(xPath)
xFileArr() = GetFiles(strSaveFldr)
For I = 0 To UBound(xFileArr()) - 1
    xExt = SplitPath(xFileArr(I), 2)
    If (xExt = ".xlsx") Or (xExt = ".xls") Or (xExt = ".xlsm") Or (xExt = ".xlt") Or _
       (xExt = ".xltm") Or (xExt = ".xltx") Then  'conver excel to word
        Set xWb = xExcel.Workbooks.Open(xPath & xFileArr(I))
        Set xTempDoc = xWdApp.Documents.Add("Normal", False, wdNewBlankDocument, False)
        Set xWs = xWb.ActiveSheet
        xWs.UsedRange.Copy
        xTempDoc.Content.PasteAndFormat wdFormatOriginalFormatting
        xTempDoc.SaveAs2 xPath & xWs.Name + ".docx", wdFormatXMLDocument
        xWb.Close False
        Kill xPath & xFileArr(I)
        xTempDoc.Close wdDoNotSaveChanges, wdOriginalDocumentFormat, False
    End If
Next
xExcel.DisplayAlerts = True
xExcel.Quit
xFileArr() = GetFiles(xPath)
'Merge Documents
For I = 0 To UBound(xFileArr()) - 1
    xExt = SplitPath(xFileArr(I), 2)
    If (xExt = ".docx") Or (xExt = ".doc") Or (xExt = ".docm") Or (xExt = ".dot") Or _
       (xExt = ".dotm") Or (xExt = ".dotx") Then
        MergeDoc xWdApp, xPath & xFileArr(I), xNewDoc
        Kill xPath & xFileArr(I)
    End If
Next
xNewDoc.Sections.Item(1).Range.Delete wdCharacter, 1
xNewDoc.SaveAs2 xPDFSavePath, wdFormatPDF
xNewDoc.Close wdDoNotSaveChanges, wdOriginalDocumentFormat, False
xWdApp.Quit
Set xMail = Nothing
Set xNameSpace = Nothing
Set xFSysObj = Nothing
MsgBox "Merged successfully", vbInformation + vbOKOnly
End Sub
 
Public Function SplitPath(FullPath As String, ResultFlag As Integer) As String
Dim SplitPos As Integer, DotPos As Integer
SplitPos = InStrRev(FullPath, "/")
DotPos = InStrRev(FullPath, ".")
Select Case ResultFlag
Case 0
   SplitPath = Left(FullPath, SplitPos - 1)
Case 1
   If DotPos = 0 Then DotPos = Len(FullPath) + 1
   SplitPath = Mid(FullPath, SplitPos + 1, DotPos - SplitPos - 1)
Case 2
   If DotPos = 0 Then DotPos = Len(FullPath)
   SplitPath = Mid(FullPath, DotPos)
Case Else
   Err.Raise vbObjectError + 1, "SplitPath Function", "Invalid Parameter!"
End Select
End Function
   
Function CleanFileName(StrText As String) As String
Dim xStripChars As String
Dim xLen As Integer
Dim I As Integer
xStripChars = "/\[]:=," & Chr(34)
xLen = Len(xStripChars)
StrText = Trim(StrText)
For I = 1 To xLen
StrText = Replace(StrText, Mid(xStripChars, I, 1), "")
Next
CleanFileName = StrText
End Function
 
Function GetFiles(xFldPath As String) As String()
On Error Resume Next
Dim xFile As String
Dim xFileArr() As String
Dim xArr() As String
Dim I, x As Integer
x = 0
ReDim xFileArr(1)
xFileArr(1) = xFldPath '& "\"
xFile = Dir(xFileArr(1) & "*.*")
Do Until xFile = ""
    x = x + 1
    xFile = Dir
Loop
ReDim xArr(0 To x)
x = 0
xFile = Dir(xFileArr(1) & "*.*")
Do Until xFile = ""
    xArr(x) = xFile
    x = x + 1
    xFile = Dir
Loop
GetFiles = xArr()
End Function
 
Sub MergeDoc(WdApp As Word.Application, xFileName As String, Doc As Document)
Dim xNewDoc As Document
Dim xSec As Section
    Set xNewDoc = WdApp.Documents.Open(FileName:=xFileName, Visible:=False)
    Set xSec = Doc.Sections.Add
    xNewDoc.Content.Copy
    xSec.PageSetup = xNewDoc.PageSetup
    xSec.Range.PasteAndFormat wdFormatOriginalFormatting
    xNewDoc.Close
End Sub

[Gasman]

Now you have shown all the code, Word is being used to Merge all the Word docs?

I'd leave it well alone.
If it ain't broke don't fix it.

[aman]

Thanks Gasman, Another thing here is the code works fine if there are word document attachments but when there are excel attachments then it will only look for the selected sheet in the attachments and then merge into one PDF. I want the code to look for all the sheets in the excel workbook and if the sheet is not blank then merge them into one PdF.

I hope it makes sense . Can anyone please tweak the code accordingly?

Thanks

[Gasman]

Try

For each xWs in xWb.Sheets
        xWs.UsedRange.Copy
        xTempDoc.Content.PasteAndFormat wdFormatOriginalFormatting
Next

Not sure if you would need to move the cursor for any following pastes.

HTH

[aman]

I tried that but it didn't merge excel workbook attachment at all.

It just converted email body to PDF and saved it down but ignored excel attachment .

[aman]

Hi guys, Also the code ignores pdf attachments and doesn't save them on the shared folder. Any help will be much appreciated .

Thanks

[aman]

Also guys at the moment when the code merges email message and attachments into pdf then in the pdf file attachments appear first and then at the bottom email message appear . I want it done the other way so email message on the top and then attachments at the bottom.