使用新文件名将 Word Doc 转换为 PDF 并附加到新电子邮件

问题描述

我正在尝试将文档以 PDF 格式添加到电子邮件中。我正在尝试更改文件名以包含存储在 Word 文档表中的日期。

我可以创建电子邮件，但脚本在尝试导出时出现错误。

如何将文件附加为 PDF 文件，文件名带有从 Word 表格中提取的日期？

Sub CommandButton1_Click()
Dim OL              As Object
Dim EmailItem       As Object
Dim Doc             As Document

Dim DateField       As String
Dim desktoploc      As String
Dim mypath          As String


Application.ScreenUpdating = False
Set OL = CreateObject("outlook.application")
Set EmailItem = OL.CreateItem(olMailItem)
Set Doc = ActiveDocument
Doc.Save


'Pull date from table and change format
DateField = Format(Doc.Content.Tables(1).Cell(1,4).Range.Text,"yyyymmdd")

'Pull line number and subject names from table 1 and table 2 in word to add to subject.
Dim linenum As Word.Range,subject1 As Word.Range,subjec2 As Word.Range

'Need to remove hidden line breaks from tables in word in order to fit on subject line of email
Set linenum = Doc.Content.Tables(1).Cell(1,2).Range
linenum.MoveEnd unit:=wdCharacter,Count:=-1
Set subject1 = Doc.Content.Tables(2).Cell(2,1).Range
subject1.MoveEnd unit:=wdCharacter,Count:=-1
Set subjec2 = Doc.Content.Tables(2).Cell(3,1).Range
subjec2.MoveEnd unit:=wdCharacter,Count:=-1

'Create PDF File
Dim file_name       As String
Dim NewFileName     As String

NewFileName = "Load Limits Subjects " & linenum & " " & DateField

file_name = ActiveDocument.Path & "\" & Left(ActiveDocument.Name,InStrRev(ActiveDocument.Name,".") - 1) & NewFileName & ".pdf"

'This is where I keep getting the error.....

ActiveDocument.ExportAsFixedFormat OutputFileName:=file_name,_
    ExportFormat:=wdExportFormatPDF,OpenAfterExport:=False,Optimizefor:= _
    wdExportOptimizeforPrint,Range:=wdExportAllDocument,Item:= _
    wdExportDocumentContent,IncludeDocProps:=False,KeepIRM:=True,_
    CreateBookmarks:=wdExportCreateNoBookmarks,DocStructureTags:=True,_
    BitmapMissingFonts:=True,UseISO19005_1:=False

   
With EmailItem
    .display
    .Subject = "Limit Notification - Subject " & linenum & " #line #" & linenum & _
    " #" & subject1.Text & " #" & subjec2.Text & vbCrLf
    .Body = "Please see the attached Limit Notification for Subject " & linenum.Text & vbCrLf & _
    "" & vbCrLf & _
    "Let me kNow if you have any questions." & vbCrLf & _
    "" & vbCrLf & _
    "Thank you," & vbCrLf & vbCrLf & _
    "INSERT SIGNATURE HERE"
    
'Update Recipient List here:
    .To = "LineEmail@email.com; "
    .CC = "Another Email@demail.com"
    '.Importance = olImportancenormal
    
    .Attachments.Add Doc.FullName
End With

End Sub

解决方法

您的代码有多个缺陷，包括：

您的 DateField 字符串正在尝试将包含表格单元格的单元格结束标记的内容转换为 ISO 格式的日期
您的代码未将 NewFileName 字符串验证为文件名。
您的代码正在尝试将文档附加到电子邮件中，而不是 pdf。
在为新文件名创建路径等时，您的代码正在引用 ActiveDocument（可能不再与 Doc 相同）。

尝试以下方法：

Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim OL              As Object
Dim EmailItem       As Object
Dim Doc             As Document
Dim Rng             As Range
Dim i               As Long
Dim NewFileName     As String
Dim MailSubject     As String
Dim MailBody        As String
Const StrNoChr      As String = """*./\:?|"
NewFileName = " Load Limits Subjects "
MailSubject = "Limit Notification - Subject "
MailBody = "Please see the attached Limit Notification for Subject "

Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)

Set Doc = ActiveDocument
With Doc
  .Save
  Set Rng = .Tables(1).Cell(1,2).Range
  Rng.End = Rng.End - 1
  NewFileName = NewFileName & Rng.Text & " "
  MailSubject = MailSubject & Rng.Text & " #line #" & Rng.Text & " #"
  MailBody = MailBody & Rng.Text
  Set Rng = .Tables(1).Cell(1,4).Range
  Rng.End = Rng.End - 1
  NewFileName = NewFileName & Format(Rng.Text,"YYYYMMDD")
  Set Rng = .Tables(2).Cell(2,1).Range
  Rng.End = Rng.End - 1
  MailSubject = MailSubject & Rng.Text
  Set Rng = .Tables(2).Cell(3,1).Range
  Rng.End = Rng.End - 1
  MailSubject = MailSubject & Rng.Text
  For i = 1 To Len(StrNoChr)
    NewFileName = Replace(NewFileName,Mid(StrNoChr,i,1),"_")
  Next
  NewFileName = Split(.FullName,".doc")(0) & NewFileName & ".pdf"
  SaveAs2 FileName:=NewFileName,FileFormat:=wdFormatPDF,AddToRecentFiles:=False
End With


MailBody = MailBody & vbCrLf & _
  "" & vbCrLf & _
  "Let me know if you have any questions." & vbCrLf & _
  "" & vbCrLf & _
  "Thank you," & vbCrLf & vbCrLf & _
  "INSERT SIGNATURE HERE"

With EmailItem
    .Display
    .Subject = MailSubject
    .Body = MailBody
    
'Update Recipient List here:
    .To = "LineEmail@email.com; "
    .CC = "Another Email@demail.com"
    '.Importance = olImportanceNormal
    
    .Attachments.Add NewFileName
End With
End Sub

filenames ms-word