使用 Excel VBA 创建 Word 文档 - 插入图像？从 3rd Doc 复制和粘贴文本

Question

我正在尝试在 excel 中编写一些 VBA 代码来自动构建 100 多个 .pdf word 文档的任务，每个文档都遵循设置的模板。我最初从 youtube tutorial 复制了一段代码，展示了如何从电子表格构建自动电子邮件，我觉得我的应用程序足够相似。

我可以按应有的方式进行文本替换。我的主要问题是将图像插入需要的位置。我尝试使用书签并替换代码，但没有成功。我认为我的问题在于我的变量在各个子项之间没有正确的值，尽管这只是我没有受过教育的最佳猜测。

我的下一个问题是创建代码以从现有文档中提取文本并粘贴到新文档中。老实说，我一直被图像问题所困扰，甚至还没有研究过。

我可能会以一种低效的方式完成这项任务，但是，如果有人能够发现我的代码中的错误，我将不胜感激。我在下面粘贴了我现有的代码。希望不会太糟糕。

    Option Explicit

   Dim CustRow, CustCol, LastRow, TemplRow, j  As Long
   Dim DocLoc, TagName, TagValue, TemplName, FileName As String
   Dim CurDt, LastAppDt As Date
   Dim WordDoc, WordApp As Object
   Dim WordContent As Word.Range

Sub CreateWordDocuments()

With Sheet1

  If .Range("B3").Value = Empty Then
    MsgBox "Please select a correct template from the drop down list"
    .Range("G3").Select
    Exit Sub
  End If
    TemplRow = .Range("B3").Value 'Set Template Row
    TemplName = .Range("G3").Value 'Set Template Name
    DocLoc = Sheet2.Range("F" & TemplRow).Value 'Word Document Filename

    'Open Word Template
    On Error Resume Next 'If Word is already running
    Set WordApp = GetObject("Word.Application")
        If Err.Number <> 0 Then
        'Launch a new instance of Word
        Err.Clear
        'On Error GoTo Error_Handler
        Set WordApp = CreateObject("Word.Application")
        WordApp.Visible = True 'Make the application visible to the user
        End If


    LastRow = .Range("E9999").End(xlUp).Row  'Determine Last Row in Table
        For CustRow = 8 To LastRow
                                Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open Template
                                For CustCol = 5 To 10 'Move Through 6 Columns
                                    TagName = .Cells(7, CustCol).Value 'Tag Name
                                    TagValue = .Cells(CustRow, CustCol).Value 'Tag Value
                                     With WordDoc.Content.Find
                                        .Text = TagName
                                        .Replacement.Text = TagValue
                                        .Wrap = wdFindContinue
                                        .Execute Replace:=wdReplaceAll 'Find & Replace all instances
                                     End With
                                 Next CustCol

         Call InsertScreenshots

    If .Range("I3").Value = "PDF" Then
                                          FileName = ThisWorkbook.Path & "\" & .Range("E" & CustRow).Value & "_" & .Range("G" & CustRow).Value & ".pdf" 'Create full filename & Path with current workbook location, Category_Model
                                          WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
                                          WordDoc.Close False
                                      Else: 'If Word
                                          FileName = ThisWorkbook.Path & "\" & .Range("E" & CustRow).Value & "_" & .Range("G" & CustRow).Value & ".docx"
                                          WordDoc.SaveAs FileName
                                   End If
                                      .Range("O" & CustRow).Value = TemplName 'Template Name
                                      .Range("P" & CustRow).Value = Now
     Next CustRow


End With


End Sub


 Sub FillABookmark(bookmarkname As String, imagepath As String)

   Dim objWord As Object
    Dim objDoc As Object
    With Sheet1

    On Error Resume Next
    Set objWord = GetObject(, "Word.Application")
    If objWord Is Nothing Then
        Set objWord = CreateObject("Word.Application")
        objWord.Visible = True
        objWord.Documents.Open "DocLoc"
    End If

    Set objDoc = objWord.ActiveDocument

    With objDoc
        .Bookmarks(bookmarkname).Select
        .Shapes.AddPicture FileName:=imagepath
    End With
End With
End Sub

Sub InsertScreenshots()
    With Sheet1
        For CustCol = 11 To 14 'Move Through 4 Columns
            TagName = .Cells(7, CustCol).Value 'Tag Name
            TagValue = .Cells(CustRow, CustCol).Value 'Tag Value
                    Call FillABookmark("TagName", "TagValue")
         Next CustCol
    End With

End Sub

Answer 1

这里发生了很多事情，也有很多问题。

关键点

1. 了解正确缩进的价值
2. Dim 所有变量，否则为Variants
3. 早期绑定更容易调试。使用显式类型而不是 Object
4. 除非有充分的理由，否则不要使用模块范围的变量
5. 代码名很有用​​，但要给它们起有意义的名字
6. Empty 的正确测试是 IsEmpty
7. GetObject ClassID 是 2nd 参数。我需要使用Word.Application.16，您的安装可能会有所不同
8. 使用On Error Resume Next 后尽快重置错误处理（这可能是对您隐藏错误）
9. 使用EndUp查找最后使用的行时，从工作表底部开始搜索
10. 简化了InsertScreenshots 代码的调用
11. 您已经有一个 Word 应用并打开了文档，请不要再次打开它
12. 简化图片插入，避免使用Select

注意：如果没有工作簿示例和 word 文档，我无法确定没有其他问题，您需要继续调试。

查看带有 ~~ 标记的更改的内联 cmets

重构代码

Option Explicit

Sub CreateWordDocuments()
    '~~ Don't use module scoped variables
    '~~ declare all variable types, else they are Variants
    Dim CustRow As Long, CustCol As Long, LastRow As Long, TemplRow As Long, j As Long 
    Dim DocLoc As String, TagName As String, TagValue As String, TemplName As String, FileName As String
    Dim CurDt As Date, LastAppDt As Date
        '~~ to make debugging easier, use Early Binding (add reference to Microsoft Word), to get Intellisence help.  If you need late binding, change back later
    Dim WordDoc As Word.Document, WordApp As Word.Application    '  Object
    Dim WordContent As Word.Range '~~ this suggests you are already using Early Binding!

    With Sheet1 '~~ If you are going to use CodeNames, give the sheet a meaningful name (edit it in the Properties window)
        If IsEmpty(.Range("B3").Value) Then  '~~ correct test for Empty
            MsgBox "Please select a correct template from the drop down list"
            .Range("G3").Select '~~ will only work if Sheet1 is active
            Exit Sub
        End If
        TemplRow = .Range("B3").Value 'Set Template Row
        TemplName = .Range("G3").Value 'Set Template Name
        DocLoc = Sheet2.Range("F" & TemplRow).Value 'Word Document Filename

        'Open Word Template
        On Error Resume Next 'If Word is already running
        Set WordApp = GetObject(, "Word.Application.16") '~~ correct format for Office365 - YMMV
        If Err.Number <> 0 Then
            Err.Clear
            On Error GoTo 0 '~~ reset error handling
            'Launch a new instance of Word
            Set WordApp = New Word.Application ' CreateObject("Word.Application")
            WordApp.Visible = True 'Make the application visible to the user
        End If
        On Error GoTo 0 '~~ reset error handling
        WordApp.Visible = True
        LastRow = .Cells(.Rows.Count, 5).End(xlUp).Row '~~ use real last row  'Determine Last Row in Table
        For CustRow = 8 To LastRow
            Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open Template
            For CustCol = 5 To 10 'Move Through 6 Columns
                TagName = .Cells(7, CustCol).Value 'Tag Name
                TagValue = .Cells(CustRow, CustCol).Value 'Tag Value
                With WordDoc.Content.Find
                   .Text = TagName
                   .Replacement.Text = TagValue
                   .Wrap = wdFindContinue
                   .Execute Replace:=wdReplaceAll 'Find & Replace all instances
                End With
            Next CustCol
            For CustCol = 11 To 14 'Move Through 4 Columns  ~~ do it here, it's cleaner and easier to reference the Row
                TagName = .Cells(7, CustCol).Value '~~ Bookmark Name
                TagValue = .Cells(CustRow, CustCol).Value '~~ Image path and name
                FillABookmark TagName, TagValue, WordDoc '~~ call to insert each image
            Next

            If .Range("I3").Value = "PDF" Then
                FileName = ThisWorkbook.Path & "\" & .Range("E" & CustRow).Value & "_" & .Range("G" & CustRow).Value & ".pdf" 'Create full filename & Path with current workbook location, Category_Model
                WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
                WordDoc.Close False
            Else '~~ don't need the : 
                FileName = ThisWorkbook.Path & "\" & .Range("E" & CustRow).Value & "_" & .Range("G" & CustRow).Value & ".docx"
                WordDoc.SaveAs FileName
            End If
            .Range("O" & CustRow).Value = TemplName 'Template Name
            .Range("P" & CustRow).Value = Now
         Next CustRow
    End With
End Sub


Sub FillABookmark(bookmarkname As String, imagepath As String, objDoc As Word.Document)
    '~~ Use passed Parameter for Doc
    '~~ Don't need select
    objDoc.Bookmarks(bookmarkname).Range _
        .InlineShapes.AddPicture FileName:=imagepath
End Sub