如何修改代码，做到将关键字所在段落提取到新文档时保持原有格式

tangqingfu · 发表于 2019-6-1 09:18

本帖最后由 tangqingfu 于 2019-6-1 09:54 编辑

以下是杜老师帮忙编写的代码（将关键字所在的段落提取到新文档中），可惜无法做到保持原有格式（颜色），请教如何修改代码做到提取后保留原有格式（如字体，颜色等）？

Sub main()
Dim doc As Document, re As Object, mh As Object
Dim mystr$, keystr$, restr$, results$, i&, n&
If Selection.Type = wdSelectionIP Then
MsgBox "没选择关键字！": Exit Sub
Else
keystr = Selection.Text '选择文档中某一处“关键字”
End If
For i = 1 To Len(keystr)
restr = restr & "\u" & Right("0000" & Hex$(AscW(Mid(keystr, i, 1))), 4)
Next
Set doc = ActiveDocument
mystr = doc.Content.Text
Set re = CreateObject("vbscript.regexp")
re.Global = True: re.Pattern = restr
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")
For Each mh In re.Execute(mystr)
i = mh.FirstIndex: n = mh.Length
With doc.Range(i, i + n)
.Expand 4
d(.Text) = vbNullString
End With
Next
For Each k In d.keys
results = results & k
Next
With Documents.Add
.Content.InsertAfter results
End With
End Sub

复制代码

小花鹿 · 发表于 2019-6-1 09:49

上个帖子中不是已经做过相关的讨论了吗，有附件才好写代码
Sub test()
Dim mydoc As Document, p As Range
Set mydoc = Documents.Add
With ThisDocument.Content.Find
      .ClearFormatting
      .Font.Color = wdColorGreen
      Do While .Execute
         Set p = .Parent.Paragraphs(1).Range.FormattedText
         With mydoc.Range
            .Collapse wdCollapseEnd
            .FormattedText = p
         End With
         .Parent.Move 4
      Loop
End With
End Sub

tangqingfu · 发表于 2019-6-1 09:52

小花鹿发表于 2019-6-1 09:49
上个帖子中不是已经做过相关的讨论了吗，有附件才好写代码
Sub test()
Dim mydoc As Document, p As ...

竟忘了发附件了，请兄台指点

小花鹿 · 发表于 2019-6-1 11:10

tangqingfu 发表于 2019-6-1 09:52
竟忘了发附件了，请兄台指点

Sub test()
Dim mydoc As Document, p As Range, s
If Selection.Type = wdSelectionIP Then
      MsgBox "没选择关键字！": Exit Sub
Else
      s = Selection.Text
End If
Set mydoc = Documents.Add
With ThisDocument.Content.Find
      .ClearFormatting
      .Text = s
      Do While .Execute
         Set p = .Parent.Paragraphs(1).Range.FormattedText
         With mydoc.Range
            .Collapse wdCollapseEnd
            .FormattedText = p
         End With
         .Parent.Move 4
      Loop
End With
End Sub

tangqingfu · 发表于 2019-6-1 14:22

本帖最后由 tangqingfu 于 2019-6-1 15:35 编辑

小花鹿发表于 2019-6-1 11:10
Sub test()
Dim mydoc As Document, p As Range, s
If Selection.Type = wdSelectionIP Then

Sub test()
Dim mydoc As Document, p As Range, s
If Selection.Type = wdSelectionIP Then
MsgBox "没选择关键字！": Exit Sub
Else
s = Selection.Text
End If
Set mydoc = Documents.Add
With ActiveDocument.Content.Find
.ClearFormatting
.Text = s
Do While .Execute
Set p = .Parent.Paragraphs(1).Range.FormattedText
With mydoc.Range
.Collapse wdCollapseEnd
.FormattedText = p
End With
.Parent.Move 4
Loop
End With
End Sub

复制代码

把ThisDocument改为ActiveDocument
并把代码置于文档模板，并复制到Word 2016的STARTUP文件夹下，在测试中发现提取到新文档时，新文档内容为空，能否请兄台帮忙解决？

小花鹿 · 发表于 2019-6-1 18:50

本帖最后由小花鹿于 2019-6-1 18:55 编辑

tangqingfu 发表于 2019-6-1 14:22
把ThisDocument改为ActiveDocument
并把代码置于文档模板，并复制到Word 2016的STARTUP文件夹下，在测试 ...

Sub 音标分类()
Dim mydoc As Document, p As Range, s, thisdoc As Document
If Selection.Type = wdSelectionIP Then
      MsgBox "您未选择关键字，请选择关键字后再运行程序！": Exit Sub
Else
      s = Selection.Text
End If
Set thisdoc = ActiveDocument
Set mydoc = Documents.Add
With thisdoc.Content.Find
      .ClearFormatting
      .Text = s
      Do While .Execute
         Set p = .Parent.Paragraphs(1).Range.FormattedText
         With mydoc.Range
            .Collapse wdCollapseEnd
            .FormattedText = p
         End With
         .Parent.Move 4
      Loop
End With
End Sub

tangqingfu · 发表于 2019-6-1 21:00

小花鹿发表于 2019-6-1 18:50
Sub 音标分类()
Dim mydoc As Document, p As Range, s, thisdoc As Document
If Selection.Typ ...

测试很完美，谢谢小花鹿兄的一再帮助！

413191246se · 发表于 2019-6-2 01:59

谢谢小花鹿老师！又学到一个“属性”（.FormattedText保持格式文本，但它返回 .Range 对象）。
同时也学到了 .Move 4（4 为 Unit:=wdParagraph 的值）这个“属性”（光标向前一个段落）。

tangqingfu · 发表于 2021-5-13 08:12

小花鹿发表于 2019-6-1 18:50
Sub 音标分类()
Dim mydoc As Document, p As Range, s, thisdoc As Document
If Selection.Typ ...

能否请老师帮忙解决这个帖子的问题？
http://club.excelhome.net/thread-1584723-1-1.html

		自动登录	找回密码
密码			免费注册

[求助] 如何修改代码，做到将关键字所在段落提取到新文档时保持原有格式

评分

评分