[问题求助] [已解决]vbs后台一直循环2秒监控。如果发现u盘插入，就弹出我的电脑。如何实现？

ygqiang

[已解决]vbs后台一直循环2秒监控。如果发现u盘插入，就弹出我的电脑。如何实现？
如果发现有重复标题的文件夹窗口，就自动关闭(只保留1个文件夹窗口)

'关闭重复窗口、u盘插入-自动打开我的电脑
'
'后台一直循环2秒监控。
'如果发现u盘插入，就弹出我的电脑
'如果发现有重复标题的文件夹窗口，就自动关闭(只保留1个文件夹窗口)

Do
  Main
  WScript.Sleep 2000
Loop

Sub Main()

  Dim wso, fso
  Set wso = CreateObject("WScript.Shell")
  Set fso = CreateObject("Scripting.FileSystemObject")
  
  '监控u盘/usb移动硬盘，是否插入
  
  '如果u盘插入-自动打开我的电脑
  wso.Run "Explorer.exe /n," 

  '关闭重复的文件窗口
  Call CloseRepeatFolderWindow()
  
  Set wso = NoThing
  
End Sub

'监控u盘/usb移动硬盘，是否插入
Sub Monitor-U()

End Sub

' VBS关闭重复的文件夹窗口 By Crlf bathome.net
Sub CloseRepeatFolderWindow()
  On Error Resume Next
  Dim Shell, Dict, Wins
  Set Shell = CreateObject("Shell.Application")
  Set Dict = CreateObject("Scripting.Dictionary")
  Set Wins = Shell.Windows
  For i=Wins.Count-1 To 0 step -1
    If Instr(LCase(Wins(i).FullName),"\explorer.exe") Then
      If Dict.Exists(Wins(i).LocationURL) Then
        Wins(i).Quit
      Else
        Dict.Add Wins(i).LocationURL,True
      End If
    End If
  Next
End Sub

'检测vbs代码是否重复运行
Function AppPrevInstance()
  AppPrevInstance=False
  Dim objItem, i
  For Each objItem in GetObject("winmgmts:\\.\root\cimv2:win32_process").instances_
    IF LCase(objItem.Name)=LCase(Right(WScript.FullName,11)) Then
      IF InStr(1,objItem.CommandLine,WScript.ScriptFullName,vbTextCompare) > 0 Then i=i+1
    End IF
  Next
  If i>1 Then AppPrevInstance=True
End Function
复制代码

ygqiang

'监控
Sub MonitorWindowTitle(ByVal strWindowTitle)
  Dim wso, objWord, objTasks
  Set wso = CreateObject("Wscript.Shell")
  Set objWord = CreateObject("word.Application")
  Set objTasks = objWord.Tasks
  Do While objTasks.Exists(strWindowTitle) = False
    WScript.sleep 200    ' 延时 0.2 秒
    Call CloseRepeatFolderWindow()
    '检查是否重复运行
    If AppPrevInstance() = True Then
      Call wso.Popup("该程序不允许重复运行！" & vbCrLf & String(75," ") & _
          vbCrLf & "程序将在 3 秒后全部退出 ...", 3, WScript.ScriptName, vbOKOnly+vbCritical)
      '直接退出程序
      objWord.Quit
      WScript.Quit(2)
    End If
  Loop
End Sub
复制代码

ygqiang

[已解决]最终vbs代码如下：

ygqiang

'后台一直循环2秒监控。
'1、如果发现u盘插入，就弹出我的电脑(每当u盘插入1次，就弹出1次我的电脑，而且只允许弹出1次。下次重新插入u盘，再弹出1次我的电脑)
'2、如果发现有重复标题的文件夹窗口，就自动关闭(只保留1个文件夹窗口)
'上面2个功能是各自独立的、互相之间没有联系的。

  Dim wso, objWord
  Set wso = CreateObject("Wscript.Shell")
  Set objWord = CreateObject("word.Application")

    If AppPrevInstance() = True Then
      Call wso.Popup("该程序不允许重复运行！" & vbCrLf & String(75," ") & _
          vbCrLf & "程序将在 3 秒后全部退出 ...", 3, WScript.ScriptName, vbOKOnly+vbCritical)
      '直接退出程序
      objWord.Quit
      WScript.Quit(2)
    End If


dim TmpDiskNum
TmpDiskNum=0
Do
	Call ufind()
	WScript.Sleep 2000
	'关闭重复的文件窗口
	Call CloseRepeatFolderWindow()
Loop

'监控u盘/usb移动硬盘，是否插入
Sub ufind()
On Error Resume Next
	dim a
	Set fso = CreateObject("scripting.filesystemobject") 
	Set Disks = fso.Drives 
	dim DiskNumber
	DiskNumber = 0
	
	For Each Disk In Disks 
		If Disk.IsReady And Disk.DriveType = 1 Then
		
			DiskNumber = DiskNumber + 1
			
			'MsgBox "发现U盘" & Disk.DriveLetter & ":\!", 4096 + 64, "温馨提示" 
			'如果u盘插入-自动打开我的电脑
			D = Disk.DriveLetter
			
			if DiskNumber > TmpDiskNum then '如果是检测到 但是没有开启过 择开启
				dim wso
				Set wso = CreateObject("WScript.Shell")
				wso.Run "Explorer.exe /n," 
			end if
			
			'关闭重复的文件窗口
			Call CloseRepeatFolderWindow()
			WScript.Sleep 1000
			Set wso = NoThing
			a = true
		End If 
	Next
	
	TmpDiskNum = DiskNumber
	
	if a = false then 
		'U盘不存在
		'msgbox "没有发现U盘,请检查U盘是否插好",,"温馨提示"
	End if
	
End Sub


'检测vbs代码是否重复运行
Function AppPrevInstance()
  AppPrevInstance=False
  Dim objItem, i
  For Each objItem in GetObject("winmgmts:\\.\root\cimv2:win32_process").instances_
    IF LCase(objItem.Name)=LCase(Right(WScript.FullName,11)) Then
      IF InStr(1,objItem.CommandLine,WScript.ScriptFullName,vbTextCompare) > 0 Then i=i+1
    End IF
  Next
  If i>1 Then AppPrevInstance=True
End Function



'VBS关闭重复的文件夹窗口 By Crlf bathome.net
Sub CloseRepeatFolderWindow()
  On Error Resume Next
  Dim Shell, Dict, Wins
  Set Shell = CreateObject("Shell.Application")
  Set Dict = CreateObject("Scripting.Dictionary")
  Set Wins = Shell.Windows
  For i=Wins.Count-1 To 0 step -1
    If Instr(LCase(Wins(i).FullName),"\explorer.exe") Then
      If Dict.Exists(Wins(i).LocationURL) Then
        Wins(i).Quit
      Else
        Dict.Add Wins(i).LocationURL,True
      End If
    End If
  Next
End Sub
复制代码