Question

我下面有我每天都使用的代码。基本上，它将选项卡转换为pdf，创建带有已创建pdf附件的电子邮件，并从范围中获取主题名称。例如，如果该范围包含4个交货参考，则代码将创建4个电子邮件，并附加相同的pdf。完美的作品。

我想要实现的是，我想将这些创建的电子邮件另存为msg到Windows文件夹中。我没有运气尝试了SaveAs方法。有人可以建议吗？

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

使用Option Explicit并限制使用On Error Resume Next来限制VBA编码成功的机会很少。

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:\Users\username\Test\"

            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

将创建的电子邮件复制到文件夹

1 个答案: