将创建的电子邮件另存为.msg

Question

我每天都有代码。它将选项卡转换为pdf，创建附有创建的pdf的电子邮件，并从范围中获取主题名称。

例如，如果该范围包含四个传递引用，则代码将创建四封附加了相同 pdf 的电子邮件。

我想将这些创建的电子邮件作为.msg保存到Windows文件夹中。

我尝试了保存方法。

Sub Oval2_Click()
Dim IsCreated As Boolean
Dim i As Long
Dim PdfFile As String, Title As String
Dim OutlApp As Object
Dim sPath As String
Dim sName As String
Dim rng As Range, c As Range
Set rng = Range("B10:B14")
For Each c In rng.Cells
If c <> "" Then '----------------------------------
Title = c
PdfFile = ActiveWorkbook.FullName
i = InStrRev(PdfFile, ".")
If i > 1 Then PdfFile = Left(PdfFile, i - 1)
PdfFile = PdfFile & "_" & "Information" & ".pdf"
With ActiveWorkbook.Worksheets("Information")
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
With OutlApp.CreateItem(0)
.Subject = Title
.To = ""
.CC = ""
.Attachments.Add PdfFile
On Error Resume Next
.Display
sPath = "Any folder"
sPath = sPath & m.Subject
sPath = sPath & ".msg"
OutlApp.SaveAs sPath
Application.Visible = True
On Error GoTo 0
End With
'Kill PdfFile
'If IsCreated Then OutlApp.Quit
Set OutlApp = Nothing
End If '---------------------------------
Next c
End Sub

Answer 1

VBA 编码的成功率随着Option Explicit的使用而增加，并将On Error Resume Next的使用限制在极少数情况下。

Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
Sub Oval2_Click()
Dim IsCreated As Boolean
Dim i As Long
Dim pdfFile As String
Dim Title As String
Dim OutlApp As Object
Dim sPath As String
Dim sName As String
Dim rng As Range
Dim c As Range
' Rare appropriate use of On Error Resume Next
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
' restore normal error handling 
On Error GoTo 0
pdfFile = ActiveWorkbook.FullName
Debug.Print pdfFile
i = InStrRev(pdfFile, ".")
If i > 1 Then
pdfFile = Left(pdfFile, i - 1)
Debug.Print pdfFile
End If
pdfFile = pdfFile & "_" & "Information" & ".pdf"
Debug.Print pdfFile
With ActiveWorkbook.Worksheets("Information")
.ExportAsFixedFormat Type:=xlTypePDF, fileName:=pdfFile, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
Set rng = Range("B10:B14")
For Each c In rng.Cells
If c <> "" Then '----------------------------------
Title = c
With OutlApp.CreateItem(0)
.Subject = Title
.To = ""
.CC = ""
.Attachments.Add pdfFile
' Inappropriate "On Error Resume Next" removed
.Display
sPath = "Any folder"
'sPath = "C:UsersusernameTest"
Debug.Print sPath
If Right(sPath, 1) <> "" Then
sPath = sPath & ""
Debug.Print sPath
End If
' error would be bypassed due to poor error handling
' would have been caught by Option Explicit
'sPath = sPath & m.Subject
sPath = sPath & .Subject
Debug.Print sPath
sPath = sPath & ".msg"
Debug.Print sPath
' error would be bypassed due to poor error handling
'OutlApp.SaveAs sPath
.SaveAs sPath
End With
End If '---------------------------------
Next c
'Kill pdfFile
'If IsCreated Then OutlApp.Quit
Set OutlApp = Nothing
Debug.Print "Done."
End Sub