[问题求助] 如何合并验证密码和禁止QQ的VBS脚本的功能？

ww0000

这是个验证密码的脚本：

dim a 
const pass="123456" 
do
    a=inputbox("请输入密码")
    if a=pass then 
         msgbox("密码校验成功")
         exit do
    end if
loopCOPY

这是个禁止QQ程序的脚本：

do
set mi=getobject("winmgmts:win32_process").instances_
for each p in mi
if ucase(p.name)=ucase("QQ.exe") then 
p.terminate
MsgBox "你不能用QQ"
end if
next
wscript.sleep 2000
loopCOPY

现在要将这两个脚本的功能合并起来，运行QQ程序就会要求你输入密码，密码正确，QQ运行；密码不正确，QQ不能运行！高手们，请考虑一下！谢谢！

ww0000

回复 7# yu2n


    谢谢,你真厉害,那么长的代码!

yu2n

Ps: 我觉得你应该试着修改别人的代码，一步步学习，而不是要现成的。

参考：

' QQ 程序设定，自行修改(必须)
Const pass="123456" 
Const QQAppName = "qq.exe"
Const QQFullPath = "E:\AF071\Desktop\qq.exe"
 
 
' 全局变量
Dim RunQQ, MePID
RunQQ = False
MePID = GetMePid()
 
 
' 程序初始化，取得参数
If WScript.Arguments.Count = 0 Then
 
    If MeIsRunAgain() = True Then
        Call TipInfo( "程序访问控制", "正在退出监控程序……", 2 )
        Call MeClose()
    Else
        Call CloseApp(QQAppName, "")
        Call TipInfo( "程序访问控制", "正在启动监控程序……", 3 )
        Call Main()
    End If
 
    WScript.Quit
    
Else
    Dim strArg, arrTmp
    For Each strArg In WScript.Arguments
        arrTmp = Split(strArg, "=")
        If UBound( arrTmp ) = 1 Then 
            Select Case LCase( arrTmp(0) )
                Case "process_stop"
                    Call process_stop( arrTmp(1) )
                Case Else
                    WScript.Quit
            End Select
        End If
    Next
    WScript.Quit
End If
 
 
 
' 主程序
Sub Main()
    Do
        If (QQ_IsRun() = False) Then
            RunQQ = False
        Else
        
            If (RunQQ = False) Then
                Call QQ_Close()
                Call QAQ()
            End If
            
        End If
 
        WScript.Sleep 1000
    Loop
End Sub
 
 
' 获取输入的密码
Sub QAQ()
 
    InputPwd = Trim( InputBox("请输入密码：", "程序访问控制", "") )
 
    If InputPwd = pass then 
        
        Call MeSubAppClose( MePID )
        Call TipInfo( "程序访问控制", "密码校验成功 !", 3 )
        Call QQ_Start()
        RunQQ = True
 
    Else
        
        Call ErrorInfo( "程序访问控制", "密码校验失败 !", 3 )
        RunQQ = False
        
        If Confirm( "程序访问控制 - 继续验证密码" ) = True Then Call QAQ()
 
    End If
 
End Sub
 
 
' 启动QQ
Sub QQ_Start()
 
    CreateObject("WScript.Shell").Run """" & QQFullPath & """", 1, False
    
End Sub
 
 
' 检测 QQ 是否运行
Function QQ_IsRun()
 
    QQ_IsRun = False
    If Not IsRun(QQAppName, "") = 0 Then QQ_IsRun = True
 
End Function
 
 
' 关闭 QQ 程序
Sub QQ_Close()
 
    CreateObject("WScript.Shell").Run """" & WScript.ScriptFullName & """ process_stop=" & QQAppName, 0, False
    
End Sub
 
 
' 持续的关闭 QQ 程序
Sub process_stop( byVal AppName )
 
    Do
        Call CloseApp(AppName, "")
        WScript.Sleep 1000
    Loop
    
End Sub
 
 
 
' 提示信息
Sub TipInfo( strTitle, strMsg, sTime )
    If Len(strMsg) < 22 Then strMsg = "　" & strMsg & String(22 - 1 - Len(strMsg), "　")
    CreateObject("WScript.Shell").popup strMsg, sTime , strTitle, 64+4096    ' 提示信息
End Sub
Sub ErrorInfo( strTitle, strMsg, sTime )
    If Len(strMsg) < 22 Then strMsg = "　" & strMsg & String(22 - 1 - Len(strMsg), "　")
    CreateObject("WScript.Shell").popup strMsg, sTime , strTitle, 16+4096    ' 提示信息
End Sub
 
' 确认继续
Function Confirm( ByVal strMsg )
    Confirm = False
    Set wso = CreateObject("WScript.Shell")
    If wso.Popup("确定要继续吗？" & String(17, "　"), 5, strMsg, 48+4096+1) = 1 Then
        Confirm = True
    End If
End Function
 
 
 
' 检测程序是否运行
Function IsRun(byVal AppName, byVal AppPath)   ' Eg: Call IsRun("mshta.exe", "c:\test.hta")
    IsRun = 0 : i = 0
    For Each ps in GetObject("winmgmts:\\.\root\cimv2:win32_process").instances_
        IF LCase(ps.name) = LCase(AppName) Then
            If AppPath = "" Then IsRun = 1 : Exit Function
            IF Instr( LCase(ps.CommandLine) , LCase(AppPath) ) Then i = i + 1
        End IF
    Next
    IsRun = i
End Function
 
 
' 关闭程序
Sub CloseApp(byVal AppName, byVal AppPath)   ' Eg: Call CloseApp("mshta.exe", "c:\test.hta")
    On Error Resume Next
    For Each ps in GetObject("winmgmts:\\.\root\cimv2:win32_process").instances_
        IF LCase(ps.name) = LCase(AppName) Then
            If AppPath = "" Then
                ps.terminate
            Else
                IF Instr( LCase(ps.CommandLine) , LCase(AppPath) ) Then ps.terminate
            End If
        End IF
    Next
    On Error GoTo 0
End Sub
 
 
' 获取自身PID
Function GetMePid()
    For Each ps In Getobject("winmgmts:\\.").InstancesOf("Win32_Process")
        If ((LCase(ps.name) = LCase(Right(WScript.FullName, 11))) And _
            Instr(LCase(ps.CommandLine) , LCase(WScript.ScriptFullName))) Then
            GetMePid = ps.ProcessID
            Exit Function
        End If
    Next
End Function
 
 
' 检测自身是否重复运行
Function MeIsRunAgain()
    MeIsRunAgain = False
    Dim ps, i
    For Each ps in GetObject("winmgmts:\\.\root\cimv2:win32_process").instances_
        If Lcase(ps.name) = LCase(Right(WScript.FullName,11)) Then
            If instr(Lcase(ps.CommandLine),Lcase(WScript.ScriptFullName)) Then i = i + 1
        End If
    Next
    If i > 2 Then
        MeIsRunAgain = True
    End If
End Function
 
 
' 关闭自身
Function MeClose()
    Dim MeAllPid
    Set pid = Getobject("winmgmts:\\.").InstancesOf("Win32_Process")
    For Each ps In pid
        If Lcase(ps.name) = LCase(Right(WScript.FullName,11)) Then
            If Instr(Lcase(ps.CommandLine),Lcase(WScript.ScriptFullName)) Then
                MeAllPid = MeAllPid & "/PID " & ps.ProcessID & " "
            End If
        End If
    Next
    Set pid = Nothing
    CreateObject("WScript.Shell").Run "TASKKILL " & MeAllPid & " /F /T", 0, False
End Function
 
 
' 关闭子程序
Function MeSubAppClose( ByVal MePID)
    Dim MeAllPid, i
    Set pid = Getobject("winmgmts:\\.").InstancesOf("Win32_Process")
    For Each ps In pid
        If Lcase(ps.name) = LCase(Right(WScript.FullName,11)) Then
            If Instr(Lcase(ps.CommandLine),Lcase(WScript.ScriptFullName)) Then
                If Not MePID = ps.ProcessID Then
                    ps.terminate
                End If
            End If
        End If
    Next
    Set pid = Nothing
End FunctionCOPY

ww0000

回复 5# yu2n


    谢谢你，辛苦了！功能很强大，但不能达到要求！

你的脚本运行后，不用管它的密码窗口，不用输入任何东西，照样用QQ！

yu2n

回复  yu2n


    这个好象不能达到要求，

要每次运行QQ时，跳出要求输入密码，

如果密码错误，跳 ...
ww0000 发表于 2013-1-27 08:31

供参考:

Dim RunQQ
const pass="123456" 
 
 
RunQQ = False
 
 
 
If MeIsRunAgain() = True Then
    Call TipInfo( "程序访问控制", "正在退出监控程序……", 2 )
    Call MeClose()
Else
    Call Main()
End If
 
 
 
Sub Main()
    Do
        If (QQ_IsRun() = False) Then
            RunQQ = False
        Else
        
            If (RunQQ = False) Then
                Call QAQ()
            End If
            
        End If
 
        WScript.Sleep 1000
    Loop
End Sub
 
 
 
Sub QAQ()
 
    InputPwd = Trim( InputBox("请输入密码：", "程序访问控制", "") )
 
    If InputPwd = pass then 
 
        Call TipInfo( "程序访问控制", "密码校验成功 !", 3 )
        RunQQ = True
        
    Else
        
        Call ErrorInfo( "程序访问控制", "密码校验失败 !", 3 )
        Call QQ_Close()
        RunQQ = False
        
        If Confirm( "程序访问控制 - 继续验证密码" ) = True Then Call QAQ()
 
    End If
 
End Sub
 
 
 
' 检测 QQ 是否运行
Function QQ_IsRun()
 
    QQ_IsRun = False
    If Not IsRun("QQ.exe", "") = 0 Then QQ_IsRun = True
 
End Function
 
' 关闭 QQ
Sub QQ_Close()
 
    Call CloseApp("QQ.exe", "")
    
End Sub
 
 
 
' 提示信息
Sub TipInfo( strTitle, strMsg, sTime )
    If Len(strMsg) < 22 Then strMsg = "　" & strMsg & String(22 - 1 - Len(strMsg), "　")
    CreateObject("WScript.Shell").popup strMsg, sTime , strTitle, 64+4096    ' 提示信息
End Sub
Sub ErrorInfo( strTitle, strMsg, sTime )
    If Len(strMsg) < 22 Then strMsg = "　" & strMsg & String(22 - 1 - Len(strMsg), "　")
    CreateObject("WScript.Shell").popup strMsg, sTime , strTitle, 16+4096    ' 提示信息
End Sub
 
' 确认继续
Function Confirm( ByVal strMsg )
    Confirm = False
    Set wso = CreateObject("WScript.Shell")
    If wso.Popup("确定要继续吗？" & String(17, "　"), 5, strMsg, 48+4096+1) = 1 Then
        Confirm = True
    End If
End Function
 
 
 
' 检测程序是否运行
Function IsRun(byVal AppName, byVal AppPath)   ' Eg: Call IsRun("mshta.exe", "c:\test.hta")
    IsRun = 0 : i = 0
    For Each ps in GetObject("winmgmts:\\.\root\cimv2:win32_process").instances_
        IF LCase(ps.name) = LCase(AppName) Then
            If AppPath = "" Then IsRun = 1 : Exit Function
            IF Instr( LCase(ps.CommandLine) , LCase(AppPath) ) Then i = i + 1
        End IF
    Next
    IsRun = i
End Function
 
' 关闭程序
Sub CloseApp(byVal AppName, byVal AppPath)   ' Eg: Call CloseApp("mshta.exe", "c:\test.hta")
    On Error Resume Next
    For Each ps in GetObject("winmgmts:\\.\root\cimv2:win32_process").instances_
        IF LCase(ps.name) = LCase(AppName) Then
            If AppPath = "" Then
                ps.terminate
            Else
                IF Instr( LCase(ps.CommandLine) , LCase(AppPath) ) Then ps.terminate
            End If
        End IF
    Next
    On Error GoTo 0
End Sub
 
 
 
' 检测自身是否重复运行
Function MeIsRunAgain()
    MeIsRunAgain = False
    Dim ps, i
    For Each ps in GetObject("winmgmts:\\.\root\cimv2:win32_process").instances_
        If Lcase(ps.name)="wscript.exe" Or Lcase(ps.name)="cscript.exe" Then
            If instr(Lcase(ps.CommandLine),Lcase(WScript.ScriptFullName)) Then i = i + 1
        End If
    Next
    If i > 1 Then
        MeIsRunAgain = True
    End If
End Function
 
' 关闭自身
Function MeClose()
    Dim MeAllPid, i
    Set pid = Getobject("winmgmts:\\.").InstancesOf("Win32_Process")
    For Each ps In pid
        If Lcase(ps.name)="wscript.exe" Or Lcase(ps.name)="cscript.exe"Then
            If Instr(Lcase(ps.CommandLine),Lcase(WScript.ScriptFullName)) Then
                MeAllPid = MeAllPid & "/PID " & ps.ProcessID & " "
            End If
        End If
    Next
    Set pid = Nothing
    CreateObject("WScript.Shell").Run "TASKKILL " & MeAllPid & " /F /T", 0, False
End FunctionCOPY

ww0000

回复 3# yu2n


    这个好象不能达到要求，

要每次运行QQ时，跳出要求输入密码，

如果密码错误，跳出“你不能使用QQ”。

如果密码正确，跳出QQ登陆的界面！

yu2n

回复 1# ww0000


直接用你的代码，自己测试。

dim a 
const pass="123456" 
do
    a=inputbox("请输入密码")
    if a=pass then 
         msgbox("密码校验成功")
         exit do
    else
 
        ' 调用第二段程序
        call check_qq_run()
 
    end if
loop
 
 
sub check_qq_run()
 
    do
        set mi=getobject("winmgmts:win32_process").instances_
        for each p in mi
            if ucase(p.name)=ucase("QQ.exe") then 
                p.terminate
                MsgBox "你不能用QQ"
            end if
        next
        wscript.sleep 2000
    loop
 
end subCOPY

wankoilz

我晕，("winmgmts:win32_process").instances_
这样写也行... ...无语了
真够简洁的.