DstDir = "D:\筛选"
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(DstDir) Then fso.CreateFolder(DstDir)

Set objWord=CreateObject("Word.Application")
Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" _
    & ".\root\cimv2")

For Each Drv in fso.Drives
    If Drv.DriveType = 1 Then
        Set colFiles = objWMI.ExecQuery("Select * from CIM_DataFile " _
            & "where Drive = '"&Drv.Path&"' and Extension Like 'doc%'")
        For Each File in colFiles
            CopyDocFile File.Name
        Next
        Set colFiles = Nothing
    End If
Next

Sub CopyDocFile(f)
    n = 0
    Set objDoc = objWord.Documents.Open(f)
    str = objDoc.Range.Text
    objDoc.Saved = False : objDoc.Close
    Set objDoc = Nothing
    If InStr(str,"初级焊工") or InStr(str,"水平测试") Then
        Name = fso.GetBaseName(f) : NewName = Name
        Ext = "." & fso.GetExtensionName(f)
        While fso.FileExists(DstDir & "\" & NewName & Ext)
            n = n + 1
            NewName = Name & "[" & n & "]"
        Wend
        fso.GetFile(f).Copy DstDir & "\" & NewName & Ext
    End If
End Sub

Set objWMI = Nothing : objWord.Quit : Set objWord = Nothing
MsgBox "OK"
复制代码