將Outlook Email轉換為JPG圖片(程式碼功能只能轉當前第一頁,待優化)
阿新 • • 發佈:2018-11-23
Sub ExportEmailAsImage() 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 Dim objPowerPointApp As PowerPoint.Application Dim objPresentation As PowerPoint.Presentation Dim objShape As PowerPoint.Shape On Error Resume Next 'Export the email as Word document Set objMail = Outlook.Application.ActiveExplorer.Selection(1) strFileName = Replace(objMail.Subject, "/", " ") strFileName = Replace(strFileName, "\", " ") strFileName = Replace(strFileName, ":", "") strFileName = Replace(strFileName, "?", " ") strFileName = Replace(strFileName, Chr(34), " ") strWordDocument = Environ("Temp") & "\" & strFileName & ".doc" objMail.SaveAs strWordDocument, olDoc Set objWordApp = CreateObject("Word.Application") Set objWordDocument = objWordApp.Documents.Open(strWordDocument) objWordApp.Visible = True objWordApp.Selection.Find.ClearFormatting objWordApp.Selection.Find.Replacement.ClearFormatting With objWordApp.Selection.Find .Text = "^p^p" .Replacement.Text = "^p" .Wrap = wdFindContinue End With 'Insert the document into a PowerPoint Presentation slide as an object objWordApp.Selection.Find.Execute Replace:=wdReplaceAll Set objDocumentRange = objWordDocument.Range() objDocumentRange.Font.Name = "Calibri" objDocumentRange.Font.Size = 10 objWordDocument.Close True objWordApp.Quit Set objPowerPointApp = CreateObject("PowerPoint.Application") Set objPresentation = objPowerPointApp.Presentations.Add objPowerPointApp.Visible = msoTrue With objPresentation .PageSetup.SlideHeight = 792 .PageSetup.SlideWidth = 612 .Slides.AddSlide 1, .SlideMaster.CustomLayouts(1) End With 'Export the slide With objPresentation.Slides(1) Set objShape = .Shapes.AddOLEObject(0, 0, 612, 792, , strWordDocument) .Export "E:\Email_" & strFileName & ".jpg", "JPG" End With objPresentation.Saved = msoTrue objPresentation.Close objPowerPointApp.Quit End Sub