[技术讨论] vbs获取系统/IE/DirectX/MediaPlaye/Flash插件/MSXML及各种运行库的版本及安装情况

czjt1234

请测试

Wscript.Echo QueryWinVer()   & vbCrLf & QueryDirectX()  & vbCrLf & _
             QueryIEVer()    & vbCrLf & QueryFlashVer() & vbCrLf & _
             QueryMediaVer() & vbCrLf & QueryVC20xx()   & vbCrLf & _
             QueryXML()      & vbCrLf & QueryNET()
 
'By QQ20147578 2014-05-03
 
Function QueryWinVer()
    '查询WMI的Win32_OperatingSystem和Win32_ComputerSystem，读取操作系统版本
    Dim objSWbemServices, objSWbemObject
    Set objSWbemServices = GetObject("Winmgmts:\\.\Root\Cimv2")
    For Each objSWbemObject In objSWbemServices.InstancesOf("Win32_OperatingSystem")
        QueryWinVer = objSWbemObject.Caption & " " & objSWbemObject.CSDVersion
    Next
    QueryWinVer = QueryWinVer & vbCrLf
    For Each objSWbemObject In objSWbemServices.InstancesOf("Win32_ComputerSystem")
        If InStr(objSWbemObject.SystemType, "86") > 0 Then
            QueryWinVer = QueryWinVer & "32位 操作系统"
        ElseIf InStr(objSWbemObject.SystemType, "64") > 0 Then
            QueryWinVer = QueryWinVer & "64位 操作系统"
        Else
            QueryWinVer = QueryWinVer & objSWbemObject.SystemType
        End If
    Next
    QueryWinVer = QueryWinVer & vbCrLf
End Function
 
Function QueryDirectX()
    '读取C:\Windows\System32\dxdiag.exe的文件版本，判断DirectX版本
    '读取C:\Windows\System32\XAudio2_7.dll的文件版本，判断DirectX最终用户运行时版本
    Dim s, objFSO, objWshShell
    Set objFSO      = CreateObject("Scripting.FileSystemObject")
    Set objWshShell = CreateObject("Wscript.Shell")
    s = objWshShell.ExpandEnvironmentStrings("%SystemRoot%\System32\dxdiag.exe")
    If objFSO.FileExists(s) = False Then
        QueryDirectX = "未能找到 dxdiag.exe 文件，DirectX 版本 查询失败"
    Else
        s = objFSO.GetFileVersion(s)
        If s < "4.09.00.0904" Then
            QueryDirectX = "DirectX 版本 低于 DirectX 9.0C"
        ElseIf s < "6.0" Then
            QueryDirectX = "DirectX 9.0C"
        ElseIf s < "6.1" Then
            QueryDirectX = "DirectX 10"
        Else
            QueryDirectX = "DirectX 11"
        End If
    End If
    QueryDirectX = QueryDirectX & vbCrLf
    s = objWshShell.ExpandEnvironmentStrings("%SystemRoot%\System32\XAudio2_7.dll")
    If objFSO.FileExists(s) = False Then
        QueryDirectX = QueryDirectX & "DirectX 最终用户运行时 2010.6 未安装"
    ElseIf objFSO.GetFileVersion(s) = "9.29.1962.0" Then
        QueryDirectX = QueryDirectX & "DirectX 最终用户运行时 2010.6 已安装"
    Else
        QueryDirectX = QueryDirectX & "DirectX 最终用户运行时 已安装 版本未知"
    End If
    QueryDirectX = QueryDirectX & vbCrLf
End Function
 
Function QueryIEVer()
    '读取C:\Program Files\Internet Explorer\iexplore.exe的文件版本，判断IE版本
    '如果读取注册表，注意IE6~11的版本号分别是6.0  7.0  8.0  9.0  9.10  9.11
    Dim s, objFSO, objWshShell
    Set objFSO      = CreateObject("Scripting.FileSystemObject")
    Set objWshShell = CreateObject("Wscript.Shell")
    s = objWshShell.ExpandEnvironmentStrings("%ProgramFiles%\Internet Explorer\iexplore.exe")
    If objFSO.FileExists(s) = False Then
        QueryIEVer = "未能找到 iexplore.exe 文件，Internet Explorer 版本 查询失败"
    Else
        s = Split(objFSO.GetFileVersion(s), ".")
        QueryIEVer = "Internet Explorer " & s(0)
    End If
    QueryIEVer = QueryIEVer & vbCrLf
End Function
 
Function QueryMediaVer()
    '读取C:\Program Files\Windows Media Player\wmplayer.exe的文件版本，判断MediaPlayer版本
    Dim s, objFSO, objWshShell
    Set objFSO      = CreateObject("Scripting.FileSystemObject")
    Set objWshShell = CreateObject("Wscript.Shell")
    s = objWshShell.ExpandEnvironmentStrings("%ProgramFiles%\Windows Media Player\wmplayer.exe")
    If objFSO.FileExists(s) = False Then
        QueryMediaVer = "未能找到 wmplayer.exe 文件，MediaPlayer 版本 查询失败"
    Else
        s = Split(objFSO.GetFileVersion(s), ".")
        QueryMediaVer = "Media Player " & s(0)
    End If
    QueryMediaVer = QueryMediaVer & vbCrLf
End Function
 
Function QueryFlashVer()
    '查询HKLM\SOFTWARE\Macromedia\FlashPlayerActiveX\Version，判断Flash版本
    '不要读取 "添加删除程序" 的注册表信息，比如win8.1集成Flash插件，Uninstall里面不显示
    'Const HKEY_LOCAL_MACHINE = &H80000002
    Dim s, objSWbemObject
    Set objSWbemObject = GetObject("Winmgmts:\\.\Root\Default:StdRegProv")
    objSWbemObject.GetStringValue &H80000002, "SOFTWARE\Macromedia\FlashPlayerActiveX", "Version", s
    If IsNull(s) Then
        QueryFlashVer = "Flash Player 版本 注册表查询 失败"
    Else
        QueryFlashVer = "Flash Player " & s
    End If
    QueryFlashVer = QueryFlashVer & vbCrLf
End Function
 
Function QueryVC20xx()
    '读取 "添加删除程序" 里的 VC++ 运行库的安装信息
    '注册表：HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall
    '注册表：HKLM\SOFTWARE\Wow6432Node\Microsoft\Windows\CurrentVersion\Uninstall
    'Const HKEY_LOCAL_MACHINE = &H80000002
    Dim s, sREG, sDis, sVer, i, j, arr, newarr, objReg
    QueryVC20xx = ""
    Set objReg = GetObject("Winmgmts:\\.\Root\Default:StdRegProv")
    sREG = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall"
    objReg.EnumKey &H80000002, sREG, s
    If IsNull(s) = False Then
        For i = 0 To Ubound(s)
            If InStr(s(i), "{") > 0 Then
                objReg.GetStringValue &H80000002, sREG & "\" & s(i), "DisplayName", sDis
                If InStr(sDis, "Microsoft Visual C++") > 0 And InStr(sDis, "Redistributable") > 0 Then
                    If InStr(sDis, "Microsoft Visual C++ 2005") > 0 Then
                        objReg.GetStringValue &H80000002, sREG & "\" & s(i), "DisplayVersion", sVer
                        QueryVC20xx = QueryVC20xx & sDis & " " & sVer & vbCrLf
                    Else
                        QueryVC20xx = QueryVC20xx & sDis & vbCrLf
                    End If
                End If
            End If
        Next
    End If
    sREG = "SOFTWARE\Wow6432Node\Microsoft\Windows\CurrentVersion\Uninstall"
    objReg.EnumKey &H80000002, sREG, s
    If IsNull(s) = False Then
        For i = 0 To Ubound(s)
            If InStr(s(i), "{") > 0 Then
                objReg.GetStringValue &H80000002, sREG & "\" & s(i), "DisplayName", sDis
                If InStr(sDis, "Microsoft Visual C++") > 0 And InStr(sDis, "Redistributable") > 0 Then
                    If InStr(sDis, "Microsoft Visual C++ 2005") > 0 Then
                        objReg.GetStringValue &H80000002, sREG & "\" & s(i), "DisplayVersion", sVer
                        QueryVC20xx = QueryVC20xx & sDis & " (x86) " & sVer & vbCrLf
                    Else
                        QueryVC20xx = QueryVC20xx & sDis & vbCrLf
                    End If
                End If
            End If
        Next
    End If
    If QueryVC20xx = "" Then
        QueryVC20xx = "未检测到 VC++ 运行库 安装信息" & vbCrLf
        Exit Function
    End If
    '下面是排序，忽略大小写
    arr = Split(QueryVC20xx, vbCrLf)
    Redim newarr(UBound(arr))
    newarr(0) = arr(0)
    For i = 1 To UBound(arr)
        For j = 0 To i
            If Lcase(arr(i)) > Lcase(newarr(j)) Then
                s = newarr(j)
                newarr(j) = arr(i)
                arr(i) = s
            End If
        Next
    Next
    For i = 0 To UBound(arr)
        arr(i) = newarr(UBound(arr) - i)
    Next
    '用VC替代Microsoft Visual C++，否则Win7系统显示字符数过多会自动换行
    QueryVC20xx = "已安装VC运行库:" & RePlace(Join(arr, vbCrLf), "Microsoft Visual C++", "VC")
    QueryVC20xx = QueryVC20xx & vbCrLf
End Function
 
Function QueryXML()
    'MSXML3  HKCR\CLSID\{F5078F32-C551-11D3-89B9-0000F81FE221}
    'MSXML4  HKCR\CLSID\{88D969C0-F192-11D4-A65F-0040963251E5}
    'MSXML5  HKCR\CLSID\{88D969E5-F192-11D4-A65F-0040963251E5}
    'MSXML6  HKCR\CLSID\{88d96a05-f192-11d4-a65f-0040963251e5}
    '读取注册表，判断对应版本的MSXML的安装信息
    'Const HKEY_CLASSES_ROOT = &H80000000
    Dim s, sREG, objSWbemObject
    QueryXML = ""
    Set objSWbemObject = GetObject("Winmgmts:\\.\Root\Default:StdRegProv")
    sREG = "CLSID\{F5078F32-C551-11D3-89B9-0000F81FE221}\InProcServer32"
    objSWbemObject.GetStringValue &H80000000, sREG, "", s
    If IsNull(s) Then
        QueryXML = QueryXML & "MSXML 3   未安装" & vbCrLf
    Else
        QueryXML = QueryXML & "MSXML 3   " & s & vbCrLf
    End If
    sREG = "CLSID\{88D969C0-F192-11D4-A65F-0040963251E5}\InProcServer32"
    objSWbemObject.GetStringValue &H80000000, sREG, "", s
    If IsNull(s) Then
        QueryXML = QueryXML & "MSXML 4   未安装  (已被 MSXML6 替代)" & vbCrLf
    Else
        QueryXML = QueryXML & "MSXML 4   " & s & vbCrLf
    End If
    sREG = "CLSID\{88D969E5-F192-11D4-A65F-0040963251E5}\InProcServer32"
    objSWbemObject.GetStringValue &H80000000, sREG, "", s
    If IsNull(s) Then
        QueryXML = QueryXML & "MSXML 5   未安装  (office 软件专用 )" & vbCrLf
    Else
        QueryXML = QueryXML & "MSXML 5   " & s & vbCrLf
    End If
    sREG = "CLSID\{88d96a05-f192-11d4-a65f-0040963251e5}\InProcServer32"
    objSWbemObject.GetStringValue &H80000000, sREG, "", s
    If IsNull(s) Then
        QueryXML = QueryXML & "MSXML 6   未安装" & vbCrLf
    Else
        QueryXML = QueryXML & "MSXML 6   " & s & vbCrLf
    End If
    If QueryXML = "" Then QueryXML = "未检测到 MSXML 安装信息" & vbCrLf
End Function
 
Function QueryNET()
    'HKLM\SOFTWARE\Microsoft\NET Framework Setup\NDP
    '读取注册表，判断 .NET Framework 的安装信息
    'Const HKEY_LOCAL_MACHINE = &H80000002
    Dim s, sREG, sVer, i, objReg
    QueryNET = "已安装 .NET Framework :" & vbCrLf
    Set objReg = GetObject("Winmgmts:\\.\Root\Default:StdRegProv")
    sREG = "SOFTWARE\Microsoft\NET Framework Setup\NDP"
    objReg.EnumKey &H80000002, sREG, s
    If IsNull(s) Then
        QueryNET = "未检测到 .NET Framework 安装信息" & vbCrLf
        Exit Function
    End If
    For i = 0 To Ubound(s)
        If Lcase(Left(s(i), 1)) <> "v" Then
            '
        ElseIf Lcase(s(i)) = "v4" Then
            objReg.GetStringValue &H80000002, sREG & "\v4\Client", "Version", sVer
            QueryNET = QueryNET & "v" & sVer & vbCrLf
        Else
            objReg.GetDWORDValue &H80000002, sREG & "\" & s(i), "SP", sVer
            If IsNull(sVer) Then
                objReg.GetDWORDValue &H80000002, sREG & "\" & s(i) & "\Client", "SP", sVer
                If IsNull(sVer) Then
                    QueryNET = QueryNET & s(i) & vbCrLf
                Else
                    QueryNET = QueryNET & s(i) & " SP" & sVer & vbCrLf
                End If
            Else
                QueryNET = QueryNET & s(i) & " SP" & sVer & vbCrLf
            End If
        End If
    Next
    QueryNET = QueryNET & vbCrLf
End Function
 
'参考文档:
'DirectX 简介和版本         http://zh.wikipedia.org/wiki/DirectX
'用VBS判断x86或x64系统      http://demon.tw/programming/vbs-x86-x64.html
'win7系统Msgbox输出自动换行 http://blogs.msdn.com/b/oldnewthing/archive/2011/06/24/10178386.aspx
'WMI 操作注册表详解         http://hi.baidu.com/350078238/item/0f62f9104e107b6e71d5e88dCOPY