Board logo

标题: [问题求助] [已解决]xp/win7系统下，vbs如何获取qq安装路径？并赋值给变量？ [打印本页]
作者: ygqiang    时间: 2015-5-5 23:23     标题: [已解决]xp/win7系统下，vbs如何获取qq安装路径？并赋值给变量？

本帖最后由 ygqiang 于 2015-5-6 19:27 编辑

[已解决]xp/win7系统下，vbs如何获取qq安装路径？并赋值给变量？
另外，下面的vbs代码，能否进一步简化？
  1. '定义QQ程序路径、帐名、密码 

  2. Dim Program1,a,b 

  3. Program1= "qq路径" 

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

  5. '运行QQ主程序 

  6. Set oExec=WshShell.Exec(Program1) 

  7. WScript.Sleep 3000 

  8. '激活QQ窗口 

  9. WshShell.AppActivate "qq" 

  10. wshShell.SendKeys "+{TAB}" 

  11. '输入帐号 

  12. a="qq号码" 

  13. WshShell.SendKeys a 

  14. WScript.Sleep 1000 

  15. WshShell.SendKeys "{TAB}" 

  16. '输入帐号 

  17. a="qq号码" 

  18. WshShell.SendKeys a 

  19. WScript.Sleep 1000 

  20. WshShell.SendKeys "{TAB}" 

  21. WScript.Sleep 1000 

  22. '输入密码 

  23. b="qq密码" 

  24. WshShell.SendKeys b 

  25. WScript.Sleep 1000 

  26. WshShell.SendKeys "{ENTER}" 
复制代码
qq路径，以下情况都有可能：
C:\Program Files\Tencent\QQ\Bin\QQ.exe
C:\Program Files (x86)\Tencent\QQ\Bin\QQ.exe
D:\Program Files\Tencent\QQ\Bin\QQ.exe
D:\xxx\???\QQ.exe
作者: CrLf    时间: 2015-5-5 23:37

如果是正常安装的官方版本，可以试试这个：
  1. for /f "tokens=1* delims==" %%a in ('ftype Tencent') do echo %%~dpbQQ.exe
复制代码
实测 QQ7.1 有效，不确定是否通用于 TM、QQ国际版或其他版本 QQ
作者: ygqiang    时间: 2015-5-5 23:42

[quote]如果是正常安装的官方版本，可以试试这个：实测 QQ7.1 有效，不确定是否通用于 TM、QQ国际版或其他版本 QQ
CrLf 发表于 2015-5-5 23:37 %
作者: ygqiang    时间: 2015-5-5 23:43

如果是正常安装的官方版本，可以试试这个：实测 QQ7.1 有效，不确定是否通用于 TM、QQ国际版或其他版本 QQ
CrLf 发表于 2015-5-5 23:37



多谢。。win7 64系统下，测试了下。。好用。。。

不过你这个是bat代码。。。不是vbs的。。。
作者: CrLf    时间: 2015-5-6 00:12

回复 4# ygqiang


vbs 原理一样：
  1. Set fso = WScript.CreateObject("Scripting.Filesystemobject")

  2. Set WS = CreateObject("Wscript.Shell")

  3. 

  4. Tencent = WS.RegRead("HKEY_CLASSES_ROOT\Tencent\shell\open\command\")

  5. QQ = Replace(Tencent,"""","")

  6. QQ = fso.GetFolder(QQ&"\..")&"\QQ.exe"

  7. 

  8. MsgBox QQ
复制代码
作者: ygqiang    时间: 2015-5-6 06:25

回复 5# CrLf


    多谢。。。。。下面这个vbs代码，是否有进一步简化的可能。。。。
  1. Dim Program1,a,b 

  2. Set fso = WScript.CreateObject("Scripting.Filesystemobject")

  3. Set WshShell = CreateObject("Wscript.Shell")

  4. Tencent = WshShell.RegRead("HKEY_CLASSES_ROOT\Tencent\shell\open\command\")

  5. Program1 = Replace(Tencent,"""","")

  6. Program1 = fso.GetFolder(Program1&"\..")&"\QQ.exe"

  7. 'MsgBox Program1

  8. 

  9. 

  10. '运行QQ主程序 

  11. Set oExec=WshShell.Exec(Program1) 

  12. WScript.Sleep 3000 

  13. '激活QQ窗口 

  14. WshShell.AppActivate "qq" 

  15. wshShell.SendKeys "+{TAB}" 

  16. '输入帐号 

  17. a="qq号码" 

  18. WshShell.SendKeys a 

  19. WScript.Sleep 1000 

  20. WshShell.SendKeys "{TAB}" 

  21. '输入帐号 

  22. a="qq号码" 

  23. WshShell.SendKeys a 

  24. WScript.Sleep 1000 

  25. WshShell.SendKeys "{TAB}" 

  26. WScript.Sleep 1000 

  27. '输入密码 

  28. b="qq密码" 

  29. WshShell.SendKeys b 

  30. WScript.Sleep 1000 

  31. WshShell.SendKeys "{ENTER}" 
复制代码
作者: gawk    时间: 2015-5-6 08:46

回复 6# ygqiang


    “输入帐号”写两遍有啥原因吗
作者: ygqiang    时间: 2015-5-6 10:25

回复 7# gawk


装最新版本qq，  如果只输入1次。。测试过。不行。。。
作者: ygqiang    时间: 2015-5-6 12:51

回复 5# CrLf


    初步解决了。。。

情况1（如果已经确定装了qq软件）————————————————————————————————————
  1. '定义QQ程序路径、帐名、密码 

  2. Dim Program1,a,b

  3. 

  4. Set fso = WScript.CreateObject("Scripting.Filesystemobject")

  5. Set WshShell = CreateObject("Wscript.Shell")

  6. Tencent = WshShell.RegRead("HKEY_CLASSES_ROOT\Tencent\shell\open\command\")

  7. Program1 = Replace(Tencent,"""","")

  8. Program1 = fso.GetFolder(Program1&"\..")&"\QQ.exe"

  9. 'MsgBox Program1

  10. 

  11. '运行QQ主程序 

  12. Set oExec=WshShell.Exec(Program1) 

  13. WScript.Sleep 3000 

  14. '激活QQ窗口 

  15. WshShell.AppActivate "qq" 

  16. WScript.Sleep 1000 

  17. wshShell.SendKeys "+{TAB}" 

  18. WScript.Sleep 1000 

  19. '输入帐号 

  20. a="273088140" 

  21. WshShell.SendKeys a 

  22. WScript.Sleep 1000 

  23. WshShell.SendKeys "{TAB}" 

  24. '输入帐号 

  25. a="273088140" 

  26. WshShell.SendKeys a 

  27. WScript.Sleep 1000 

  28. WshShell.SendKeys "{TAB}" 

  29. WScript.Sleep 2000 

  30. '输入密码 

  31. b="ygq$2008" 

  32. WshShell.SendKeys b 

  33. WScript.Sleep 1000 

  34. WshShell.SendKeys "{ENTER}" 
复制代码
作者: ygqiang    时间: 2015-5-6 12:51

回复 5# CrLf  

情况2（如果不确定是否装了qq软件）————————————————————————————————————
  1. Function GetQQPath()

  2.   Const HKEY_LOCAL_MACHINE = &H80000002

  3.   Dim s, sREG, sDis, sPath, oReg, fso

  4.   sPath = ""

  5.   Set fso = CreateObject("Scripting.FileSystemObject")

  6.   Set oReg = GetObject("Winmgmts:\\.\Root\Default:StdRegProv")

  7.   sREG = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall"

  8.   oReg.EnumKey HKEY_LOCAL_MACHINE, sREG, s

  9.   If IsNull(s) = False Then

  10.     For i = 0 To Ubound(s)

  11.       oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "DisplayName", sDis

  12.       If Ucase(sDis) = "腾讯QQ" Then

  13.         oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "InstallLocation", sPath

  14.       End If

  15.     Next

  16.   End If

  17.   sREG = "SOFTWARE\Wow6432Node\Microsoft\Windows\CurrentVersion\Uninstall"

  18.   oReg.EnumKey HKEY_LOCAL_MACHINE, sREG, s

  19.   If IsNull(s) = False Then

  20.     For i = 0 To Ubound(s)

  21.       oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "DisplayName", sDis

  22.       If Ucase(sDis) = "腾讯QQ" Then

  23.         oReg.GetStringValue HKEY_LOCAL_MACHINE, sREG & "\" & s(i), "InstallLocation", sPath

  24.       End If

  25.     Next

  26.   End If

  27.   If sPath = "" Then

  28.     MsgBox "未找到 腾讯QQ 的注册表路径", 4096

  29.     WScript.Quit(1)

  30.   Else

  31.     GetQQPath = fso.BuildPath(sPath, "Bin\QQ.exe")

  32.     If fso.FileExists(GetQQPath) = False Then

  33.       MsgBox "未找到 " & GetQQPath, 4096

  34.       WScript.Quit(2)

  35.     End If

  36.   End If

  37. End Function

  38. 

  39. 

  40. 

  41. '定义QQ程序路径、帐名、密码 

  42. Dim Program1,a,b 

  43. 

  44. Program1 = GetQQPath()

  45. 'MsgBox Program1

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

  47. 

  48. '运行QQ主程序 

  49. Set oExec=WshShell.Exec(Program1) 

  50. WScript.Sleep 3000 

  51. '激活QQ窗口 

  52. WshShell.AppActivate "qq" 

  53. wshShell.SendKeys "+{TAB}" 

  54. WScript.Sleep 1000 

  55. '输入帐号 

  56. a="273088140" 

  57. WshShell.SendKeys a 

  58. WScript.Sleep 1000 

  59. WshShell.SendKeys "{TAB}" 

  60. '输入帐号 

  61. a="273088140" 

  62. WshShell.SendKeys a 

  63. WScript.Sleep 1000 

  64. WshShell.SendKeys "{TAB}" 

  65. WScript.Sleep 2000 

  66. '输入密码 

  67. b="ygq$2008" 

  68. WshShell.SendKeys b 

  69. WScript.Sleep 1000 

  70. WshShell.SendKeys "{ENTER}" 
复制代码
如果没有装qq。会弹出这个对话框，
能否修改下vbs代码。设置：倒计时5秒后自动关闭对话框。。
作者: pcl_test    时间: 2015-5-6 13:04

回复 10# ygqiang

MsgBox "未找到 腾讯QQ 的注册表路径", 4096改为
CreateObject("Wscript.Shell").Popup "未找到 腾讯QQ 的注册表路径", 5
作者: ygqiang    时间: 2015-5-6 13:13

回复  ygqiang


    “输入帐号”写两遍有啥原因吗
gawk 发表于 2015-5-6 08:46




为啥要输入2次qq号码??

应该是按键后用于获取焦点之类的
估计是第一次用于获取焦点..第一次可以只直接随意输入一个按键..
然后再输入账号。。
作者: zz100001    时间: 2015-5-6 16:13

你这是在弄QQ自动登陆吗？
找马化腾协商一下，弄个命令行接口不是最简单。。。。
下面是一个启动指定QQ号的vbs代码，你可以试试，密码还得自己输
（账号可以是邮箱的）
  1. ' 创建QQ自带的对象

  2. Set c = WScript.CreateObject("QQCPHelper.CPAdder")

  3. ' 启动QQ并指定一个号码

  4. c.StartupIM "273088140"
复制代码
作者: CrLf    时间: 2015-5-6 16:45

回复 13# zz100001


    补充一下，QQ 和 TM 都支持命令行参数，例如：
  1. "C:\Program Files\Tencent\TM\Bin\TM.exe" /uin:10000
复制代码
作者: czjt1234    时间: 2015-5-6 17:15

回复 13# zz100001


   赞一个
作者: ygqiang    时间: 2015-5-11 11:39

最终修改后的解决方案：
  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 3000 

  74. '激活QQ窗口 

  75. WshShell.AppActivate "qq" 

  76. wshShell.SendKeys "+{TAB}" 

  77. WScript.Sleep 1000 

  78. '输入帐号 

  79. a="qq帐号" 

  80. WshShell.SendKeys a 

  81. WScript.Sleep 1000 

  82. WshShell.SendKeys "{TAB}" 

  83. '输入帐号 

  84. a="qq帐号" 

  85. WshShell.SendKeys a 

  86. WScript.Sleep 1000 

  87. WshShell.SendKeys "{TAB}" 

  88. WScript.Sleep 2000 

  89. '输入密码 

  90. b="qq密码前半部分" 

  91. WshShell.SendKeys b 

  92. WScript.Sleep 2000 

  93. 

  94. '输入密码 

  95. c="qq密码后半部分" 

  96. WshShell.SendKeys c 

  97. WScript.Sleep 1000 

  98. 

  99. WshShell.SendKeys "{ENTER}" 
复制代码




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