尝试使用 VBA 将 Excel 中的图片粘贴到 Word 后创建封闭书签 [英] Trying to create an enclosing bookmark after pasting a picture from Excel into Word using VBA

问题描述

我在互联网、这个论坛和许多其他论坛上四处寻找，似乎找不到我认为比现在简单得多的答案.

I've been looking around a lot on internet, on this forum and so many others and can't seem to find my answer which I thought would be much more simple than it is currently.

我正在编写代码来自动化一份报告，我们在 excel 中拥有大部分数据.我的代码相对简单:获取这几个单元格中的文本，获取这些图形，复制这些表格并将所有这些粘贴到特定书签(作为图形和表格的图像).

I am writing a code to automatize a report that we have most data in excel. My code is relatively simple : Take the text in those few cells, take those graphs, copy those tables and paste all of those to specific bookmarks (as image for graphs and tables).

到目前为止，这一步是完美的.我尝试了多种编码方式，主要是通过循环，但使用书签非常具有挑战性且不是非常灵活，因此代码只是一组重复的步骤，编写非常简单.我刚刚在做跨办公室应用宏，尤其是 word 中首次亮相.我的代码完全按照上面提到的去做，直到我必须第二次运行它.目标是，如果我再次运行宏，它会再次运行并替换最初粘贴的文本、图像和表格.

So far, this step is going perfect. I've tried multiple ways of coding it, mostly through loops but working with bookmarks as been very challenging and not super flexible so the code is just a repetitive set of steps, very simply written. I'm just debuting in doing inter-office apps macros, especially word. My code does exactly what is mentioned above, until I have to run it a second time. The goal is that if I run again the macro, it will run again and replace the texts, images and the tables that were initially pasted.

代码如下:

Sub IMPORT_TO_WORD()

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim msWord As Object

'Set worksheets
Set ws1 = ThisWorkbook.Worksheets("Tableaux")
Set ws2 = ThisWorkbook.Worksheets("Graph")
Set ws3 = ThisWorkbook.Worksheets("REFERENCE MACRO")
Set ws4 = ThisWorkbook.Worksheets("Tableaux2")


     
    Filename = ws4.Range("B3")
       
   'Open word / check if it's open
    On Error Resume Next
    Set msWord = GetObject(class:="Word.Application")
    Err.Clear
    If msWord Is Nothing Then Set msWord = CreateObject(class:="Word.Application")
    
        
    With msWord
        .Visible = True
        .Documents.Open (Filename)
        .Activate
        Application.Wait Now + #12:00:03 AM#
        


'If ws4.Range("F1") = "English" Then
On Error GoTo 0

'Set the BookMarks range
    Set BMSALES = .ActiveDocument.Bookmarks(1).Range
    Set BMSALES2 = .ActiveDocument.Bookmarks(2).Range
    Set BMLISTINGS = .ActiveDocument.Bookmarks(3).Range
    Set BMLISTINGS2 = .ActiveDocument.Bookmarks(4).Range
    Set BMMEDPRICE = .ActiveDocument.Bookmarks(5).Range
    Set BMMEDPRICE2 = .ActiveDocument.Bookmarks(6).Range
    Set BMEVO = .ActiveDocument.Bookmarks(7).Range
    Set BMEVO2 = .ActiveDocument.Bookmarks(8).Range
    Set BMMKTCOND = .ActiveDocument.Bookmarks(9).Range
    Set BMGraph1 = .ActiveDocument.Bookmarks(10).Range
    Set BMGraph2 = .ActiveDocument.Bookmarks(11).Range
    Set BMGraph3 = .ActiveDocument.Bookmarks(12).Range
    Set BMGraph4 = .ActiveDocument.Bookmarks(13).Range
    Set BMGraph5 = .ActiveDocument.Bookmarks(14).Range
    Set BMTABLE1 = .ActiveDocument.Bookmarks(15).Range
    Set BMTABLE2 = .ActiveDocument.Bookmarks(16).Range
    Set BMTABLE3 = .ActiveDocument.Bookmarks(17).Range
    Set BMTABLE4 = .ActiveDocument.Bookmarks(18).Range
 
'Insert text
    BMSALES.Text = ws3.Range("B1")
    BMSALES2.Text = ws3.Range("B2")
    BMLISTINGS.Text = ws3.Range("B3")
    BMLISTINGS2.Text = ws3.Range("B4")
    BMMEDPRICE.Text = ws3.Range("B5")
    BMMEDPRICE2.Text = ws3.Range("B6")
    BMEVO.Text = ws3.Range("B7")
    BMEVO2.Text = ws3.Range("B8")
    BMMKTCOND.Text = ws3.Range("B9")

'Insert Graphs
            ws2.ChartObjects(5).Copy
            Application.Wait Now + #12:00:01 AM#
            BMGraph1.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, Placement:=wdInLine, DisplayAsIcon:=False
            
            ws2.ChartObjects(1).Copy
            Application.Wait Now + #12:00:01 AM#
            BMGraph5.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, Placement:=wdInLine, DisplayAsIcon:=False
            
            ws2.ChartObjects(2).Copy
            Application.Wait Now + #12:00:01 AM#
            BMGraph4.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, Placement:=wdInLine, DisplayAsIcon:=False
            
            ws2.ChartObjects(3).Copy
            Application.Wait Now + #12:00:01 AM#
            BMGraph3.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, Placement:=wdInLine, DisplayAsIcon:=False

            ws2.ChartObjects(4).Copy
            Application.Wait Now + #12:00:01 AM#
            BMGraph2.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, Placement:=wdInLine, DisplayAsIcon:=False

'Insert tables           
            ws1.Range("D3:P11").Copy
            Application.Wait Now + #12:00:01 AM#
            BMTABLE1.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, Placement:=wdInLine, DisplayAsIcon:=False
            
            ws1.Range("D22:P30").Copy
            Application.Wait Now + #12:00:01 AM#
            BMTABLE2.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, DisplayAsIcon:=False, Placement:=wdInLine
            
            ws1.Range("D41:P49").Copy
            Application.Wait Now + #12:00:01 AM#
            BMTABLE3.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, DisplayAsIcon:=False, Placement:=wdInLine
            
            ws1.Range("D60:P68").Copy
            Application.Wait Now + #12:00:01 AM#
            BMTABLE4.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, DisplayAsIcon:=False, Placement:=wdInLine
            
            Application.CutCopyMode = False
            
   'Put the bookmark back in the word doc to be able to use the macro again         
    ActiveDocument.Bookmarks.Add Name:="ASales", Range:=BMSALES
    ActiveDocument.Bookmarks.Add Name:="ASales2", Range:=BMSALES2
    ActiveDocument.Bookmarks.Add Name:="BLISTINGS", Range:=BMLISTINGS
    ActiveDocument.Bookmarks.Add Name:="BLISTINGS2", Range:=BMLISTINGS2
    ActiveDocument.Bookmarks.Add Name:="CMEDPRICE", Range:=BMMEDPRICE
    ActiveDocument.Bookmarks.Add Name:="CMEDPRICE2", Range:=BMMEDPRICE2
    ActiveDocument.Bookmarks.Add Name:="EVO1", Range:=BMEVO
    ActiveDocument.Bookmarks.Add Name:="EVO2", Range:=BMEVO2
    ActiveDocument.Bookmarks.Add Name:="FMKTCOND", Range:=BMMKTCOND
    ActiveDocument.Bookmarks.Add Name:="GRAPH1", Range:=BMGraph1
    ActiveDocument.Bookmarks.Add Name:="GRAPH2", Range:=BMGraph2
    ActiveDocument.Bookmarks.Add Name:="GRAPH3", Range:=BMGraph3
    ActiveDocument.Bookmarks.Add Name:="GRAPH4", Range:=BMGraph4
    ActiveDocument.Bookmarks.Add Name:="GRAPH5", Range:=BMGraph5
    ActiveDocument.Bookmarks.Add Name:="TABLE1", Range:=BMTABLE1
    ActiveDocument.Bookmarks.Add Name:="TABLE2", Range:=BMTABLE2
    ActiveDocument.Bookmarks.Add Name:="TABLE3", Range:=BMTABLE3
    ActiveDocument.Bookmarks.Add Name:="TABLE4", Range:=BMTABLE4
     
End With
End Sub

对于文本来说，它创造了奇迹，因为创建的书签仍然是一个封闭的书签.由于创建的书签成为占位符书签，而不是包含图片，因此图像变得复杂，因此当我再次使用宏时，图像会加起来并且不会替换它.

For the text, it works wonders, as the bookmark that is created stays an enclosing bookmark. It gets complicated for the image as the bookmark that is created becomes a placeholder bookmark, not enclosing the pictures so when I use the macro again the images add up and don't replace it.

我尝试了不同的方法，但找不到任何东西.我觉得我最接近的是这个:

I've tried different ways of doing it and can't find anything. The closest I feel I was was with this :

ActiveDocument.Bookmarks.Add Name:="GRAPH1", Range:=BMGraph1
BMGraph1.Select
ActiveDocument.Selection.Move Unit:=wdCharacter, Count:=1
ActiveDocument.Bookmarks.Add , Range:=Selection.Range

这样我们就可以选择新放置的占位符，将所选内容移动一个字符(我也尝试了 Selection.MoveRight)，以便选择图像，然后重新插入书签并确保它被封闭，然后宏可以运行结束.

So that we select the newly placed placeholder, move the selection one character (I tried Selection.MoveRight as well) so that the image is selected and then reinsert the bookmark and ensure it's enclosing and then the macro could be run over and over.

但由于某种原因，我得到一个对象不支持此属性或方法 vba"；Selection.Move 中的错误，我无法理解，因为它绝对是 Selection 支持的方法.

But for some reason I get a "object doesn't support this property or method vba" error at the Selection.Move which I have trouble understanding since it definitely a supported method for Selection.

我在网上寻找了很多不同的解决方案，这也是我获得最后一段代码(根据我的情况进行调整)但找不到任何适合这种特定情况的方法.

I've looked online for so many different solutions, which is also how I got the last piece of code (adjusted to my situation) but can't find anything that is fitting this specific situation.

我也无法调整粘贴图像的大小，因为我很难找到正确的对象或方法.一旦我能够正确地拥有封闭书签，就计划在上述书签中使用 InLineShapes.

I also haven't been able to resize my pasted image as I have lot of trouble finding the correct object or method to do so. Planning on using InLineShapes in said bookmarks once I am able to correctly have enclosing bookmarks.

所以我在这里寻求你的帮助.

So I'm out here, asking for your help.

提前谢谢各位！

推荐答案

也许:

Sub IMPORT_TO_WORD()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim ObjWd As Object, ObjDoc As Object
Dim r As Long, ArrTxtBkMk(), ArrImgBkMk(), ArrImgSrc(), ArrTblBkMk(), ArrTblSrc()
'Set worksheets
With ThisWorkbook
  Set ws1 = .Worksheets("Tableaux")
  Set ws2 = .Worksheets("Graph")
  Set ws3 = .Worksheets("REFERENCE MACRO")
  Set ws4 = .Worksheets("Tableaux2")
End With
       
'Open word / check if it's open
On Error Resume Next
Set ObjWd = GetObject(class:="Word.Application")
Err.Clear
If ObjWd Is Nothing Then
  Set ObjWd = CreateObject(class:="Word.Application")
End If
On Error GoTo 0
ArrTxtBkMk = Array(, "ASales", "ASales2", "BLISTINGS", "BLISTINGS2", _
            "CMEDPRICE", "CMEDPRICE2", "EVO1", "EVO2", "FMKTCOND")
ArrImgBkMk = Array("GRAPH1", "GRAPH2", "GRAPH3", "GRAPH4", "GRAPH5")
ArrImgSrc = Array(5, 1, 2, 3, 4)
ArrTblBkMk = Array("TABLE1", "TABLE2", "TABLE3", "TABLE4")
ArrTblSrc = Array("D3:P11", "D22:P30", "D41:P49", "D60:P68")

With ObjWd
  .Visible = True
  Set ObjDoc = .Documents.Open(ws4.Range("B3"))
  'Update Text bookmark ranges
  For r = 1 To UBound(ArrTxtBkMk)
    Call UpdateTextBookmark(ObjDoc, "" & ArrTxtBkMk(r) & "", ws3.Range("B" & r))
  Next
  'Update Image bookmark ranges
  For r = 0 To UBound(ArrImgBkMk)
    ws2.ChartObjects(ArrImgSrc(r)).Copy
    Call UpdateImageBookmark(ObjDoc, "" & ArrImgBkMk(r) & "")
  Next
  'Update table bookmark ranges
  For r = 0 To UBound(ArrTblBkMk)
    ws1.Range("" & ArrTblSrc(r) & "").Copy
    Call UpdateImageBookmark(ObjDoc, "" & ArrTblBkMk(r) & "")
  Next
End With
Application.CutCopyMode = False
End Sub

Sub UpdateTextBookmark(ObjDoc As Object, StrBkMk As String, StrTxt As String)
Dim ObjRng As Object
With ObjDoc
  If .Bookmarks.Exists(StrBkMk) Then
    Set ObjRng = .Bookmarks(StrBkMk).Range
    ObjRng.Text = StrTxt
    .Bookmarks.Add StrBkMk, ObjRng
  Else
    MsgBox StrBkMk & " bookmark NOT found!", vbExclamation
  End If
End With
Set ObjRng = Nothing
End Sub

Sub UpdateImageBookmark(ObjDoc As Object, StrBkMk As String)
Dim ObjRng As Object
With ObjDoc
  If .Bookmarks.Exists(StrBkMk) Then
    Set ObjRng = .Bookmarks(StrBkMk).Range
    With ObjRng
      .Range.Text = vbNullString
      .PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
        Placement:=wdInLine, DisplayAsIcon:=False
      .End = .End + 1
    End With
    .Bookmarks.Add StrBkMk, ObjRng
  Else
    MsgBox StrBkMk & " bookmark NOT found!", vbExclamation
  End If
End With
Set ObjRng = Nothing
End Sub

这篇关于尝试使用 VBA 将 Excel 中的图片粘贴到 Word 后创建封闭书签的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！