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
将Outlook Email转换为JPG图片(代码功能只能转当前第一页,待优化)
猜你喜欢
转载自blog.csdn.net/zhui454990390/article/details/84330635
今日推荐
周排行