如何使用Excel VBA将当前工作表存为PDF并通过Outlook发送邮件

核心修改逻辑 #

• 删除原代码中调用文件夹选择弹窗的FileDialog相关代码段，取消手动选择保存位置的交互
• 通过VBA内置的Environ("TEMP")接口直接读取系统临时文件夹路径，自动拼接生成PDF的完整存储路径
• 适配临时文件使用场景，默认自动覆盖临时目录下的同名文件，也可自行恢复覆盖确认逻辑

修改后完整代码 #

Sub Saveaspdfandsend()
    Dim xSht As Worksheet
    Dim xFolder As String
    Dim xOutlookObj As Object
    Dim xEmailObj As Object
    Dim xUsedRng As Range
 
    Set xSht = ActiveSheet
    ' 直接获取系统临时文件夹路径，拼接PDF文件名
    xFolder = Environ("TEMP") & "\" & xSht.Name & ".pdf"
 
    ' 自动覆盖已存在的同名临时文件，若需要保留提示可恢复原代码的覆盖确认逻辑
    On Error Resume Next
    Kill xFolder
    On Error GoTo 0
    If Err.Number <> 0 Then
        MsgBox "无法删除已有临时文件，请确认文件未被打开或无写入权限。" & vbCrLf & vbCrLf & "按OK退出宏。", vbCritical, "删除文件失败"
        Exit Sub
    End If
 
    Set xUsedRng = xSht.UsedRange
    If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
        ' 保存为PDF文件到临时目录
        xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
     
        ' 创建Outlook邮件
        Set xOutlookObj = CreateObject("Outlook.Application")
        Set xEmailObj = xOutlookObj.CreateItem(0)
        With xEmailObj
            .Display
            .To = ""
            .CC = ""
            .Subject = xSht.Name & ".pdf"
            .Attachments.Add xFolder
            ' 若需要自动发送邮件，取消下一行的注释即可
            '.Send
        End With
    Else
      MsgBox "当前活动工作表不能为空"
      Exit Sub
    End If
End Sub

可选调整说明 #

• 如果需要保留原有的同名文件覆盖提示，把原代码中的覆盖确认弹窗代码段加回即可
• 如果需要修改邮件的默认收件人、抄送、正文内容，直接在With xEmailObj代码块中添加对应的配置项即可，比如添加.Body = "这是自动发送的PDF附件"即可设置默认邮件正文

内容的提问来源于stack exchange，提问作者stuntmanmike.84