[问题求助] [已解决]xp/win7系统下，vbs如何获取qq安装路径？并赋值给变量？

ygqiang

[已解决]xp/win7系统下，vbs如何获取qq安装路径？并赋值给变量？
另外，下面的vbs代码，能否进一步简化？

'定义QQ程序路径、帐名、密码 
Dim Program1,a,b 
Program1= "qq路径" 
Set WshShell=createobject("wscript.shell") 
'运行QQ主程序 
Set oExec=WshShell.Exec(Program1) 
WScript.Sleep 3000 
'激活QQ窗口 
WshShell.AppActivate "qq" 
wshShell.SendKeys "+{TAB}" 
'输入帐号 
a="qq号码" 
WshShell.SendKeys a 
WScript.Sleep 1000 
WshShell.SendKeys "{TAB}" 
'输入帐号 
a="qq号码" 
WshShell.SendKeys a 
WScript.Sleep 1000 
WshShell.SendKeys "{TAB}" 
WScript.Sleep 1000 
'输入密码 
b="qq密码" 
WshShell.SendKeys b 
WScript.Sleep 1000 
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

如果是正常安装的官方版本，可以试试这个：

for /f "tokens=1* delims==" %%a in ('ftype Tencent') do echo %%~dpbQQ.exe
复制代码

实测 QQ7.1 有效，不确定是否通用于 TM、QQ国际版或其他版本 QQ

ygqiang

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

ygqiang

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

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

不过你这个是bat代码。。。不是vbs的。。。

CrLf

回复 4# ygqiang


vbs 原理一样：

Set fso = WScript.CreateObject("Scripting.Filesystemobject")
Set WS = CreateObject("Wscript.Shell")

Tencent = WS.RegRead("HKEY_CLASSES_ROOT\Tencent\shell\open\command\")
QQ = Replace(Tencent,"""","")
QQ = fso.GetFolder(QQ&"\..")&"\QQ.exe"

MsgBox QQ
复制代码

ygqiang

回复 5# CrLf


    多谢。。。。。下面这个vbs代码，是否有进一步简化的可能。。。。

Dim Program1,a,b 
Set fso = WScript.CreateObject("Scripting.Filesystemobject")
Set WshShell = CreateObject("Wscript.Shell")
Tencent = WshShell.RegRead("HKEY_CLASSES_ROOT\Tencent\shell\open\command\")
Program1 = Replace(Tencent,"""","")
Program1 = fso.GetFolder(Program1&"\..")&"\QQ.exe"
'MsgBox Program1


'运行QQ主程序 
Set oExec=WshShell.Exec(Program1) 
WScript.Sleep 3000 
'激活QQ窗口 
WshShell.AppActivate "qq" 
wshShell.SendKeys "+{TAB}" 
'输入帐号 
a="qq号码" 
WshShell.SendKeys a 
WScript.Sleep 1000 
WshShell.SendKeys "{TAB}" 
'输入帐号 
a="qq号码" 
WshShell.SendKeys a 
WScript.Sleep 1000 
WshShell.SendKeys "{TAB}" 
WScript.Sleep 1000 
'输入密码 
b="qq密码" 
WshShell.SendKeys b 
WScript.Sleep 1000 
WshShell.SendKeys "{ENTER}" 
复制代码

gawk

回复 6# ygqiang


    “输入帐号”写两遍有啥原因吗

ygqiang

回复 7# gawk


装最新版本qq，  如果只输入1次。。测试过。不行。。。

ygqiang

回复 5# CrLf


    初步解决了。。。

情况1（如果已经确定装了qq软件）————————————————————————————————————

'定义QQ程序路径、帐名、密码 
Dim Program1,a,b

Set fso = WScript.CreateObject("Scripting.Filesystemobject")
Set WshShell = CreateObject("Wscript.Shell")
Tencent = WshShell.RegRead("HKEY_CLASSES_ROOT\Tencent\shell\open\command\")
Program1 = Replace(Tencent,"""","")
Program1 = fso.GetFolder(Program1&"\..")&"\QQ.exe"
'MsgBox Program1

'运行QQ主程序 
Set oExec=WshShell.Exec(Program1) 
WScript.Sleep 3000 
'激活QQ窗口 
WshShell.AppActivate "qq" 
WScript.Sleep 1000 
wshShell.SendKeys "+{TAB}" 
WScript.Sleep 1000 
'输入帐号 
a="273088140" 
WshShell.SendKeys a 
WScript.Sleep 1000 
WshShell.SendKeys "{TAB}" 
'输入帐号 
a="273088140" 
WshShell.SendKeys a 
WScript.Sleep 1000 
WshShell.SendKeys "{TAB}" 
WScript.Sleep 2000 
'输入密码 
b="ygq$2008" 
WshShell.SendKeys b 
WScript.Sleep 1000 
WshShell.SendKeys "{ENTER}" 
复制代码

ygqiang

回复 5# CrLf  

情况2（如果不确定是否装了qq软件）————————————————————————————————————

Function GetQQPath()
  Const HKEY_LOCAL_MACHINE = &H80000002
  Dim s, sREG, sDis, sPath, oReg, fso
  sPath = ""
  Set fso = CreateObject("Scripting.FileSystemObject")
  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
    WScript.Quit(1)
  Else
    GetQQPath = fso.BuildPath(sPath, "Bin\QQ.exe")
    If fso.FileExists(GetQQPath) = False Then
      MsgBox "未找到 " & GetQQPath, 4096
      WScript.Quit(2)
    End If
  End If
End Function



'定义QQ程序路径、帐名、密码 
Dim Program1,a,b 

Program1 = GetQQPath()
'MsgBox Program1
Set WshShell=createobject("wscript.shell") 

'运行QQ主程序 
Set oExec=WshShell.Exec(Program1) 
WScript.Sleep 3000 
'激活QQ窗口 
WshShell.AppActivate "qq" 
wshShell.SendKeys "+{TAB}" 
WScript.Sleep 1000 
'输入帐号 
a="273088140" 
WshShell.SendKeys a 
WScript.Sleep 1000 
WshShell.SendKeys "{TAB}" 
'输入帐号 
a="273088140" 
WshShell.SendKeys a 
WScript.Sleep 1000 
WshShell.SendKeys "{TAB}" 
WScript.Sleep 2000 
'输入密码 
b="ygq$2008" 
WshShell.SendKeys b 
WScript.Sleep 1000 
WshShell.SendKeys "{ENTER}" 
复制代码

如果没有装qq。会弹出这个对话框，
能否修改下vbs代码。设置：倒计时5秒后自动关闭对话框。。

pcl_test

回复 10# ygqiang

MsgBox "未找到 腾讯QQ 的注册表路径", 4096改为
CreateObject("Wscript.Shell").Popup "未找到 腾讯QQ 的注册表路径", 5

ygqiang

回复  ygqiang


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

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

应该是按键后用于获取焦点之类的
估计是第一次用于获取焦点..第一次可以只直接随意输入一个按键..
然后再输入账号。。

zz100001

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

' 创建QQ自带的对象
Set c = WScript.CreateObject("QQCPHelper.CPAdder")
' 启动QQ并指定一个号码
c.StartupIM "273088140"
复制代码

CrLf

回复 13# zz100001


    补充一下，QQ 和 TM 都支持命令行参数，例如：

"C:\Program Files\Tencent\TM\Bin\TM.exe" /uin:10000
复制代码

czjt1234

回复 13# zz100001


   赞一个