抱歉,如果标题令人困惑。我正在尝试执行一个多应用程序子程序,最终将通过电子邮件发送 PDF 附件。该过程首先从 CSV 中提取信息(我已经这样做了),然后使用该信息填充 PowerPoint 中预先存在的幻灯片(也这样做了)。下一步是我无法弄清楚的。可以通过 PowerPoint 创建讲义,但我只知道如何设置对话框,而不知道如何完成该过程。
PowerPointApp.CommandBars.ExecuteMso ("CreateHandoutsInWord") 将打开对话框,但仅此而已。我已经成功使用 SendKeys 执行了其余操作,但在移交给 Word 时总是失败。在代码中放入 Waits 也无济于事。我现在正在研究一种替代方法,但很好奇是否有人知道如何完成这个过程。
Sub CreateHandoutsForWord()
Dim mailSht As Worksheet
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim sl As Object
Dim myShape As Object
Dim impStr As String
Dim implStr() As String
Dim wordPath As String
Dim fso As New FileSystemObject
Dim fo As Folder
Dim f As File
Dim wordApp As New Word.Application
Dim wordDoc As Word.Document
Set mailSht = Worksheets("Mailer")
impStr = OpenCSV
implStr() = Split(impStr, " ")
Set fo = fso.GetFolder(mailSht.Range("E5").Value)
Set f = fo.Files("Mailer.pptx")
On Error Resume Next
Set PowerPointApp = GetObject(Class:="PowerPoint.Application")
Err.Clear
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(Class:="PowerPoint.Application")
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
Application.ScreenUpdating = False
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Open(f.Path)
Set sl = myPresentation.Slides(1)
sl.Shapes.Range(Array(2, 1)).Item(1).TextFrame.TextRange.Text = "Scott Corwin"
sl.Shapes.Range(Array(3, 1)).Item(1).TextFrame.TextRange.Text = "Guest Speaker"
PowerPointApp.CommandBars.ExecuteMso ("CreateHandoutsInWord")
Application.Wait Now + 0.00003
PowerPointApp.Activate
SendKeys "{DOWN}", True
Application.Wait Now + 0.00001
PowerPointApp.Activate
SendKeys "{DOWN}", True
Application.Wait Now + 0.00001
PowerPointApp.Activate
SendKeys "~", True
Application.Wait Now + 0.0003
PowerPointApp.Activate
myPresentation.Close
PowerPointApp.Quit
Application.Wait Now + 0.0006
Set wordApp = GetObject(Class:="Word.Application")
此时,应用程序会停止运行,并反复显示应用程序不可用的错误。一旦我弄清楚了这一点,我就会拥有可以创建 PDF 并通过 Outlook 发送电子邮件的工作代码。