ThrottleWorks
Excel Ninja
Hi,
This code seems to be working for me. Still lot of editing is required. But I guess this will work.
Thanks for the help.
This code seems to be working for me. Still lot of editing is required. But I guess this will work.
Thanks for the help.
Code:
Option Explicit
'https://stackoverflow.com/questions/51655911/export-outlook-email-as-pdf
Sub Test_1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.StatusBar = "Please wait, macro in progess !"
Dim MyOutlook As Outlook.Application
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim FSO As Object, TmpFolder As Object
Dim sName As String
Dim ONS As Outlook.Namespace
Dim MYFOLD As Outlook.Folder
Dim OMAIL As Object
Dim R As Long
Dim ListSht As Worksheet
Dim WshShell As Object
Dim SpecialPath As String
Dim strToSaveAs As String
Dim J As Variant
Dim TmpFileName As Variant
Dim MyDocs As Variant
Dim MapSht As Worksheet
Dim TempLr As Long
Set MapSht = ThisWorkbook.Worksheets("Mapping")
On Error Resume Next
Set wrdApp = CreateObject("Word.Application")
Set MyOutlook = New Outlook.Application
Set ONS = MyOutlook.GetNamespace("MAPI")
Set ONS = MyOutlook.PickFolder
Set MYFOLD = ONS.PickFolder
Set OMAIL = MyOutlook.CreateItem(olMailItem)
Set ListSht = ThisWorkbook.Worksheets("List")
Dim MyCount As Long
MyCount = 0
'
Dim objMail As Outlook.MailItem
Dim strFileName As String
Dim strWordDocument As String
Dim objWordApp As Word.Application
Dim objWordDocument As Word.Document
Dim objDocumentRange As Word.Range
'
For Each OMAIL In MYFOLD.Items
TempLr = MapSht.Cells(MapSht.Rows.Count, 3).End(xlUp).Row + 1
MapSht.Cells(TempLr, 3).Value = TempLr - 1
MapSht.Cells(TempLr, 4).Value = OMAIL.Subject
MapSht.Cells(TempLr, 5) = OMAIL.ConversationID 'E Conversation ID
MapSht.Cells(TempLr, 6) = OMAIL.ConversationTopic 'F Conversation Topic
MapSht.Cells(TempLr, 7) = OMAIL.ReceivedTime 'G Received Time
MapSht.Cells(TempLr, 8) = OMAIL.To 'H To
MapSht.Cells(TempLr, 9) = OMAIL.Sender 'I From
MapSht.Cells(TempLr, 10) = Now 'J Run time
MyCount = MyCount + 1
On Error Resume Next
Set objMail = OMAIL
strFileName = Replace(objMail.Subject, "/", " ")
strFileName = Replace(strFileName, "\", " ")
strFileName = Replace(strFileName, ":", "")
strFileName = Replace(strFileName, "?", " ")
strFileName = Replace(strFileName, Chr(34), " ")
strWordDocument = Environ("Temp") & "\" & strFileName & "_" & MyCount & ".doc"
objMail.SaveAs strWordDocument, olDoc
Set objWordApp = CreateObject("Word.Application")
Set objWordDocument = objWordApp.Documents.Open(strWordDocument)
objWordApp.Visible = True
If objWordApp.Selection.PageSetup.Orientation = wdOrientPortrait Then
objWordApp.Selection.PageSetup.Orientation = wdOrientLandscape
End If
Dim MyFileName As String
MyFileName = "H:\Sachin Sonawane\IIS Paper Saving Project\Save Emails here\"
MyFileName = MyFileName & Left(OMAIL.Subject, 30) & "_" & MyCount & ".doc"
MapSht.Cells(TempLr, 11) = MyFileName 'K
objWordApp.ActiveDocument.SaveAs Filename:=MyFileName
objWordApp.Quit
Next OMAIL
MyCount = 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.StatusBar = False
MsgBox "Done!"
End Sub
Sub Test_2()
Dim wordFile As Object
Dim MyString As String
Dim wordDoc As Variant
Dim MapSht As Worksheet
Set MapSht = ThisWorkbook.Worksheets("Mapping")
MyString = MapSht.Range("K2")
Set wordFile = CreateObject("Word.Application")
Set wordDoc = wordFile.Documents.Open(MyString)
wordDoc.ExportAsFixedFormat Left(wordDoc.FullName, InStrRev(wordDoc.FullName, ".") - 1), 17
wordDoc.Close
wordFile.Quit
End Sub
