Dim WdApp As Object 'Word.ApplicationDim doc As Object 'Word.DocumentDim t
'主程序Public Sub MergeToWord() Application.Calculation = xlCalculationManual Application.ScreenUpdating = False '打开Word Set WdApp = Nothing Set doc = Nothing On Error Resume Next Set WdApp = GetObject(, "Word.Application") If Err <> 0 Then MsgBox "检查你的Word文档是否已打开" Exit Sub End If '获取当前文档 Set doc = WdApp.ActiveDocument If Err <> 0 Then MsgBox "错误地连接当前Word文档: " & Err.Message Exit Sub End If On Error GoTo 0 '查找Word中所有相关书签并进行处理 ReDim B(WdApp.ActiveDocument.bookmarks.Count) As Object Dim i As Long '在数组中存储标签, 然后逐个处理 '当发生粘贴时Word会销毁书签 '下面的代码重新创建书签 For i = 1 To WdApp.ActiveDocument.bookmarks.Count Set B(i) = WdApp.ActiveDocument.bookmarks(i) Next i
For i = 1 To UBound(B) If InStr(1, B(i).Name, "tag_", vbTextCompare) = 1 Then PasteToWord B(i) End If Next i '激活Word以方便用户检查结果 WdApp.Activate Set WdApp = Nothing Application.StatusBar = False t = Timer - tEnd Sub
'处理Word书签Private Sub PasteToWord(B As Object, Optional Method As String = "Metafile") 'tag As String On Error Resume Next Dim strTag As String Dim tag As String tag = B.Name strTag = Mid$(B.Name, 5) If Err <> 0 Then Exit Sub On Error GoTo 0 '选择书签区域 B.Range.Select '标记书签开始 Dim rngMark As Object Set rngMark = WdApp.Selection.Range 'b.Range.Text = vbNullString 'b.Range.Delete '基于书签名选择是否粘贴表或图表 If InStr(tag, "tag_tbl") > 0 Then rngMark.Collapse 1 PasteTableToWord B ElseIf InStr(tag, "tag_cht") > 0 Then 'b.Range.Text = vbNullString 'rngMark.Collapse 1 B.Range.Delete 'b.Range.Select CopyChartToWord B, rngMark, Method rngMark.End = WdApp.Selection.End WdApp.ActiveDocument.bookmarks.Add tag, rngMark ElseIf InStr(tag, "tag_txt") > 0 Then rngMark.Collapse 1 PasteTextToWord B ElseIf InStr(tag, "tag_pic") > 0 Then rngMark.Collapse 1 PastePicToWord B Else Exit Sub End If If InStr(tag, "tag_cht") = 0 Then '标记粘贴的末尾 rngMark.End = WdApp.Selection.End '再添加书签 WdApp.ActiveDocument.bookmarks.Add tag, rngMark End IfCleanup: Application.CutCopyMode = False Application.StatusBar = FalseEnd Sub
'粘贴文本Private Sub PasteTextToWord(B As Object) Dim strTag As String On Error Resume Next strTag = Mid$(B.Name, 5) If Err <> 0 Then Exit Sub On Error GoTo 0 Dim txtTag As String Dim u As Long txtTag = strTag On Error Resume Next Range(txtTag).Copy If Err = 0 Then If InStr(1, txtTag, "txt", vbTextCompare) > 0 Then With WdApp.Selection .Select .ClearContents .PasteAndFormat (22) End With Else With WdApp.Selection .Select .ClearContents WdApp.Selection.PasteAndFormat(22) End With End If Else WdApp.ActiveDocument.Selection = "***没有发现 ***" End If On Error GoTo 0End Sub
Private Sub PastePicToWord(B As Object) Dim strTag As String On Error Resume Next strTag = Mid$(B.Name, 5) If Err <> 0 Then Exit Sub On Error GoTo 0 Dim txtTag As String Dim u As Long txtTag = strTag Dim w As Worksheet, pic As Picture For Each w In ActiveWorkbook.Sheets Set pic = w.Pictures(strTag) If Not pic Is Nothing Then Exit For Next w If pic Is Nothing Then Exit Sub On Error Resume Next pic.Copy If Err = 0 Then WdApp.Selection.Paste 'SpecialLink:=False, DataType:=8, Placement:=0 End If On Error GoTo 0End Sub
'Private Sub PasteTableToWord(B As Object) Dim strTag As String On Error Resume Next strTag = Mid$(B.Name, 5) If Err <> 0 Then Exit Sub On Error GoTo 0 Dim tblTag As String Dim u As Long tblTag = strTag On Error Resume Next Range(tblTag).Copy If Err = 0 Then If InStr(1, tblTag, "tbl", vbTextCompare) > 0 Then With WdApp.Selection .Tables(1).Select .Tables(1).Delete .PasteSpecial DataType:=1, Placement:=0 '.PasteAndFormat (0) '默认粘贴 End With Else With WdApp.Selection .Tables(1).Select .Tables(1).Delete WdApp.Selection.PasteAndFormat(22) End With End If Else WdApp.ActiveDocument.Selection = "*** 没有发现 ***" End If On Error GoTo 0End Sub
'粘贴图表Private Sub CopyChartToWord(B As Object, rngMark, Optional Method As String = "Metafile") On Error Resume Next Dim strTag As String strTag = Mid$(B.Name, 5) If Err <> 0 Then Exit Sub On Error GoTo 0
Dim w As Worksheet, cht As ChartObject For Each w In ActiveWorkbook.Sheets Set cht = w.ChartObjects(strTag) If Not cht Is Nothing Then Exit For Next w If cht Is Nothing Then Exit Sub On Error Resume Next cht.Copy If Err = 0 Then Select Case Method Case "Metafile" rngMark.PasteSpecial DataType:=3, Placement:=0 Case "Enhanced metafile" WdApp.Selection.PasteSpecial DataType:=9, Placement:=0 Case "Bitmap" WdApp.Selection.PasteSpecial DataType:=4, Placement:=0 Case "Drawing" WdApp.Selection.PasteSpecial link:=False, DataType:=8, Placement:=0 Case "JPG" Dim fName As String fName = ThisWorkbook.Path & "\tmp.jpg" cht.Chart.Export fName, "JPG" WdApp.Selection.InlineShapes.AddPicture Filename:=fName, LinkToFile:=False, SaveWithDocument:=True Kill fName End Select Else WdApp.ActiveDocument.Selection.Text = "*** 没有发现 ***" End If On Error GoTo 0End Sub
