请高手们修改代码，如何对指定文章进行搜索？

sz114

以下这段代码已经很棒了，我希望能都在代码里面加上一段代码（对指定的文本进行操作），这段代码该怎么写？请高手们帮忙！！！
例如：运行《例句提取》，然后指定文件《原文》（希望高手加上这段代码），再指定《list》进行单词提取
请高手打开附件，找到这些文件。

万分感谢


Sub test()
    Dim a As String
    Dim fs, f
    Dim findtext() As String, temp As String
    Dim i As Integer, n As Integer, c As Long, info As String

    a = InputBox("请输入每个单词所需要的例句数。其中：" & vbCrLf & vbCrLf & _
        "0　全部列出（默认）" & vbCrLf & "-1 指定一个单词搜索", , 0)
    If a = "" Then Exit Sub
    If a = "-1" Then
        ReDim findtext(0)
        findtext(0) = InputBox("请输入要查的单词", , "Number")
    Else
        Set fs = CreateObject("Scripting.FileSystemObject")
        With Application.FileDialog(msoFileDialogFilePicker)
            .Title = "请指定单词列表文本文件"
            .InitialFileName = ActiveDocument.Path
            .AllowMultiSelect = False
            If .Show <> -1 Then Exit Sub
            Set f = fs.OpenTextFile(.SelectedItems(1))
            findtext() = Split(f.ReadAll, vbCrLf)
            f.Close
            Set fs = Nothing
        End With
    End If

    With ActiveDocument.Content.Find
        For i = 0 To UBound(findtext)
            .MatchAllWordForms = IIf(findtext(i) Like "*[!A-Za-z]*", False, True)
            info = info & vbCrLf & findtext(i) & vbCrLf
            .Text = findtext(i)
            Do While .Execute
                n = n + 1
                c = c + 1
                If Val(a) > 0 And n > Val(a) Then Exit Do
                With .Parent
                    .Expand wdSentence
                    temp = .Text
                    If Right(temp, 1) <> Chr(13) Then temp = temp & vbCrLf
                    If Val(a) = 1 Then
                        If InStr(info, vbCrLf & temp) = 0 Then
                            info = info & temp
                        Else
                            info = Replace(info, vbCrLf & findtext(i) & vbCrLf, "")
                            info = Replace(info, vbCrLf & temp, "|" & findtext(i) & vbCrLf & temp)
                            c = c - 1
                        End If
                        Exit Do
                    Else
                        If InStr(info, vbTab & temp) > 0 Then temp = "*" & temp '用星号标记重复的例句
                        info = info & n & vbTab & temp
                    End If
                    .Collapse wdCollapseEnd
                End With
            Loop
            n = 0
            .Parent.WholeStory
        Next
    End With

    info = "共搜索到" & c & "条。" & vbCrLf & info
    If a = "-1" Then
        info = "指定单词搜索：" & findtext(0) & vbCrLf & info
    Else
        info = "指定每个单词所需例句的搜索上限数：" & IIf(Val(a) = 0, "全部", a) & vbCrLf & info
    End If
    Documents.Add.Content.Text = info
End Sub

zhanglei1371

看代码风格像是sylun的吧？
稍作修改，如下【还可进一步完善。懒得继续搞了，浪费时间】

Sub test1()
    Dim a As String
    Dim fs, f
    Dim findtext() As String, temp As String
    Dim i As Integer, n As Integer, c As Long, info As String
    a = InputBox("请输入每个单词所需要的例句数。其中：" & vbCrLf & vbCrLf & _
                 "0　全部列出（默认）" & vbCrLf & "-1 指定一个单词搜索", , 0)
    If a = "" Then Exit Sub
    If a = "-1" Then
        ReDim findtext(0)
        findtext(0) = InputBox("请输入要查的单词", , "Number")
    Else
        Set fs = CreateObject("Scripting.FileSystemObject")
        With Application.FileDialog(msoFileDialogFilePicker)
            .Title = "请指定单词列表文本文件"
            .InitialFileName = ActiveDocument.Path
            .AllowMultiSelect = False
            .Filters.Clear
            .Filters.Add "文本文档", "*.txt", 1
            If .Show <> -1 Then Exit Sub
            Set f = fs.OpenTextFile(.SelectedItems(1))
            findtext() = Split(f.ReadAll, vbCrLf)
            f.Close
            Set fs = Nothing
        End With
    End If
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .InitialFileName = ActiveDocument.Path
        .Filters.Clear
        .Filters.Add "word文档", "*.doc;*.docx", 1
        .Title = "请选取要锁定的目标文件..."
        If .Show <> -1 Then
            tf = 1
            MsgBox "未选择文件，将对当前文件进行操作！"
            GoTo aa:
        End If
        For Each f In .SelectedItems
            With Documents.Open(f)
aa:
                With ActiveDocument.Content.Find
                    For i = 0 To UBound(findtext)
                        .MatchAllWordForms = IIf(findtext(i) Like "*[!A-Za-z]*", False, True)
                        info = info & vbCrLf & findtext(i) & vbCrLf
                        .Text = findtext(i)
                        Do While .Execute
                            n = n + 1
                            c = c + 1
                            If Val(a) > 0 And n > Val(a) Then Exit Do
                            With .Parent
                                .Expand wdSentence
                                temp = .Text
                                If Right(temp, 1) <> Chr(13) Then temp = temp & vbCrLf
                                If Val(a) = 1 Then
                                    If InStr(info, vbCrLf & temp) = 0 Then
                                        info = info & temp
                                    Else
                                        info = Replace(info, vbCrLf & findtext(i) & vbCrLf, "")
                                        info = Replace(info, vbCrLf & temp, "|" & findtext(i) & vbCrLf & temp)
                                        c = c - 1
                                    End If
                                    Exit Do
                                Else
                                    If InStr(info, vbTab & temp) > 0 Then temp = "*" & temp    '用星号标记重复的例句
                                    info = info & n & vbTab & temp
                                End If
                                .Collapse wdCollapseEnd
                            End With
                        Loop
                        n = 0
                        .Parent.WholeStory
                    Next
                End With
                If tf = 1 Then GoTo bb:
            End With
            Documents(f).Close False
        Next
    End With
bb:
    info = "共搜索到" & c & "条。" & vbCrLf & info
    If a = "-1" Then
        info = "指定单词搜索：" & findtext(0) & vbCrLf & info
    Else
        info = "指定每个单词所需例句的搜索上限数：" & IIf(Val(a) = 0, "全部", a) & vbCrLf & info
    End If
    Documents.Add.Content.Text = info
    MsgBox "OK ,搞定！"
End Sub

sz114

zhanglei1371 发表于 2014-12-22 22:40
看代码风格像是sylun的吧？
稍作修改，如下【还可进一步完善。懒得继续搞了，浪费时间】

谢谢您修改的代码，我试用了一下，很好用。
（我把目标文件的格式改成了txt格式，请用我提供的附件试验一下）
但有2个问题，希望继续得到您的帮助。

1、在最终输出文件中有很多空行（或者说是空白，后面有附图），网上查了一下，好像是前面那个按钮框引起的，不知道该如何避免？

2、我希望最后输出的结果文件为pdf格式，希望您修改一下。

这个修改对您来说可能是简单了些，但对我来说却帮我解决了很大的问题，深深感谢您的帮助。

sz114

zhanglei1371

记得下次提问问题一次说清楚，我懒得反复回答一个问题。
代码如下

1. Sub test1()
   
2.     Dim a As String
   
3.     Dim fs, f
   
4.     Dim findtext() As String, temp As String
   
5.     Dim i As Integer, n As Integer, c As Long, info As String
   
6.     a = InputBox("请输入每个单词所需要的例句数。其中：" & vbCrLf & vbCrLf & _
   
7.                  "0　全部列出（默认）" & vbCrLf & "-1 指定一个单词搜索", , 0)
   
8.     If a = "" Then Exit Sub
   
9.     If a = "-1" Then
   
10.         ReDim findtext(0)
    
11.         findtext(0) = InputBox("请输入要查的单词", , "Number")
    
12.     Else
    
13.         Set fs = CreateObject("Scripting.FileSystemObject")
    
14.         With Application.FileDialog(msoFileDialogFilePicker)
    
15.             .Title = "请指定单词列表文本文件"
    
16.             .InitialFileName = ActiveDocument.Path
    
17.             .AllowMultiSelect = False
    
18.             .Filters.Clear
    
19.             .Filters.Add "文本文档", "*.txt", 1
    
20.             If .Show <> -1 Then Exit Sub
    
21.             Set f = fs.OpenTextFile(.SelectedItems(1))
    
22.             findtext() = Split(f.ReadAll, vbCrLf)
    
23.             f.Close
    
24.             Set fs = Nothing
    
25.         End With
    
26.     End If
    
27.     With Application.FileDialog(msoFileDialogFilePicker)
    
28.         .AllowMultiSelect = True
    
29.         .InitialFileName = ActiveDocument.Path
    
30.         .Filters.Clear
    
31.         .Filters.Add "文本文档", "*.txt", 1
    
32.         .Title = "请选取要锁定的目标文件..."
    
33.         If .Show <> -1 Then
    
34.             tf = 1
    
35.             MsgBox "未选择文件，将对当前文件进行操作！"
    
36.             GoTo aa:
    
37.         End If
    
38.         For Each f In .SelectedItems
    
39.             With Documents.Open(f)
    
40. aa:
    
41.                 With ActiveDocument.Content.Find
    
42.                     For i = 0 To UBound(findtext)
    
43.                         .MatchAllWordForms = IIf(findtext(i) Like "*[!A-Za-z]*", False, True)
    
44.                         info = info & vbCrLf & findtext(i) & vbCrLf
    
45.                         .Text = findtext(i)
    
46.                         Do While .Execute
    
47.                             n = n + 1
    
48.                             c = c + 1
    
49.                             If Val(a) > 0 And n > Val(a) Then Exit Do
    
50.                             With .Parent
    
51.                                 .Expand wdSentence
    
52.                                 temp = .Text
    
53.                                 If Right(temp, 1) <> Chr(13) Then temp = temp & vbCrLf
    
54.                                 If Val(a) = 1 Then
    
55.                                     If InStr(info, vbCrLf & temp) = 0 Then
    
56.                                         info = info & temp
    
57.                                     Else
    
58.                                         info = Replace(info, vbCrLf & findtext(i) & vbCrLf, "")
    
59.                                         info = Replace(info, vbCrLf & temp, "|" & findtext(i) & vbCrLf & temp)
    
60.                                         c = c - 1
    
61.                                     End If
    
62.                                     Exit Do
    
63.                                 Else
    
64.                                     If InStr(info, vbTab & temp) > 0 Then temp = "*" & temp    '用星号标记重复的例句
    
65.                                     info = info & n & vbTab & temp
    
66.                                 End If
    
67.                                 .Collapse wdCollapseEnd
    
68.                             End With
    
69.                         Loop
    
70.                         n = 0
    
71.                         .Parent.WholeStory
    
72.                     Next
    
73.                 End With
    
74.                 If tf = 1 Then GoTo bb:
    
75.             End With
    
76.             Documents(f).Close False
    
77.         Next
    
78.     End With
    
79. bb:
    
80.     info = "共搜索到" & c & "条。" & vbCrLf & info
    
81.     If a = "-1" Then
    
82.         info = "指定单词搜索：" & findtext(0) & vbCrLf & info
    
83.     Else
    
84.         info = "指定每个单词所需例句的搜索上限数：" & IIf(Val(a) = 0, "全部", a) & vbCrLf & info
    
85.     End If
    
86.     With Documents.Add
    
87.         .Content.Text = info
    
88.         .Content.Find.Execute "^12", , , 1, , , , , , "", 2  '去除分页符
    
89.          .Content.Find.Execute "^13^13", , , 1, , , , , , "^p", 2  '去除全部空行
    
90.          .Content.Find.Execute "^13^13", , , 1, , , , , , "^p", 2  '去除全部空行
    
91.         .SaveAs2 "c:\abc.pdf", wdFormatPDF
    
92.         .Close False
    
93.     End With
    
94.     MsgBox "OK ,已生成C:\abc.pdf,路径名称可自己修改！"
    
95. End Sub
    
96. 
    
97. Private Sub CommandButton1_Click()
    
98. Call test1
    
99. End Sub
    
100. 
     

复制代码

sz114

谢谢zhanglei1371：

代码经测试：发现错误，用调试功能发现是存储pdf时发生的故障。

我调整了路径还是报错？

请您看看~~~~~

sz114

经网上查询，在出错的代码前加了一个单词解决了，ActiveDocument.
估计是命令不完整导致的？

目前运行很正常，正是我想要的效果。

非常感谢您的帮助，这个小程序对我的学习有很大帮助，祝您每天开心，万事如意。