Word简易查找替换器

kingtau

Private Type CHOOSECOLOR 'http://www.exceltip.net/thread-5644-1-1.html
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As Long
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As Long
End Type
Private Type RGBColor
    R As Byte
    G As Byte
    B As Byte
    space As Byte  '用作间隔
End Type
Private Declare Function ChooseColorA Lib "Comdlg32" (pChoosecolor As CHOOSECOLOR) As Long
Dim CustColors(1 To 16) As RGBColor



Sub 批量文件多个关键词替换()
Dim arr(), brr(), ra As Range
Dim ta As Table
    Set ta = ActiveDocument.Tables(1)
    i = 0
    For R = 2 To ta.Rows.Count
        If Replace(Replace(ta.Cell(R, 1).Range.Text, Chr(13), ""), Chr(7), "") = "" Then Exit For
        ReDim Preserve arr(i)
        ReDim Preserve brr(i)
        arr(i) = Replace(Replace(ta.Cell(R, 1).Range.Text, Chr(13), ""), Chr(7), "")
        brr(i) = Replace(Replace(ta.Cell(R, 2).Range.Text, Chr(13), ""), Chr(7), "")
        i = i + 1
    Next
    If ActiveDocument.InlineShapes(3).OLEFormat.Object = True Then
        tf1 = 1
    Else
        tf1 = 0
    End If
    If ActiveDocument.InlineShapes(4).OLEFormat.Object = True Then
        tf2 = 1
    Else
        tf2 = 0
    End If
    With Application.FileDialog(msoFileDialogFilePicker)
        If .Show <> -1 Then Exit Sub
        For Each f In .SelectedItems
            处理文档 f, arr, brr, tf1, tf2
        Next
    End With
    MsgBox "恭喜，已完成！"
End Sub
Sub 文件夹下word文档替换()
On Error GoTo ext:
Dim arr(), brr(), ra As Range
Dim ta As Table
    Set ta = ActiveDocument.Tables(1)
    i = 0
    For R = 2 To ta.Rows.Count
        If Replace(Replace(ta.Cell(R, 1).Range.Text, Chr(13), ""), Chr(7), "") = "" Then Exit For
        ReDim Preserve arr(i)
        ReDim Preserve brr(i)
        arr(i) = Replace(Replace(ta.Cell(R, 1).Range.Text, Chr(13), ""), Chr(7), "")
        brr(i) = Replace(Replace(ta.Cell(R, 2).Range.Text, Chr(13), ""), Chr(7), "")
        i = i + 1
    Next
    If ActiveDocument.InlineShapes(3).OLEFormat.Object = True Then
        tf1 = 1
    Else
        tf1 = 0
    End If
    If ActiveDocument.InlineShapes(4).OLEFormat.Object = True Then
        tf2 = 1
    Else
        tf2 = 0
    End If
    For Each f In DIR数组遍历

            处理文档 f, arr, brr, tf1, tf2

    Next
    MsgBox "恭喜，已完成！"
ext:

End Sub
Sub t()
For Each ra In ActiveDocument.StoryRanges
                If Len(Trim(ra)) > 2 Then
                    '                    ra.Find.Execute arr(i), , , tf1, , , , , , brr(i), 2
                    Do While ra.Find.Execute(5, , , 0)

                        ra.Find.Parent.Select
                        ra.Find.Execute 5, , , 0, , , , , , 1, 1
                        ra.Find.Parent.Font.Color = Label1.ForeColor
                        ra.Text = 1
                        ra.Find.Parent.Collapse 0
                    Loop
                    End If
                    Next
ActiveDocument.Range.Find.Execute 5, , , 0, , , , , , 1, 1
End Sub
Sub 处理文档(f, arr, brr, tf1, tf2)
On Error GoTo ext:
Dim ra As Range
    With Documents.Open(f, Visible:=1)
    Application.ScreenUpdating = False
        If tf2 = 1 Then .Range.Find.Execute "[^11^13][ 　^t" & ChrW(160) & "^11^13]{1,}", , , 2, , , , , , "^p", 2
        For i = 0 To UBound(arr)
            For Each ra In .StoryRanges
                If Len(Trim(ra)) > 2 Then
                    '                    ra.Find.Execute arr(i), , , tf1, , , , , , brr(i), 2
                    Do While ra.Find.Execute(arr(i), , , tf1)

'                        ra.Find.Parent = brr(i)
                        ra.Find.Execute arr(i), , , tf1, , , , , , brr(i), 1
                        ra.Find.Parent.Font.Color = Label1.ForeColor
                        If tf1 = 0 Then ra.Text = brr(i)
                        ra.Find.Parent.Collapse 0
                    Loop
                    ra.Find.Execute arr(i), , , tf1, , , , , , brr(i), 2
                End If
            Next
        Next
        Application.ScreenUpdating = True
        .Close True
    End With
ext:
End Sub


Function DIR数组遍历()
Dim d1 As Object, arr(), brr()
With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = -1 Then fod = .SelectedItems(1) & "\" Else Exit Function
End With
ReDim Preserve brr(0)
brr(0) = fod
        js = 0   '词典计数器，起到类似递归的作用，随着不断的增加，逐渐深入到新加入的目录中；
    Do While js < UBound(brr) + 1  '第几个i就是进入第几个文件夹！i从0开始。d1.count为找到的文件夹总数。

        ML = Dir(brr(js), vbDirectory)
        Do While ML <> ""
            If ML <> "." And ML <> ".." Then '这两个点，一个代表本目录，另一个代表上级目录parent，dir方式总会有
                If (GetAttr(brr(js) & ML) And vbDirectory) = vbDirectory Then    '第一个括号必须有
                j = j + 1
                ReDim Preserve brr(j)
                   brr(j) = brr(js) & ML & "\"

                Else
                    If InStr(ML, "doc") > 0 And InStr(ML, "$") = 0 Then
                         ReDim Preserve arr(i)
                         arr(i) = brr(js) & ML
                         i = i + 1
                    End If
                End If
            End If
            ML = Dir()
        Loop
        js = js + 1
    Loop
    DIR数组遍历 = arr
End Function



Private Sub CommandButton1_Click()
    批量文件多个关键词替换
End Sub

Private Sub CommandButton2_Click()
    文件夹下word文档替换
End Sub

Private Sub Label1_Click()
Dim CColor As CHOOSECOLOR
With CColor
.lStructSize = Len(CColor) '结构长度
.lpCustColors = VarPtr(CustColors(1)) '存储自定义颜色的缓冲区地址，CustColors为公共变量，用于保存自定义颜色，以便于用户下一次打开调色板时仍能够使用前一次的自定义颜色
End With
If ChooseColorA(CColor) = 0 Then Exit Sub   '等于0表示按下了取消键
Label1.ForeColor = CColor.rgbResult
End Sub

kingtau

我存的草稿怎么给发表了？
请问：怎么编辑自己发的贴子，没找到入口。
我需要将已解决的改下标题，将本贴设为草稿，谢谢

daibao88

第一次见自己的草稿带注释网址的 'http://www.exceltip......