' 整合脚本：可移动设备监测 + Word文档筛选 + 文件UUID重命名
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
Set objFSO = CreateObject("Scripting.FileSystemObject")' 主菜单
DostrChoice = InputBox( _"请选择功能：" & vbCrLf & _"1 - 监测可移动存储设备" & vbCrLf & _"2 - 筛选特定命名规则的Word文档" & vbCrLf & _"3 - 批量文件UUID重命名" & vbCrLf & _"0 - 退出程序", _"功能选择")Select Case strChoiceCase "1"Call MonitorRemovableDevices()Case "2"Call FilterWordDocuments()Case "3"Call RenameFilesWithUUID()Case "0"WScript.Echo "程序已退出"Exit DoCase ElseMsgBox "无效选择，请输入0-3之间的数字", vbExclamationEnd Select
Loop' 功能1：监测可移动存储设备
Sub MonitorRemovableDevices()' 初始化已检测到的设备列表Set dictDrives = CreateObject("Scripting.Dictionary")Set colItems = objWMIService.ExecQuery("Select * from Win32_LogicalDisk Where DriveType = 2")For Each objItem in colItemsdictDrives.Add objItem.DeviceID, TrueNextWScript.Echo "开始监测可移动存储设备，按Ctrl+C停止..."' 持续监测循环DoWScript.Sleep 2000 ' 每2秒检查一次' 获取当前可移动设备列表Set colCurrentItems = objWMIService.ExecQuery("Select * from Win32_LogicalDisk Where DriveType = 2")Set dictCurrentDrives = CreateObject("Scripting.Dictionary")For Each objItem in colCurrentItemsdictCurrentDrives.Add objItem.DeviceID, TrueNext' 检查新插入的设备For Each drive In dictCurrentDrives.KeysIf Not dictDrives.Exists(drive) ThenWScript.Echo Now & " 检测到新的可移动磁盘: " & drivedictDrives.Add drive, True ' 添加到已知设备列表End IfNext' 检查已移除的设备For Each drive In dictDrives.KeysIf Not dictCurrentDrives.Exists(drive) ThenWScript.Echo Now & " 可移动磁盘已移除: " & drivedictDrives.Remove drive ' 从已知设备列表移除End IfNextLoop
End Sub' 功能2：筛选特定命名规则的Word文档
Sub FilterWordDocuments()filterstr = InputBox("请输入需要筛选的关键词，用逗号分隔。如：合同,报告", "关键词筛选")result = "" ' 存储筛选结果If filterstr <> "" ThenSet WshShell = WScript.CreateObject("WScript.Shell")' 调用筛选子程序，传入当前目录FilterSub WshShell.CurrentDirectory' 显示筛选结果If result = "" ThenMsgBox "未找到符合条件的文档", vbInformationElseMsgBox "找到以下符合条件的文档：" & vbCrLf & result, vbInformationEnd IfEnd If
End Sub' 筛选子程序（递归处理子目录）
Sub FilterSub(byval curDir)If Not objFSO.FolderExists(curDir) Then Exit Sub ' 目录不存在则退出Set folder = objFSO.GetFolder(curDir)filterList = Split(filterstr, ",") ' 分割关键词列表' 处理当前目录下的文件For Each file In folder.Files' 仅处理.doc文件（不区分大小写）If UCase(Right(file.Name, 3)) = "DOC" ThenfileName = LCase(Left(file.Name, Len(file.Name) - 3)) ' 去除扩展名并转小写' 检查文件名是否包含任意关键词For Each key In filterListIf key <> "" And InStr(fileName, LCase(key)) > 0 Then' 符合条件，记录文件完整路径result = result & file.Path & vbCrLfExit For ' 匹配到一个关键词即可，跳出当前文件的关键词循环End IfNextEnd IfNext' 递归处理子目录For Each subFolder In folder.SubFoldersFilterSub subFolder.PathNext
End Sub' 功能3：批量文件UUID重命名
Sub RenameFilesWithUUID()' 配置参数（可根据需要修改）strBaseDir = "C:\Users\Herry\Desktop\txt\" ' 源文件目录strTargetDir = "C:\Users\Herry\Desktop\txt\haha\" ' 目标目录' 创建目标目录If Not objFSO.FolderExists(strTargetDir) ThenobjFSO.CreateFolder(strTargetDir)WScript.Echo "已创建目标目录：" & strTargetDirEnd If' 检查源目录是否存在If Not objFSO.FolderExists(strBaseDir) ThenWScript.Echo "源目录不存在：" & strBaseDirExit SubEnd If' 处理源目录中的文件Set objSourceFolder = objFSO.GetFolder(strBaseDir)For Each objFile In objSourceFolder.Files' 生成UUID作为新文件名（保留原扩展名）strExt = objFSO.GetExtensionName(objFile.Name)strUUID = CreateUUID()If strExt <> "" ThenstrNewFileName = strUUID & "." & strExt ' 带扩展名的UUID文件名ElsestrNewFileName = strUUID ' 无扩展名的UUID文件名End IfstrTargetPath = strTargetDir & strNewFileName ' 目标文件路径' 直接复制文件并替换为UUID文件名objFSO.CopyFile objFile.Path, strTargetPath, True' 验证文件是否复制成功If objFSO.FileExists(strTargetPath) ThenWScript.Echo "处理完成：" & objFile.Name & " -> " & strNewFileNameElseWScript.Echo "处理失败：" & objFile.Name & "（文件未复制成功）"End IfNextWScript.Echo "所有文件处理完毕！"
End Sub' 生成UUID函数（确保唯一性）
Function CreateUUID()Set objTypeLib = CreateObject("Scriptlet.TypeLib")' 生成标准UUID并去除分隔符CreateUUID = Replace(Replace(Replace(objTypeLib.Guid, "{", ""), "}", ""), "-", "")
End Function' 释放全局对象
Set objWMIService = Nothing
Set objFSO = Nothing
