ygqiang

最终修改后的解决方案：

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 3000 
'激活QQ窗口 
WshShell.AppActivate "qq" 
wshShell.SendKeys "+{TAB}" 
WScript.Sleep 1000 
'输入帐号 
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 
'输入密码 
b="qq密码前半部分" 
WshShell.SendKeys b 
WScript.Sleep 2000 

'输入密码 
c="qq密码后半部分" 
WshShell.SendKeys c 
WScript.Sleep 1000 

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