返回列表 发帖
ygqiang

Rank: 5Rank: 5

帖子
1366 
积分
837 
技术
15  
捐助
50  
注册时间
2010-4-18 
1楼 跳转到 » 倒序看帖
打印
tT
发表于 2015-11-18 18:10 | 只看该作者

[问题求助] [已解决]win7 64系统，vbs代码，实现自动登录qq。以前好用，最近为啥不好用了呢？

本帖最后由 ygqiang 于 2015-11-23 09:14 编辑

[已解决]win7 64系统，vbs代码，实现自动登录qq。以前好用，最近为啥不好用了呢？
WshShell.AppActivate "qq"
发现这个vbs代码有问题，并不能激活qq 对话框。。。。
RunAsAdminstrator
Function GetQQPath()
  Const HKEY_LOCAL_MACHINE = &H80000002
  Dim s, sREG, sDis, sPath, oReg, fso
  sPath = ""
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set Wss = CreateObject("Wscript.Shell")
  Set oReg = GetObject("Winmgmts:\\.\Root\Default:StdRegProv")
  sREG = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall"
  oReg.EnumKey HKEY_LOCAL_MACHINE, sREG, s
  If IsNull(s) = False Then
    For i = 0 To Ubound(s)
      oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "DisplayName", sDis
      If Ucase(sDis) = "腾讯QQ" Then
        oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "InstallLocation", sPath
      End If
    Next
  End If
  sREG = "SOFTWARE\Wow6432Node\Microsoft\Windows\CurrentVersion\Uninstall"
  oReg.EnumKey HKEY_LOCAL_MACHINE, sREG, s
  If IsNull(s) = False Then
    For i = 0 To Ubound(s)
      oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "DisplayName", sDis
      If Ucase(sDis) = "腾讯QQ" Then
        oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "InstallLocation", sPath
      End If
    Next
  End If
  If sPath = "" Then
    'MsgBox "未找到 腾讯QQ 的注册表路径", 4096
    'CreateObject("Wscript.Shell").Popup "未找到 腾讯QQ 的注册表路径", 5
    Wss.Popup "未找到 腾讯QQ 的注册表路径", 5
    WScript.Quit(1)
  Else
    GetQQPath = fso.BuildPath(sPath, "Bin\QQ.exe")
    If fso.FileExists(GetQQPath) = False Then
      'MsgBox "未找到 " & GetQQPath, 4096
      'CreateObject("Wscript.Shell").Popup "未找到 " & GetQQPath, 5
      Wss.Popup "未找到 " & GetQQPath, 5
      WScript.Quit(2)
    End If
  End If
End Function
Sub RunAsAdminstrator() 
    Dim shell, os, arg, ver
    Set shell = CreateObject("Shell.Application")
    
    For Each os In GetObject("WinMgmts:").InstancesOf("Win32_OperatingSystem")
        ver = Left(os.Version, 3)
    Next
    If ver <> "6.1" And ver <> "6.0" And ver <> "6.3" Then Exit Sub
    
    For Each arg In WScript.Arguments.Named
        If LCase(arg) = "uac" Then Exit Sub
    Next
    
    Shell.ShellExecute "wscript.exe", Chr(34) & _
    WScript.ScriptFullName & Chr(34) & " /uac", "", "runas", 1
    WScript.Quit
End Sub
 
'定义QQ程序路径、帐号、密码 
Dim Program1,a,b,c 
Program1 = GetQQPath()
'MsgBox Program1
Set WshShell=createobject("wscript.shell") 
'运行QQ主程序 
Set oExec=WshShell.Exec(Program1) 
WScript.Sleep 5000 
'激活QQ窗口 
WshShell.AppActivate "qq" 
wshShell.SendKeys "+{TAB}" 
WScript.Sleep 2000 
'输入帐号 
a="24545640" 
WshShell.SendKeys a 
WScript.Sleep 1000 
WshShell.SendKeys "{TAB}" 
'输入帐号 
a="24545640" 
WshShell.SendKeys a 
WScript.Sleep 1000 
WshShell.SendKeys "{TAB}" 
WScript.Sleep 2000 
'输入密码 
b="245756" 
WshShell.SendKeys b 
WScript.Sleep 2000 
WshShell.SendKeys "{ENTER}" COPY
收藏 分享

ygqiang

Rank: 5Rank: 5

帖子
1366 
积分
837 
技术
15  
捐助
50  
注册时间
2010-4-18 
2楼
发表于 2015-11-19 10:15 | 只看该作者
本论坛，有人说：

现在的新版QQ启动时至少会出现两个进程，不能用title去激活，而且用title激活原来也很不可靠，所以我以前都是用进程ID去激活程序的。现在也应用进程ID去激活，并且我试了下，QQ只能是进程ID大的那个才行。

TOP

ygqiang

Rank: 5Rank: 5

帖子
1366 
积分
837 
技术
15  
捐助
50  
注册时间
2010-4-18 
3楼
发表于 2015-11-19 10:23 | 只看该作者
需要的功能是：
运行1次vbs，自动启动qq、自动输入帐号/密码。自动登录qq
不需要点击鼠标、键盘。就能实现。。

TOP

ygqiang

Rank: 5Rank: 5

帖子
1366 
积分
837 
技术
15  
捐助
50  
注册时间
2010-4-18 
4楼
发表于 2015-11-19 10:49 | 只看该作者
好像解决了。。。
RunAsAdminstrator
Function GetQQPath()
  Const HKEY_LOCAL_MACHINE = &H80000002
  Dim s, sREG, sDis, sPath, oReg, fso
  sPath = ""
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set Wss = CreateObject("Wscript.Shell")
  Set oReg = GetObject("Winmgmts:\\.\Root\Default:StdRegProv")
  sREG = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall"
  oReg.EnumKey HKEY_LOCAL_MACHINE, sREG, s
  If IsNull(s) = False Then
    For i = 0 To Ubound(s)
      oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "DisplayName", sDis
      If Ucase(sDis) = "腾讯QQ" Then
        oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "InstallLocation", sPath
      End If
    Next
  End If
  sREG = "SOFTWARE\Wow6432Node\Microsoft\Windows\CurrentVersion\Uninstall"
  oReg.EnumKey HKEY_LOCAL_MACHINE, sREG, s
  If IsNull(s) = False Then
    For i = 0 To Ubound(s)
      oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "DisplayName", sDis
      If Ucase(sDis) = "腾讯QQ" Then
        oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "InstallLocation", sPath
      End If
    Next
  End If
  If sPath = "" Then
    'MsgBox "未找到 腾讯QQ 的注册表路径", 4096
    'CreateObject("Wscript.Shell").Popup "未找到 腾讯QQ 的注册表路径", 5
    Wss.Popup "未找到 腾讯QQ 的注册表路径", 5
    WScript.Quit(1)
  Else
    GetQQPath = fso.BuildPath(sPath, "Bin\QQ.exe")
    If fso.FileExists(GetQQPath) = False Then
      'MsgBox "未找到 " & GetQQPath, 4096
      'CreateObject("Wscript.Shell").Popup "未找到 " & GetQQPath, 5
      Wss.Popup "未找到 " & GetQQPath, 5
      WScript.Quit(2)
    End If
  End If
End Function
 
Sub RunAsAdminstrator() 
    Dim shell, os, arg, ver
    Set shell = CreateObject("Shell.Application")
    
    For Each os In GetObject("WinMgmts:").InstancesOf("Win32_OperatingSystem")
        ver = Left(os.Version, 3)
    Next
    If ver <> "6.1" And ver <> "6.0" And ver <> "6.3" Then Exit Sub
    
    For Each arg In WScript.Arguments.Named
        If LCase(arg) = "uac" Then Exit Sub
    Next
    
    Shell.ShellExecute "wscript.exe", Chr(34) & _
    WScript.ScriptFullName & Chr(34) & " /uac", "", "runas", 1
    WScript.Quit
End Sub
 
 
'定义QQ程序路径、帐号、密码 
Dim Program1,a,b,c 
 
Program1 = GetQQPath()
'MsgBox Program1
Set WshShell=createobject("wscript.shell") 
 
'运行QQ主程序 
Set oExec=WshShell.Exec(Program1) 
WScript.Sleep 5000 
 
'激活QQ窗口 
'WshShell.AppActivate "qq.exe" 
'wshShell.SendKeys "+{TAB}" 
WshShell.SendKeys "{TAB}" 
WshShell.SendKeys "{TAB}" 
WshShell.SendKeys "{TAB}" 
WshShell.SendKeys "{TAB}" 
WshShell.SendKeys "{TAB}" 
WshShell.SendKeys "{TAB}" 
WshShell.SendKeys "{TAB}" 
WshShell.SendKeys "{TAB}" 
WshShell.SendKeys "{TAB}" 
WshShell.SendKeys "{TAB}" 
WshShell.SendKeys "{TAB}" 
WScript.Sleep 3000 
 
'输入帐号 
a="24545640" 
WshShell.SendKeys a 
WScript.Sleep 1000 
WshShell.SendKeys "{TAB}" 
 
'输入帐号 
a="24545640" 
WshShell.SendKeys a 
WScript.Sleep 1000 
WshShell.SendKeys "{TAB}" 
WScript.Sleep 2000 
 
 
'输入密码 
b="245756" 
WshShell.SendKeys b 
WScript.Sleep 2000
 
WshShell.SendKeys "{ENTER}" COPY

TOP

yiwuyun

Rank: 3Rank: 3

帖子
168 
积分
283 
技术
25  
捐助
0  
注册时间
2014-11-23 
5楼
发表于 2015-11-19 18:18 | 只看该作者
76.'WshShell.AppActivate "qq.exe"
这一句，如果这样，始终不会起作用。必须用ProcessID

TOP

ygqiang

Rank: 5Rank: 5

帖子
1366 
积分
837 
技术
15  
捐助
50  
注册时间
2010-4-18 
6楼
发表于 2015-11-20 00:03 | 只看该作者
76.'WshShell.AppActivate "qq.exe"
这一句，如果这样，始终不会起作用。必须用ProcessID
yiwuyun 发表于 2015-11-19 18:18



    如何解决呢？

楼上的vbs代码。有时候可以实现自动登录qq。。
就是成功概率比较低。。

TOP

ygqiang

Rank: 5Rank: 5

帖子
1366 
积分
837 
技术
15  
捐助
50  
注册时间
2010-4-18 
7楼
发表于 2015-11-23 09:14 | 只看该作者 
RunAsAdminstrator
Function GetQQPath()
  Const HKEY_LOCAL_MACHINE = &H80000002
  Dim s, sREG, sDis, sPath, oReg, fso
  sPath = ""
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set Wss = CreateObject("Wscript.Shell")
  Set oReg = GetObject("Winmgmts:\\.\Root\Default:StdRegProv")
  sREG = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall"
  oReg.EnumKey HKEY_LOCAL_MACHINE, sREG, s
  If IsNull(s) = False Then
    For i = 0 To Ubound(s)
      oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "DisplayName", sDis
      If Ucase(sDis) = "腾讯QQ" Then
        oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "InstallLocation", sPath
      End If
    Next
  End If
  sREG = "SOFTWARE\Wow6432Node\Microsoft\Windows\CurrentVersion\Uninstall"
  oReg.EnumKey HKEY_LOCAL_MACHINE, sREG, s
  If IsNull(s) = False Then
    For i = 0 To Ubound(s)
      oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "DisplayName", sDis
      If Ucase(sDis) = "腾讯QQ" Then
        oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "InstallLocation", sPath
      End If
    Next
  End If
  If sPath = "" Then
    'MsgBox "未找到 腾讯QQ 的注册表路径", 4096
    'CreateObject("Wscript.Shell").Popup "未找到 腾讯QQ 的注册表路径", 5
    Wss.Popup "未找到 腾讯QQ 的注册表路径", 5
    WScript.Quit(1)
  Else
    GetQQPath = fso.BuildPath(sPath, "Bin\QQ.exe")
    If fso.FileExists(GetQQPath) = False Then
      'MsgBox "未找到 " & GetQQPath, 4096
      'CreateObject("Wscript.Shell").Popup "未找到 " & GetQQPath, 5
      Wss.Popup "未找到 " & GetQQPath, 5
      WScript.Quit(2)
    End If
  End If
End Function
 
Sub RunAsAdminstrator() 
    Dim shell, os, arg, ver
    Set shell = CreateObject("Shell.Application")
    
    For Each os In GetObject("WinMgmts:").InstancesOf("Win32_OperatingSystem")
        ver = Left(os.Version, 3)
    Next
    If ver <> "6.1" And ver <> "6.0" And ver <> "6.3" Then Exit Sub
    
    For Each arg In WScript.Arguments.Named
        If LCase(arg) = "uac" Then Exit Sub
    Next
    
    Shell.ShellExecute "wscript.exe", Chr(34) & _
    WScript.ScriptFullName & Chr(34) & " /uac", "", "runas", 1
    WScript.Quit
End Sub
 
 
'定义QQ程序路径、帐号、密码 
Dim Program1,a,b,c 
 
Program1 = GetQQPath()
'MsgBox Program1
Set WshShell=createobject("wscript.shell") 
 
'运行QQ主程序 
Set oExec=WshShell.Exec(Program1) 
WScript.Sleep 5000 
 
'激活QQ窗口 
WshShell.SendKeys "{TAB}" 
WshShell.SendKeys "{TAB}" 
WshShell.SendKeys "{TAB}" 
WshShell.SendKeys "{TAB}" 
WshShell.SendKeys "{TAB}" 
WshShell.SendKeys "{TAB}" 
WshShell.SendKeys "{TAB}" 
WshShell.SendKeys "{TAB}" 
WshShell.SendKeys "{TAB}" 
WshShell.SendKeys "{TAB}" 
WshShell.SendKeys "{TAB}" 
WScript.Sleep 3000 
 
'输入帐号 
a="qq帐号" 
WshShell.SendKeys a 
WScript.Sleep 1000 
WshShell.SendKeys "{TAB}" 
 
'输入帐号 
a="qq帐号" 
WshShell.SendKeys a 
WScript.Sleep 1000 
WshShell.SendKeys "{TAB}" 
WScript.Sleep 2000 
 
 
'输入帐号 
a="qq帐号" 
WshShell.SendKeys a 
WScript.Sleep 1000 
WshShell.SendKeys "{ENTER}" 
WScript.Sleep 1000
 
 
'输入密码 
b="qq密码" 
WshShell.SendKeys b 
WScript.Sleep 2000
 
 
 
WshShell.SendKeys "{ENTER}" COPY
更新下。。。最终解决代码。。。。

TOP

erjnasrtnws

Rank: 1

帖子
59 
积分
77 
技术
0  
捐助
0  
注册时间
2015-11-21 
8楼
发表于 2015-12-30 08:16 | 只看该作者
回复 7# ygqiang


    好强大
这么好的论坛！！！！

TOP

zhangop9

Rank: 2

帖子
119 
积分
169 
技术
1  
捐助
0  
注册时间
2010-12-16 
9楼
发表于 2022-3-20 14:59 | 只看该作者
GetQQPath()

TOP

返回列表