Go Back   Access World Forums > Microsoft Access Discussion > Modules & VBA

 
Reply
 
Thread Tools Rate Thread Display Modes
Old 02-20-2019, 03:33 AM   #1
aman
Newly Registered User
 
Join Date: Oct 2008
Posts: 1,250
Thanks: 54
Thanked 3 Times in 2 Posts
aman is an unknown quantity at this point
Outlook VBA code to save email in the shared drive

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 .
Code:
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") & "\"

aman is offline   Reply With Quote
Old 02-20-2019, 06:27 AM   #2
Gasman
Enthusiastic Amateur
 
Gasman's Avatar
 
Join Date: Sep 2011
Location: Swansea, South Wales,UK
Posts: 4,507
Thanks: 439
Thanked 838 Times in 809 Posts
Gasman is a jewel in the rough Gasman is a jewel in the rough Gasman is a jewel in the rough
Re: Outlook VBA code to save email in the shared drive

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
Code:
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
__________________
Access novice. Sometimes trying to give something back.
Access 2007

Please, please use code tag # when posting code snippets

To view links or images in signatures your post count must be 10 or greater. You currently have 0 posts.


To view links or images in signatures your post count must be 10 or greater. You currently have 0 posts.


To view links or images in signatures your post count must be 10 or greater. You currently have 0 posts.
Gasman is offline   Reply With Quote
Old 02-21-2019, 03:17 AM   #3
aman
Newly Registered User
 
Join Date: Oct 2008
Posts: 1,250
Thanks: 54
Thanked 3 Times in 2 Posts
aman is an unknown quantity at this point
Re: Outlook VBA code to save email in the shared drive

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 is offline   Reply With Quote
Old 02-21-2019, 03:19 AM   #4
aman
Newly Registered User
 
Join Date: Oct 2008
Posts: 1,250
Thanks: 54
Thanked 3 Times in 2 Posts
aman is an unknown quantity at this point
Re: Outlook VBA code to save email in the shared drive

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 ?
Code:
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") & "\"
aman is offline   Reply With Quote
Old 02-21-2019, 03:29 AM   #5
Minty
AWF VIP
 
Minty's Avatar
 
Join Date: Jul 2013
Location: UK - Wiltshire
Posts: 6,437
Thanks: 166
Thanked 1,738 Times in 1,707 Posts
Minty is a jewel in the rough Minty is a jewel in the rough Minty is a jewel in the rough
Re: Outlook VBA code to save email in the shared drive

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
__________________
If we have helped please add to our reputation - click the scales symbol on the left, tick 'I approve' and leave a comment.

To view links or images in signatures your post count must be 10 or greater. You currently have 0 posts.


To view links or images in signatures your post count must be 10 or greater. You currently have 0 posts.
Minty is offline   Reply With Quote
Old 02-21-2019, 03:32 AM   #6
Gasman
Enthusiastic Amateur
 
Gasman's Avatar
 
Join Date: Sep 2011
Location: Swansea, South Wales,UK
Posts: 4,507
Thanks: 439
Thanked 838 Times in 809 Posts
Gasman is a jewel in the rough Gasman is a jewel in the rough Gasman is a jewel in the rough
Re: Outlook VBA code to save email in the shared drive

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
Code:
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
__________________
Access novice. Sometimes trying to give something back.
Access 2007

Please, please use code tag # when posting code snippets

To view links or images in signatures your post count must be 10 or greater. You currently have 0 posts.


To view links or images in signatures your post count must be 10 or greater. You currently have 0 posts.


To view links or images in signatures your post count must be 10 or greater. You currently have 0 posts.
Gasman is offline   Reply With Quote
Old 02-21-2019, 03:33 AM   #7
aman
Newly Registered User
 
Join Date: Oct 2008
Posts: 1,250
Thanks: 54
Thanked 3 Times in 2 Posts
aman is an unknown quantity at this point
Re: Outlook VBA code to save email in the shared drive

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??

aman is offline   Reply With Quote
Old 02-21-2019, 03:56 AM   #8
Gasman
Enthusiastic Amateur
 
Gasman's Avatar
 
Join Date: Sep 2011
Location: Swansea, South Wales,UK
Posts: 4,507
Thanks: 439
Thanked 838 Times in 809 Posts
Gasman is a jewel in the rough Gasman is a jewel in the rough Gasman is a jewel in the rough
Re: Outlook VBA code to save email in the shared drive

Have you tried SaveAs instead of GetSaveAsFilename ?
__________________
Access novice. Sometimes trying to give something back.
Access 2007

Please, please use code tag # when posting code snippets

To view links or images in signatures your post count must be 10 or greater. You currently have 0 posts.


To view links or images in signatures your post count must be 10 or greater. You currently have 0 posts.


To view links or images in signatures your post count must be 10 or greater. You currently have 0 posts.
Gasman is offline   Reply With Quote
Old 02-21-2019, 05:19 AM   #9
aman
Newly Registered User
 
Join Date: Oct 2008
Posts: 1,250
Thanks: 54
Thanked 3 Times in 2 Posts
aman is an unknown quantity at this point
Re: Outlook VBA code to save email in the shared drive

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

Code:
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
aman is offline   Reply With Quote
Old 02-21-2019, 05:40 AM   #10
Gasman
Enthusiastic Amateur
 
Gasman's Avatar
 
Join Date: Sep 2011
Location: Swansea, South Wales,UK
Posts: 4,507
Thanks: 439
Thanked 838 Times in 809 Posts
Gasman is a jewel in the rough Gasman is a jewel in the rough Gasman is a jewel in the rough
Re: Outlook VBA code to save email in the shared drive

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.
__________________
Access novice. Sometimes trying to give something back.
Access 2007

Please, please use code tag # when posting code snippets

To view links or images in signatures your post count must be 10 or greater. You currently have 0 posts.


To view links or images in signatures your post count must be 10 or greater. You currently have 0 posts.


To view links or images in signatures your post count must be 10 or greater. You currently have 0 posts.
Gasman is offline   Reply With Quote
Old 02-22-2019, 02:54 AM   #11
aman
Newly Registered User
 
Join Date: Oct 2008
Posts: 1,250
Thanks: 54
Thanked 3 Times in 2 Posts
aman is an unknown quantity at this point
Re: Outlook VBA code to save email in the shared drive

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
aman is offline   Reply With Quote
Old 02-22-2019, 03:19 AM   #12
Gasman
Enthusiastic Amateur
 
Gasman's Avatar
 
Join Date: Sep 2011
Location: Swansea, South Wales,UK
Posts: 4,507
Thanks: 439
Thanked 838 Times in 809 Posts
Gasman is a jewel in the rough Gasman is a jewel in the rough Gasman is a jewel in the rough
Re: Outlook VBA code to save email in the shared drive

Try

Code:
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
__________________
Access novice. Sometimes trying to give something back.
Access 2007

Please, please use code tag # when posting code snippets

To view links or images in signatures your post count must be 10 or greater. You currently have 0 posts.


To view links or images in signatures your post count must be 10 or greater. You currently have 0 posts.


To view links or images in signatures your post count must be 10 or greater. You currently have 0 posts.
Gasman is offline   Reply With Quote
Old 02-22-2019, 05:14 AM   #13
aman
Newly Registered User
 
Join Date: Oct 2008
Posts: 1,250
Thanks: 54
Thanked 3 Times in 2 Posts
aman is an unknown quantity at this point
Re: Outlook VBA code to save email in the shared drive

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 .

Last edited by aman; 02-22-2019 at 05:21 AM.
aman is offline   Reply With Quote
Old 02-26-2019, 01:27 AM   #14
aman
Newly Registered User
 
Join Date: Oct 2008
Posts: 1,250
Thanks: 54
Thanked 3 Times in 2 Posts
aman is an unknown quantity at this point
Re: Outlook VBA code to save email in the shared drive

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 is offline   Reply With Quote
Old 02-26-2019, 04:56 AM   #15
aman
Newly Registered User
 
Join Date: Oct 2008
Posts: 1,250
Thanks: 54
Thanked 3 Times in 2 Posts
aman is an unknown quantity at this point
Re: Outlook VBA code to save email in the shared drive

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.

aman is offline   Reply With Quote
Reply

Thread Tools
Display Modes Rate This Thread
Rate This Thread:

Forum Jump

Similar Threads
Thread Thread Starter Forum Replies Last Post
database on shared drive dwaynebickford General 5 12-06-2017 08:33 AM
Can I use my shared drive speakers_86 General 5 10-24-2015 07:58 AM
Code to allow saving of Outlook attachment to local drive? dwcolt Modules & VBA 0 12-14-2013 02:04 PM
Save Outlook Email as link in Access tbl TallMan Modules & VBA 2 06-26-2013 10:46 AM
Shared Drive mapat General 4 10-23-2007 12:08 PM




All times are GMT -8. The time now is 03:40 AM.


Microsoft Access Help
General
Tables
Queries
Forms
Reports
Macros
Modules & VBA
Theory & Practice
Access FAQs
Code Repository
Sample Databases
Video Tutorials

Featured Forum post


Sponsored Links


Powered by vBulletin®
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.
(c) copyright 2017 Access World