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. 

  62. '定义QQ程序路径、帐号、密码 

  63. Dim Program1,a,b,c 

  64. Program1 = GetQQPath()

  65. 'MsgBox Program1

  66. Set WshShell=createobject("wscript.shell") 

  67. '运行QQ主程序 

  68. Set oExec=WshShell.Exec(Program1) 

  69. WScript.Sleep 5000 

  70. '激活QQ窗口 

  71. WshShell.AppActivate "qq" 

  72. wshShell.SendKeys "+{TAB}" 

  73. WScript.Sleep 2000 

  74. '输入帐号 

  75. a="24545640" 

  76. WshShell.SendKeys a 

  77. WScript.Sleep 1000 

  78. WshShell.SendKeys "{TAB}" 

  79. '输入帐号 

  80. a="24545640" 

  81. WshShell.SendKeys a 

  82. WScript.Sleep 1000 

  83. WshShell.SendKeys "{TAB}" 

  84. WScript.Sleep 2000 

  85. '输入密码 

  86. b="245756" 

  87. WshShell.SendKeys b 

  88. WScript.Sleep 2000 

  89. 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. 

  45. Sub RunAsAdminstrator() 

  46.     Dim shell, os, arg, ver

  47.     Set shell = CreateObject("Shell.Application")

  48.     

  49.     For Each os In GetObject("WinMgmts:").InstancesOf("Win32_OperatingSystem")

  50.         ver = Left(os.Version, 3)

  51.     Next

  52.     If ver <> "6.1" And ver <> "6.0" And ver <> "6.3" Then Exit Sub

  53.     

  54.     For Each arg In WScript.Arguments.Named

  55.         If LCase(arg) = "uac" Then Exit Sub

  56.     Next

  57.     

  58.     Shell.ShellExecute "wscript.exe", Chr(34) & _

  59.     WScript.ScriptFullName & Chr(34) & " /uac", "", "runas", 1

  60.     WScript.Quit

  61. End Sub

  62. 

  63. 

  64. '定义QQ程序路径、帐号、密码 

  65. Dim Program1,a,b,c 

  66. 

  67. Program1 = GetQQPath()

  68. 'MsgBox Program1

  69. Set WshShell=createobject("wscript.shell") 

  70. 

  71. '运行QQ主程序 

  72. Set oExec=WshShell.Exec(Program1) 

  73. WScript.Sleep 5000 

  74. 

  75. '激活QQ窗口 

  76. 'WshShell.AppActivate "qq.exe" 

  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. WshShell.SendKeys "{TAB}" 

  84. WshShell.SendKeys "{TAB}" 

  85. WshShell.SendKeys "{TAB}" 

  86. WshShell.SendKeys "{TAB}" 

  87. WshShell.SendKeys "{TAB}" 

  88. WshShell.SendKeys "{TAB}" 

  89. WScript.Sleep 3000 

  90. 

  91. '输入帐号 

  92. a="24545640" 

  93. WshShell.SendKeys a 

  94. WScript.Sleep 1000 

  95. WshShell.SendKeys "{TAB}" 

  96. 

  97. '输入帐号 

  98. a="24545640" 

  99. WshShell.SendKeys a 

  100. WScript.Sleep 1000 

  101. WshShell.SendKeys "{TAB}" 

  102. WScript.Sleep 2000 

  103. 

  104. 

  105. '输入密码 

  106. b="245756" 

  107. WshShell.SendKeys b 

  108. WScript.Sleep 2000

  109. 

  110. 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. 

  45. Sub RunAsAdminstrator() 

  46.     Dim shell, os, arg, ver

  47.     Set shell = CreateObject("Shell.Application")

  48.     

  49.     For Each os In GetObject("WinMgmts:").InstancesOf("Win32_OperatingSystem")

  50.         ver = Left(os.Version, 3)

  51.     Next

  52.     If ver <> "6.1" And ver <> "6.0" And ver <> "6.3" Then Exit Sub

  53.     

  54.     For Each arg In WScript.Arguments.Named

  55.         If LCase(arg) = "uac" Then Exit Sub

  56.     Next

  57.     

  58.     Shell.ShellExecute "wscript.exe", Chr(34) & _

  59.     WScript.ScriptFullName & Chr(34) & " /uac", "", "runas", 1

  60.     WScript.Quit

  61. End Sub

  62. 

  63. 

  64. '定义QQ程序路径、帐号、密码 

  65. Dim Program1,a,b,c 

  66. 

  67. Program1 = GetQQPath()

  68. 'MsgBox Program1

  69. Set WshShell=createobject("wscript.shell") 

  70. 

  71. '运行QQ主程序 

  72. Set oExec=WshShell.Exec(Program1) 

  73. WScript.Sleep 5000 

  74. 

  75. '激活QQ窗口 

  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. WshShell.SendKeys "{TAB}" 

  84. WshShell.SendKeys "{TAB}" 

  85. WshShell.SendKeys "{TAB}" 

  86. WshShell.SendKeys "{TAB}" 

  87. WScript.Sleep 3000 

  88. 

  89. '输入帐号 

  90. a="qq帐号" 

  91. WshShell.SendKeys a 

  92. WScript.Sleep 1000 

  93. WshShell.SendKeys "{TAB}" 

  94. 

  95. '输入帐号 

  96. a="qq帐号" 

  97. WshShell.SendKeys a 

  98. WScript.Sleep 1000 

  99. WshShell.SendKeys "{TAB}" 

  100. WScript.Sleep 2000 

  101. 

  102. 

  103. '输入帐号 

  104. a="qq帐号" 

  105. WshShell.SendKeys a 

  106. WScript.Sleep 1000 

  107. WshShell.SendKeys "{ENTER}" 

  108. WScript.Sleep 1000

  109. 

  110. 

  111. '输入密码 

  112. b="qq密码" 

  113. WshShell.SendKeys b 

  114. WScript.Sleep 2000

  115. 

  116. 

  117. 

  118. 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