Board logo

标题: [问题求助] [已解决]win7 64系统,vbs代码,实现自动登录qq。以前好用,最近为啥不好用了呢? [打印本页]

作者: ygqiang    时间: 2015-11-18 18:10     标题: [已解决]win7 64系统,vbs代码,实现自动登录qq。以前好用,最近为啥不好用了呢?

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

[已解决]win7 64系统,vbs代码,实现自动登录qq。以前好用,最近为啥不好用了呢?
WshShell.AppActivate "qq"
发现这个vbs代码有问题,并不能激活qq 对话框。。。。
  1. RunAsAdminstrator
  2. Function GetQQPath()
  3.   Const HKEY_LOCAL_MACHINE = &H80000002
  4.   Dim s, sREG, sDis, sPath, oReg, fso
  5.   sPath = ""
  6.   Set fso = CreateObject("Scripting.FileSystemObject")
  7.   Set Wss = CreateObject("Wscript.Shell")
  8.   Set oReg = GetObject("Winmgmts:\\.\Root\Default:StdRegProv")
  9.   sREG = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall"
  10.   oReg.EnumKey HKEY_LOCAL_MACHINE, sREG, s
  11.   If IsNull(s) = False Then
  12.     For i = 0 To Ubound(s)
  13.       oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "DisplayName", sDis
  14.       If Ucase(sDis) = "腾讯QQ" Then
  15.         oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "InstallLocation", sPath
  16.       End If
  17.     Next
  18.   End If
  19.   sREG = "SOFTWARE\Wow6432Node\Microsoft\Windows\CurrentVersion\Uninstall"
  20.   oReg.EnumKey HKEY_LOCAL_MACHINE, sREG, s
  21.   If IsNull(s) = False Then
  22.     For i = 0 To Ubound(s)
  23.       oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "DisplayName", sDis
  24.       If Ucase(sDis) = "腾讯QQ" Then
  25.         oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "InstallLocation", sPath
  26.       End If
  27.     Next
  28.   End If
  29.   If sPath = "" Then
  30.     'MsgBox "未找到 腾讯QQ 的注册表路径", 4096
  31.     'CreateObject("Wscript.Shell").Popup "未找到 腾讯QQ 的注册表路径", 5
  32.     Wss.Popup "未找到 腾讯QQ 的注册表路径", 5
  33.     WScript.Quit(1)
  34.   Else
  35.     GetQQPath = fso.BuildPath(sPath, "Bin\QQ.exe")
  36.     If fso.FileExists(GetQQPath) = False Then
  37.       'MsgBox "未找到 " & GetQQPath, 4096
  38.       'CreateObject("Wscript.Shell").Popup "未找到 " & GetQQPath, 5
  39.       Wss.Popup "未找到 " & GetQQPath, 5
  40.       WScript.Quit(2)
  41.     End If
  42.   End If
  43. End Function
  44. Sub RunAsAdminstrator()
  45.     Dim shell, os, arg, ver
  46.     Set shell = CreateObject("Shell.Application")
  47.    
  48.     For Each os In GetObject("WinMgmts:").InstancesOf("Win32_OperatingSystem")
  49.         ver = Left(os.Version, 3)
  50.     Next
  51.     If ver <> "6.1" And ver <> "6.0" And ver <> "6.3" Then Exit Sub
  52.    
  53.     For Each arg In WScript.Arguments.Named
  54.         If LCase(arg) = "uac" Then Exit Sub
  55.     Next
  56.    
  57.     Shell.ShellExecute "wscript.exe", Chr(34) & _
  58.     WScript.ScriptFullName & Chr(34) & " /uac", "", "runas", 1
  59.     WScript.Quit
  60. End Sub
  61. '定义QQ程序路径、帐号、密码
  62. Dim Program1,a,b,c
  63. Program1 = GetQQPath()
  64. 'MsgBox Program1
  65. Set WshShell=createobject("wscript.shell")
  66. '运行QQ主程序
  67. Set oExec=WshShell.Exec(Program1)
  68. WScript.Sleep 5000
  69. '激活QQ窗口
  70. WshShell.AppActivate "qq"
  71. wshShell.SendKeys "+{TAB}"
  72. WScript.Sleep 2000
  73. '输入帐号
  74. a="24545640"
  75. WshShell.SendKeys a
  76. WScript.Sleep 1000
  77. WshShell.SendKeys "{TAB}"
  78. '输入帐号
  79. a="24545640"
  80. WshShell.SendKeys a
  81. WScript.Sleep 1000
  82. WshShell.SendKeys "{TAB}"
  83. WScript.Sleep 2000
  84. '输入密码
  85. b="245756"
  86. WshShell.SendKeys b
  87. WScript.Sleep 2000
  88. WshShell.SendKeys "{ENTER}"
复制代码

作者: ygqiang    时间: 2015-11-19 10:15

本论坛,有人说:

现在的新版QQ启动时至少会出现两个进程,不能用title去激活,而且用title激活原来也很不可靠,所以我以前都是用进程ID去激活程序的。现在也应用进程ID去激活,并且我试了下,QQ只能是进程ID大的那个才行。
作者: ygqiang    时间: 2015-11-19 10:23

需要的功能是:
运行1次vbs,自动启动qq、自动输入帐号/密码。自动登录qq
不需要点击鼠标、键盘。就能实现。。
作者: ygqiang    时间: 2015-11-19 10:49

好像解决了。。。
  1. RunAsAdminstrator
  2. Function GetQQPath()
  3.   Const HKEY_LOCAL_MACHINE = &H80000002
  4.   Dim s, sREG, sDis, sPath, oReg, fso
  5.   sPath = ""
  6.   Set fso = CreateObject("Scripting.FileSystemObject")
  7.   Set Wss = CreateObject("Wscript.Shell")
  8.   Set oReg = GetObject("Winmgmts:\\.\Root\Default:StdRegProv")
  9.   sREG = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall"
  10.   oReg.EnumKey HKEY_LOCAL_MACHINE, sREG, s
  11.   If IsNull(s) = False Then
  12.     For i = 0 To Ubound(s)
  13.       oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "DisplayName", sDis
  14.       If Ucase(sDis) = "腾讯QQ" Then
  15.         oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "InstallLocation", sPath
  16.       End If
  17.     Next
  18.   End If
  19.   sREG = "SOFTWARE\Wow6432Node\Microsoft\Windows\CurrentVersion\Uninstall"
  20.   oReg.EnumKey HKEY_LOCAL_MACHINE, sREG, s
  21.   If IsNull(s) = False Then
  22.     For i = 0 To Ubound(s)
  23.       oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "DisplayName", sDis
  24.       If Ucase(sDis) = "腾讯QQ" Then
  25.         oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "InstallLocation", sPath
  26.       End If
  27.     Next
  28.   End If
  29.   If sPath = "" Then
  30.     'MsgBox "未找到 腾讯QQ 的注册表路径", 4096
  31.     'CreateObject("Wscript.Shell").Popup "未找到 腾讯QQ 的注册表路径", 5
  32.     Wss.Popup "未找到 腾讯QQ 的注册表路径", 5
  33.     WScript.Quit(1)
  34.   Else
  35.     GetQQPath = fso.BuildPath(sPath, "Bin\QQ.exe")
  36.     If fso.FileExists(GetQQPath) = False Then
  37.       'MsgBox "未找到 " & GetQQPath, 4096
  38.       'CreateObject("Wscript.Shell").Popup "未找到 " & GetQQPath, 5
  39.       Wss.Popup "未找到 " & GetQQPath, 5
  40.       WScript.Quit(2)
  41.     End If
  42.   End If
  43. End Function
  44. Sub RunAsAdminstrator()
  45.     Dim shell, os, arg, ver
  46.     Set shell = CreateObject("Shell.Application")
  47.    
  48.     For Each os In GetObject("WinMgmts:").InstancesOf("Win32_OperatingSystem")
  49.         ver = Left(os.Version, 3)
  50.     Next
  51.     If ver <> "6.1" And ver <> "6.0" And ver <> "6.3" Then Exit Sub
  52.    
  53.     For Each arg In WScript.Arguments.Named
  54.         If LCase(arg) = "uac" Then Exit Sub
  55.     Next
  56.    
  57.     Shell.ShellExecute "wscript.exe", Chr(34) & _
  58.     WScript.ScriptFullName & Chr(34) & " /uac", "", "runas", 1
  59.     WScript.Quit
  60. End Sub
  61. '定义QQ程序路径、帐号、密码
  62. Dim Program1,a,b,c
  63. Program1 = GetQQPath()
  64. 'MsgBox Program1
  65. Set WshShell=createobject("wscript.shell")
  66. '运行QQ主程序
  67. Set oExec=WshShell.Exec(Program1)
  68. WScript.Sleep 5000
  69. '激活QQ窗口
  70. 'WshShell.AppActivate "qq.exe"
  71. 'wshShell.SendKeys "+{TAB}"
  72. WshShell.SendKeys "{TAB}"
  73. WshShell.SendKeys "{TAB}"
  74. WshShell.SendKeys "{TAB}"
  75. WshShell.SendKeys "{TAB}"
  76. WshShell.SendKeys "{TAB}"
  77. WshShell.SendKeys "{TAB}"
  78. WshShell.SendKeys "{TAB}"
  79. WshShell.SendKeys "{TAB}"
  80. WshShell.SendKeys "{TAB}"
  81. WshShell.SendKeys "{TAB}"
  82. WshShell.SendKeys "{TAB}"
  83. WScript.Sleep 3000
  84. '输入帐号
  85. a="24545640"
  86. WshShell.SendKeys a
  87. WScript.Sleep 1000
  88. WshShell.SendKeys "{TAB}"
  89. '输入帐号
  90. a="24545640"
  91. WshShell.SendKeys a
  92. WScript.Sleep 1000
  93. WshShell.SendKeys "{TAB}"
  94. WScript.Sleep 2000
  95. '输入密码
  96. b="245756"
  97. WshShell.SendKeys b
  98. WScript.Sleep 2000
  99. WshShell.SendKeys "{ENTER}"
复制代码

作者: yiwuyun    时间: 2015-11-19 18:18

76.'WshShell.AppActivate "qq.exe"
这一句,如果这样,始终不会起作用。必须用ProcessID
作者: ygqiang    时间: 2015-11-20 00:03

76.'WshShell.AppActivate "qq.exe"
这一句,如果这样,始终不会起作用。必须用ProcessID
yiwuyun 发表于 2015-11-19 18:18



    如何解决呢?

楼上的vbs代码。有时候可以实现自动登录qq。。
就是成功概率比较低。。
作者: ygqiang    时间: 2015-11-23 09:14

  1. RunAsAdminstrator
  2. Function GetQQPath()
  3.   Const HKEY_LOCAL_MACHINE = &H80000002
  4.   Dim s, sREG, sDis, sPath, oReg, fso
  5.   sPath = ""
  6.   Set fso = CreateObject("Scripting.FileSystemObject")
  7.   Set Wss = CreateObject("Wscript.Shell")
  8.   Set oReg = GetObject("Winmgmts:\\.\Root\Default:StdRegProv")
  9.   sREG = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall"
  10.   oReg.EnumKey HKEY_LOCAL_MACHINE, sREG, s
  11.   If IsNull(s) = False Then
  12.     For i = 0 To Ubound(s)
  13.       oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "DisplayName", sDis
  14.       If Ucase(sDis) = "腾讯QQ" Then
  15.         oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "InstallLocation", sPath
  16.       End If
  17.     Next
  18.   End If
  19.   sREG = "SOFTWARE\Wow6432Node\Microsoft\Windows\CurrentVersion\Uninstall"
  20.   oReg.EnumKey HKEY_LOCAL_MACHINE, sREG, s
  21.   If IsNull(s) = False Then
  22.     For i = 0 To Ubound(s)
  23.       oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "DisplayName", sDis
  24.       If Ucase(sDis) = "腾讯QQ" Then
  25.         oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "InstallLocation", sPath
  26.       End If
  27.     Next
  28.   End If
  29.   If sPath = "" Then
  30.     'MsgBox "未找到 腾讯QQ 的注册表路径", 4096
  31.     'CreateObject("Wscript.Shell").Popup "未找到 腾讯QQ 的注册表路径", 5
  32.     Wss.Popup "未找到 腾讯QQ 的注册表路径", 5
  33.     WScript.Quit(1)
  34.   Else
  35.     GetQQPath = fso.BuildPath(sPath, "Bin\QQ.exe")
  36.     If fso.FileExists(GetQQPath) = False Then
  37.       'MsgBox "未找到 " & GetQQPath, 4096
  38.       'CreateObject("Wscript.Shell").Popup "未找到 " & GetQQPath, 5
  39.       Wss.Popup "未找到 " & GetQQPath, 5
  40.       WScript.Quit(2)
  41.     End If
  42.   End If
  43. End Function
  44. Sub RunAsAdminstrator()
  45.     Dim shell, os, arg, ver
  46.     Set shell = CreateObject("Shell.Application")
  47.    
  48.     For Each os In GetObject("WinMgmts:").InstancesOf("Win32_OperatingSystem")
  49.         ver = Left(os.Version, 3)
  50.     Next
  51.     If ver <> "6.1" And ver <> "6.0" And ver <> "6.3" Then Exit Sub
  52.    
  53.     For Each arg In WScript.Arguments.Named
  54.         If LCase(arg) = "uac" Then Exit Sub
  55.     Next
  56.    
  57.     Shell.ShellExecute "wscript.exe", Chr(34) & _
  58.     WScript.ScriptFullName & Chr(34) & " /uac", "", "runas", 1
  59.     WScript.Quit
  60. End Sub
  61. '定义QQ程序路径、帐号、密码
  62. Dim Program1,a,b,c
  63. Program1 = GetQQPath()
  64. 'MsgBox Program1
  65. Set WshShell=createobject("wscript.shell")
  66. '运行QQ主程序
  67. Set oExec=WshShell.Exec(Program1)
  68. WScript.Sleep 5000
  69. '激活QQ窗口
  70. WshShell.SendKeys "{TAB}"
  71. WshShell.SendKeys "{TAB}"
  72. WshShell.SendKeys "{TAB}"
  73. WshShell.SendKeys "{TAB}"
  74. WshShell.SendKeys "{TAB}"
  75. WshShell.SendKeys "{TAB}"
  76. WshShell.SendKeys "{TAB}"
  77. WshShell.SendKeys "{TAB}"
  78. WshShell.SendKeys "{TAB}"
  79. WshShell.SendKeys "{TAB}"
  80. WshShell.SendKeys "{TAB}"
  81. WScript.Sleep 3000
  82. '输入帐号
  83. a="qq帐号"
  84. WshShell.SendKeys a
  85. WScript.Sleep 1000
  86. WshShell.SendKeys "{TAB}"
  87. '输入帐号
  88. a="qq帐号"
  89. WshShell.SendKeys a
  90. WScript.Sleep 1000
  91. WshShell.SendKeys "{TAB}"
  92. WScript.Sleep 2000
  93. '输入帐号
  94. a="qq帐号"
  95. WshShell.SendKeys a
  96. WScript.Sleep 1000
  97. WshShell.SendKeys "{ENTER}"
  98. WScript.Sleep 1000
  99. '输入密码
  100. b="qq密码"
  101. WshShell.SendKeys b
  102. WScript.Sleep 2000
  103. WshShell.SendKeys "{ENTER}"
复制代码
更新下。。。最终解决代码。。。。
作者: erjnasrtnws    时间: 2015-12-30 08:16

回复 7# ygqiang


    好强大
作者: zhangop9    时间: 2022-3-20 14:59

GetQQPath()




欢迎光临 批处理之家 (http://bbs.bathome.net/) Powered by Discuz! 7.2