本程序从法国网站（http://www.VBFrance.com）上下载，摘取了其中一部分发现：这是岂今为止最全面的Windows版本、IE版本、32和64位操作系统信息获取程序。我修正了其中InfoVersionWinStd过程中的错误，并增加了 Windows 8 的版本识别；同时将2个标准模块封装到了类模块中。
本程序共2个类模块：WinSysInfo.cls，RegistryHandler
演示窗体 Form1窗体模块：
'在Form1上添加一文本框控件Text1
Option Explicit
Private Sub Form_Load()
Dim clsinfosys As WinSysInfo
Set clsinfosys = New WinSysInfo
With clsinfosys
Text1.Text = "操作系统版本：" & .WindowsVersion
Text1.Text = Text1.Text & vbCrLf & "IE浏览器版本：" & .IEVersion
End With
Set clsinfosys = Nothing
End Sub
类模块WinSysInfo.cls：
Option Explicit
'------------------------------------------------------------------------------'
' 类模块： WinSysInfo.cls '
'------------------------------------------------------------------------------'
Private Declare Function GetModuleHandle _
Lib "kernel32" _
Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function LoadLibraryEx _
Lib "kernel32" _
Alias "LoadLibraryExA" (ByVal lpLibFileName As String, _
ByVal hFile As Long, _
ByVal dwFlags As Long) As Long
Private Declare Function GetProcAddress _
Lib "kernel32" (ByVal hModule As Long, _
ByVal lpProcName As String) As Long
Private Declare Function FreeLibrary _
Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Const DONT_RESOLVE_DLL_REFERENCES As Long = &H1
'D閠ection m閐ia center
Private Declare Function GetSystemMetrics _
Lib "user32" (ByVal nIndex As Long) As Long
Private Const SM_MEDIACENTER = 87
'D閠ection version windows
Private Declare Function GetVersion _
Lib "kernel32" _
Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function GetVersionEx _
Lib "kernel32" _
Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFOEX) As Long
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Private Type OSVERSIONINFOEX
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128 ' Maintenance string for PSS usage
wSPMajor As Integer ' Service Pack Major Version
wSPMinor As Integer ' Service Pack Minor Version
wSuiteMask As Integer ' Suite Identifier
bProductType As Byte ' Server / Workstation / Domain Controller ?
bReserved As Byte ' Reserved
End Type
Private Const VER_PLATFORM_WIN32_CE = 3
Private Const VER_PLATFORM_WIN32_NT = 2
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32s = 0
Private Const VER_SERVER_NT As Long = &H80000000
Private Const VER_WORKSTATION_NT As Long = &H40000000
Private Const VER_NT_DOMAIN_CONTROLLER = &H2
Private Const VER_NT_SERVER = &H3
Private Const VER_NT_WORKSTATION = &H1
Private Const VER_SUITE_SMALLBUSINESS As Long = &H1
Private Const VER_SUITE_ENTERPRISE As Long = &H2
Private Const VER_SUITE_BACKOFFICE As Long = &H4
Private Const VER_SUITE_COMMUNICATIONS As Long = &H8
Private Const VER_SUITE_TERMINAL As Long = &H10
Private Const VER_SUITE_SMALLBUSINESS_RESTRICTED As Long = &H20
Private Const VER_SUITE_EMBEDDEDNT As Long = &H40
Private Const VER_SUITE_DATACENTER As Long = &H80
Private Const VER_SUITE_SINGLEUSERTS As Long = &H100
Private Const VER_SUITE_PERSONAL As Long = &H200
Private Const VER_SUITE_BLADE As Long = &H400
Private Const SM_STARTER = 88
Private Const SM_SERVERR2 = 89
'R閏up閞ation dossier temporaire
Private Declare Function GetTempPath _
Lib "kernel32" _
Alias "GetTempPathA" (ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long
Private Type SYSTEM_INFO
wProcessorArchitecture As Integer
wReserved As Integer
dwPageSize As Long
lpMinimumApplicationAddress As Long
lpMaximumApplicationAddress As Long
dwActiveProcessorMask As Long
dwNumberOfProcessors As Long
dwProcessorType As Long
dwAllocationGranularity As Long
wProcessorLevel As Integer
wProcessorRevision As Integer
End Type
Private Declare Sub GetNativeSystemInfo _
Lib "kernel32.dll" (ByRef lpSystemInfo As SYSTEM_INFO)
Private Const PROCESSOR_ARCHITECTURE_AMD64 As Long = &H9
Private Const PROCESSOR_ARCHITECTURE_IA64 As Long = &H6
Private Const VER_SUITE_WH_SERVER As Long = &H8000
Private Const VER_SUITE_STORAGE_SERVER As Long = &H2000
Private Const VER_SUITE_COMPUTE_SERVER As Long = &H4000
Private Declare Function GetProductInfo _
Lib "kernel32.dll" (ByVal dwOSMajorVersion As Long, _
ByVal dwOSMinorVersion As Long, _
ByVal dwSpMajorVersion As Long, _
ByVal dwSpMinorVersion As Long, _
ByRef pdwReturnedProductType As Long) As Long
Private Const PRODUCT_BUSINESS As Long = &H6
Private Const PRODUCT_BUSINESS_N As Long = &H10
Private Const PRODUCT_CLUSTER_SERVER As Long = &H12
Private Const PRODUCT_DATACENTER_SERVER As Long = &H8
Private Const PRODUCT_DATACENTER_SERVER_CORE As Long = &HC
Private Const PRODUCT_DATACENTER_SERVER_CORE_V As Long = &H27
Private Const PRODUCT_DATACENTER_SERVER_V As Long = &H25
Private Const PRODUCT_ENTERPRISE As Long = &H4
Private Const PRODUCT_ENTERPRISE_N As Long = &H1B
Private Const PRODUCT_ENTERPRISE_SERVER As Long = &HA
Private Const PRODUCT_ENTERPRISE_SERVER_CORE As Long = &HE
Private Const PRODUCT_ENTERPRISE_SERVER_CORE_V As Long = &H29
Private Const PRODUCT_ENTERPRISE_SERVER_IA64 As Long = &HF
Private Const PRODUCT_ENTERPRISE_SERVER_V As Long = &H26
Private Const PRODUCT_HOME_BASIC As Long = &H2
Private Const PRODUCT_HOME_BASIC_N As Long = &H5
Private Const PRODUCT_HOME_PREMIUM As Long = &H3
Private Const PRODUCT_HOME_PREMIUM_N As Long = &H1A
Private Const PRODUCT_HYPERV As Long = &H2A
Private Const PRODUCT_MEDIUMBUSINESS_SERVER_MANAGEMENT As Long = &H1E
Private Const PRODUCT_MEDIUMBUSINESS_SERVER_MESSAGING As Long = &H20
Private Const PRODUCT_MEDIUMBUSINESS_SERVER_SECURITY As Long = &H1F
Private Const PRODUCT_SERVER_FOR_SMALLBUSINESS As Long = &H18
Private Const PRODUCT_SERVER_FOR_SMALLBUSINESS_V As Long = &H23
Private Const PRODUCT_SMALLBUSINESS_SERVER As Long = &H9
Private Const PRODUCT_STANDARD_SERVER As Long = &H7
Private Const PRODUCT_STANDARD_SERVER_CORE As Long = &HD
Private Const PRODUCT_STANDARD_SERVER_CORE_V As Long = &H28
Private Const PRODUCT_STANDARD_SERVER_V As Long = &H24
Private Const PRODUCT_STARTER As Long = &HB
Private Const PRODUCT_STORAGE_ENTERPRISE_SERVER As Long = &H17
Private Const PRODUCT_STORAGE_EXPRESS_SERVER As Long = &H14
Private Const PRODUCT_STORAGE_STANDARD_SERVER As Long = &H15
Private Const PRODUCT_STORAGE_WORKGROUP_SERVER As Long = &H16
Private Const PRODUCT_ULTIMATE As Long = &H1
Private Const PRODUCT_ULTIMATE_N As Long = &H1C
Private Const PRODUCT_UNDEFINED As Long = &H0
Private Const PRODUCT_WEB_SERVER As Long = &H11
Private Const PRODUCT_WEB_SERVER_CORE As Long = &H1D
Private Const cstNonInstalle = "Absent"
Private Const cstSeparGauche = " ["
Private Const cstSeparDroite = "]"
Private clsRegistre As RegistryHandler
Private blnIEPresent As Boolean
Private strIEVersion As String
Private strWindowsVersion As String
Private blnIsWin2K As Boolean
Private blnIsWin32s As Boolean
Private blnIsWin95 As Boolean
Private blnIsWin98 As Boolean
Private blnIsWin98SE As Boolean
Private blnIsWin98ME As Boolean
Private blnIsWin9x As Boolean
Private blnIsWinNT As Boolean
Private blnIsWinNT3 As Boolean
Private blnIsWinNT4 As Boolean
Private blnIsWinNT5 As Boolean
Private blnIsWinNT6 As Boolean
Private blnIsWinServer As Boolean
Private blnIsWinXP As Boolean
Private blnIsWinCE As Boolean
Private blnIsWinVista As Boolean
Private blnIsWin7 As Boolean
Private blnIsWin8 As Boolean
Private blnIsWinMediaCenter As Boolean
Private blnIsWin2003 As Boolean
Private blnIsWinHomeServer As Boolean
Private blnIsWin2008 As Boolean
Private blnIsWin64bit As Boolean
Private Function APIFunctionPresent(ByVal FunctionName As String, _
ByVal DLLName As String) As Boolean
Dim lHandle As Long
Dim lAddr As Long
Dim FreeLib As Boolean
FreeLib = False
lHandle = GetModuleHandle(DLLName)
If lHandle = 0 Then
lHandle = LoadLibraryEx(DLLName, 0&, DONT_RESOLVE_DLL_REFERENCES)
FreeLib = True
End If
If lHandle <> 0 Then
lAddr = GetProcAddress(lHandle, FunctionName)
If FreeLib Then
FreeLibrary lHandle
End If
End If
APIFunctionPresent = (lAddr <> 0)
End Function
Private Function InfoVersion64bit() As String
Dim lngRet As Long
Dim strTemp As String
Dim Si As SYSTEM_INFO
blnIsWin64bit = False
' If APIFunctionPresent("IsWow64Process", "kernel32") Then
' IsWow64Process GetCurrentProcess, lngRet
'
' If lngRet <> 0 Then
If APIFunctionPresent("GetNativeSystemInfo", "kernel32") Then 'N'existe qu'?partir d'XP => v閞if au cas o?2000 demande
GetNativeSystemInfo Si
If Si.wProcessorArchitecture = PROCESSOR_ARCHITECTURE_AMD64 Then
strTemp = " 64bits"
blnIsWin64bit = True
Else
strTemp = " 32bits"
blnIsWin64bit = False
End If
End If
InfoVersion64bit = strTemp
End Function
Private Sub InfoVersionIE()
Dim strVersion As String
Dim strBuild As String
strVersion = clsRegistre.GetRegValue(HKEY_LOCAL_MACHINE, "Software/Microsoft/Internet Explorer", "Version")
If strVersion = vbNullString Then
strVersion = clsRegistre.GetRegValue(HKEY_LOCAL_MACHINE, "Software/Microsoft/Internet Explorer", "IVer")
If strVersion = vbNullString Then
blnIEPresent = False
strIEVersion = cstNonInstalle
Else
blnIEPresent = True
Select Case strVersion
Case "100"
strIEVersion = "1 [IVer " & strVersion & cstSeparDroite
Case "101"
strIEVersion = "Fournit avec Windows NT 4 [IVer " & strVersion & cstSeparDroite
Case "102"
strIEVersion = "2 [IVer " & strVersion & cstSeparDroite
Case "103"
strBuild = clsRegistre.GetRegValue(HKEY_LOCAL_MACHINE, "Software/Microsoft/Internet Explorer", "Build")
Select Case strBuild
Case "1155"
strIEVersion = "3 [IVer " & strVersion & " Build " & strBuild & cstSeparDroite
Case "1158"
strIEVersion = "3 OSR2 [IVer " & strVersion & " Build " & strBuild & cstSeparDroite
Case "1215"
strIEVersion = "3.01 [IVer " & strVersion & " Build " & strBuild & cstSeparDroite
Case "1300"
strIEVersion = "3.02 ou 3.02a [IVer " & strVersion & " Build " & strBuild & cstSeparDroite
Case Else
strIEVersion = "IVer " & strVersion & " Build " & strBuild & ""
End Select
Case Else
strIEVersion = "IVer " & strVersion
End Select
End If
Else
blnIEPresent = True
strIEVersion = TraduitIEVersion(strVersion)
End If
End Sub
Private Function InfoVersionMediaCenter() As String
Dim strTemp As String
strTemp = vbNullString
If GetSystemMetrics(SM_MEDIACENTER) <> 0 Then
blnIsWinMediaCenter = True
strTemp = " Media Center"
End If
InfoVersionMediaCenter = strTemp
End Function
Private Function InfoVersionWinEx() As String
Dim OSinfo As OSVERSIONINFOEX
Dim SysInfo As SYSTEM_INFO
Dim RetValue As Long
Dim RetProdType As Long
OSinfo.dwOSVersionInfoSize = Len(OSinfo)
OSinfo.szCSDVersion = Space$(128)
RetValue = GetVersionEx(OSinfo)
With OSinfo
blnIsWinNT = True
Select Case .dwMajorVersion
Case 6
blnIsWinNT6 = True
Select Case .dwMinorVersion
Case 0
If .bProductType = VER_NT_WORKSTATION Then
blnIsWinVista = True
strWindowsVersion = "Windows Vista"
Else
blnIsWin2008 = True
strWindowsVersion = "Windows Server 2008"
End If
Case 1
blnIsWin7 = True
Select Case .dwBuildNumber
Case 6801
strWindowsVersion = "Windows 7 preBeta build M3 PDC 2008"
Case Else
strWindowsVersion = "Windows 7"
End Select
Case 2
blnIsWin8 = True
Select Case .dwBuildNumber
Case 7867
strWindowsVersion = "Windows 8 Milestone1"
Case 7910 - 7947
strWindowsVersion = "Windows 8 Milestone2"
Case 7955
strWindowsVersion = "Windows 8 Milestone3"
Case Else
strWindowsVersion = "Windows 8"
End Select
Case Else
strWindowsVersion = "Windows NT v" & CStr(.dwMajorVersion) & "." & CStr(.dwMinorVersion)
End Select
strWindowsVersion = strWindowsVersion & InfoVersion64bit
Call GetProductInfo(.dwMajorVersion, .dwMinorVersion, .wSPMajor, .wSPMinor, RetProdType)
Select Case RetProdType
Case PRODUCT_BUSINESS
strWindowsVersion = strWindowsVersion & " Business"
Case PRODUCT_BUSINESS_N
strWindowsVersion = strWindowsVersion & " Business N"
Case PRODUCT_CLUSTER_SERVER
strWindowsVersion = strWindowsVersion & " HPC"
Case PRODUCT_DATACENTER_SERVER
strWindowsVersion = strWindowsVersion & " Datacenter"
Case PRODUCT_DATACENTER_SERVER_CORE
strWindowsVersion = strWindowsVersion & " Datacenter (core installation)"
Case PRODUCT_DATACENTER_SERVER_CORE_V
strWindowsVersion = strWindowsVersion & " Datacenter sans Hyper-V(core installation)"
Case PRODUCT_DATACENTER_SERVER_V
strWindowsVersion = strWindowsVersion & " Datacenter sans Hyper-V"
Case PRODUCT_ENTERPRISE
strWindowsVersion = strWindowsVersion & " Enterprise"
Case PRODUCT_ENTERPRISE_N
strWindowsVersion = strWindowsVersion & " Enterprise N"
Case PRODUCT_ENTERPRISE_SERVER
strWindowsVersion = strWindowsVersion & " Server Enterprise"
Case PRODUCT_ENTERPRISE_SERVER_CORE
strWindowsVersion = strWindowsVersion & " Server Enterprise (core installation)"
Case PRODUCT_ENTERPRISE_SERVER_CORE_V
strWindowsVersion = strWindowsVersion & " Server Enterprise sans Hyper-V(core installation)"
Case PRODUCT_ENTERPRISE_SERVER_IA64
strWindowsVersion = strWindowsVersion & " Enterprise pour Itanium"
Case PRODUCT_ENTERPRISE_SERVER_V
strWindowsVersion = strWindowsVersion & " Server Enterprise sans Hyper-V"
Case PRODUCT_HOME_BASIC
strWindowsVersion = strWindowsVersion & " Home Basic"
Case PRODUCT_HOME_BASIC_N
strWindowsVersion = strWindowsVersion & " Home Basic N"
Case PRODUCT_HOME_PREMIUM
strWindowsVersion = strWindowsVersion & " Home Premium"
Case PRODUCT_HOME_PREMIUM_N
strWindowsVersion = strWindowsVersion & " Home Premium N"
Case PRODUCT_HYPERV
strWindowsVersion = strWindowsVersion & " Microsoft Hyper-V Server"
Case PRODUCT_MEDIUMBUSINESS_SERVER_MANAGEMENT
strWindowsVersion = strWindowsVersion & " Essential Business Server Management Server"
Case PRODUCT_MEDIUMBUSINESS_SERVER_MESSAGING
strWindowsVersion = strWindowsVersion & " Essential Business Server Messaging Server"
Case PRODUCT_MEDIUMBUSINESS_SERVER_SECURITY
strWindowsVersion = strWindowsVersion & " Essential Business Server Security Server"
Case PRODUCT_SERVER_FOR_SMALLBUSINESS
strWindowsVersion = strWindowsVersion & " Windows Essential Server Solutions"
Case PRODUCT_SERVER_FOR_SMALLBUSINESS_V
strWindowsVersion = strWindowsVersion & " Windows Essential Server Solutions sans Hyper-V"
Case PRODUCT_SMALLBUSINESS_SERVER
strWindowsVersion = strWindowsVersion & " Small Business Server"
Case PRODUCT_STANDARD_SERVER
strWindowsVersion = strWindowsVersion & " Standard"
Case PRODUCT_STANDARD_SERVER_CORE
strWindowsVersion = strWindowsVersion & " Standard (core installation)"
Case PRODUCT_STANDARD_SERVER_CORE_V
strWindowsVersion = strWindowsVersion & " Standard sans Hyper-V(core installation)"
Case PRODUCT_STANDARD_SERVER_V
strWindowsVersion = strWindowsVersion & " Standard sans Hyper-V"
Case PRODUCT_STARTER
strWindowsVersion = strWindowsVersion & " Starter"
Case PRODUCT_STORAGE_ENTERPRISE_SERVER
strWindowsVersion = strWindowsVersion & " Storage Server Enterprise"
Case PRODUCT_STORAGE_EXPRESS_SERVER
strWindowsVersion = strWindowsVersion & " Storage Server Express"
Case PRODUCT_STORAGE_STANDARD_SERVER
strWindowsVersion = strWindowsVersion & " Storage Server Standard"
Case PRODUCT_STORAGE_WORKGROUP_SERVER
strWindowsVersion = strWindowsVersion & " Storage Server Workgroup"
Case PRODUCT_ULTIMATE
strWindowsVersion = strWindowsVersion & " Ultimate"
Case PRODUCT_ULTIMATE_N
strWindowsVersion = strWindowsVersion & " Ultimate N"
Case PRODUCT_WEB_SERVER
strWindowsVersion = strWindowsVersion & " Web Server"
Case PRODUCT_WEB_SERVER_CORE
strWindowsVersion = strWindowsVersion & " Web Server(core installation)"
Case PRODUCT_UNDEFINED
strWindowsVersion = strWindowsVersion & " Produit inconnu"
End Select
strWindowsVersion = strWindowsVersion & " (" & InfoVersionMediaCenter & ")"
Case 5
blnIsWinNT5 = True
Select Case .dwMinorVersion
Case 0
blnIsWin2K = True
strWindowsVersion = "Windows 2000"
If .bProductType = VER_NT_WORKSTATION Then
If .wSuiteMask And VER_SUITE_PERSONAL Then
strWindowsVersion = strWindowsVersion & " Home Edition"
Else
strWindowsVersion = strWindowsVersion & " Professionel"
End If
Else
blnIsWinServer = True
If .wSuiteMask And VER_SUITE_DATACENTER Then
strWindowsVersion = strWindowsVersion & " DataCenter Server "
ElseIf .wSuiteMask And VER_SUITE_ENTERPRISE Then
strWindowsVersion = strWindowsVersion & " Advanced Server "
Else
strWindowsVersion = strWindowsVersion & " Server "
End If
End If
Case 1
blnIsWinXP = True
strWindowsVersion = "Windows XP"
If .wSuiteMask And VER_SUITE_PERSONAL Then
strWindowsVersion = strWindowsVersion & " Home Edition"
Else
strWindowsVersion = strWindowsVersion & " Professionel"
End If
Case 2
If GetSystemMetrics(SM_SERVERR2) <> 0 Then
blnIsWin2003 = True
If .bProductType = VER_SUITE_STORAGE_SERVER Then
strWindowsVersion = "Windows Storage Server 2003 R2"
Else
strWindowsVersion = "Windows Server 2003 R2"
End If
ElseIf .bProductType = VER_SUITE_WH_SERVER Then
blnIsWinHomeServer = True
strWindowsVersion = "Windows Home Server"
ElseIf .bProductType = VER_SUITE_STORAGE_SERVER Then
blnIsWin2003 = True
strWindowsVersion = "Windows Storage Server 2003"
ElseIf .bProductType = VER_NT_WORKSTATION And IsWin64bit Then
blnIsWinXP = True
strWindowsVersion = "Microsoft Windows XP Professional x64 Edition"
Else
blnIsWin2003 = True
strWindowsVersion = "Windows Server 2003"
End If
If .bProductType <> VER_NT_WORKSTATION Then
GetNativeSystemInfo SysInfo
If SysInfo.wProcessorArchitecture = PROCESSOR_ARCHITECTURE_IA64 Then
If .wSuiteMask And VER_SUITE_DATACENTER Then
strWindowsVersion = strWindowsVersion & " Datacenter Edition pour Itanium"
ElseIf .wSuiteMask And VER_SUITE_ENTERPRISE Then
strWindowsVersion = strWindowsVersion & " Enterprise Edition pour Itanium"
End If
ElseIf SysInfo.wProcessorArchitecture = PROCESSOR_ARCHITECTURE_AMD64 Then
If .wSuiteMask And VER_SUITE_DATACENTER Then
strWindowsVersion = strWindowsVersion & " Datacenter x64 Edition"
ElseIf .wSuiteMask And VER_SUITE_ENTERPRISE Then
strWindowsVersion = strWindowsVersion & " Enterprise x64 Edition"
Else
strWindowsVersion = strWindowsVersion & " Standard x64 Edition"
End If
Else
If .wSuiteMask And VER_SUITE_DATACENTER Then
strWindowsVersion = strWindowsVersion & " Datacenter Edition"
ElseIf .wSuiteMask And VER_SUITE_ENTERPRISE Then
strWindowsVersion = strWindowsVersion & " Enterprise Edition"
ElseIf .wSuiteMask And VER_SUITE_COMPUTE_SERVER Then
strWindowsVersion = strWindowsVersion & " Compute Cluster Edition"
ElseIf .wSuiteMask And VER_SUITE_BLADE Then
strWindowsVersion = strWindowsVersion & " Web Edition"
Else
strWindowsVersion = strWindowsVersion & " Standard Edition"
End If
End If
End If
Case Else
strWindowsVersion = "Windows NT v" & CStr(.dwMajorVersion) & "." & CStr(.dwMinorVersion)
End Select
strWindowsVersion = strWindowsVersion & InfoVersion64bit
strWindowsVersion = strWindowsVersion & InfoVersionMediaCenter
Case Else
strWindowsVersion = "Windows NT v" & CStr(.dwMajorVersion) & "." & CStr(.dwMinorVersion) & "." & CStr(.dwBuildNumber)
If .dwMajorVersion = 4 And .bProductType = VER_NT_WORKSTATION Then
strWindowsVersion = strWindowsVersion & " Workstation"
End If
End Select
If .wSPMajor > 0 Then
strWindowsVersion = strWindowsVersion & " Service Pack " & CStr(.wSPMajor)
If .wSPMinor > 0 Then
strWindowsVersion = strWindowsVersion & "." & CStr(.wSPMinor)
End If
End If
'If .wSuiteMask And VER_SUITE_TERMINAL Then
' blnTerminalServicePresent = True
'End If
strWindowsVersion = strWindowsVersion & cstSeparGauche & "Version:" & CStr(.dwMajorVersion) & "." & CStr(.dwMinorVersion) & "." & CStr(.dwBuildNumber) & cstSeparDroite
End With
End Function
Private Sub InfoVersionWinStd()
Dim OSinfo As OSVERSIONINFO
Dim strPssInfo As String
Dim RetValue As Long
OSinfo.dwOSVersionInfoSize = Len(OSinfo)
OSinfo.szCSDVersion = Space$(128)
RetValue = GetVersion(OSinfo)
With OSinfo
.dwBuildNumber = LOWORD(.dwBuildNumber)
Select Case .dwPlatformId
Case VER_PLATFORM_WIN32_WINDOWS
blnIsWin9x = True
Select Case .dwMinorVersion
Case 0
blnIsWin95 = True
Select Case .dwBuildNumber
Case 950
strWindowsVersion = "Windows 95"
Case 1111
strWindowsVersion = "Windows 95 SR2.5"
Case Else
strWindowsVersion = "Windows 95 SR2"
End Select
Case 3
blnIsWin95 = True
strWindowsVersion = "Windows 95 SR2.x"
Case 10
If .dwBuildNumber = 2222 Then
blnIsWin98SE = True
strWindowsVersion = "Windows 98 Second Edition"
Else
blnIsWin98 = True
strWindowsVersion = "Windows 98"
End If
Case 90
blnIsWin98ME = True
strWindowsVersion = "Windows Me (Millenium)"
Case Else
strWindowsVersion = "Windows v" & CStr(.dwMajorVersion) & "." & CStr(.dwMinorVersion) & "." & CStr(.dwBuildNumber)
End Select
Case VER_PLATFORM_WIN32_NT
blnIsWinNT = True
Select Case .dwMajorVersion
Case 3
blnIsWinNT3 = True
Select Case .dwMinorVersion
Case 0
strWindowsVersion = "Windows NT 3"
Case 1
strWindowsVersion = "Windows NT 3.1"
Case 51
strWindowsVersion = "Windows NT 3.51"
Case Else
strWindowsVersion = "Windows NT"
End Select
Case 4
blnIsWinNT4 = True
strWindowsVersion = "Windows NT 4.0"
Case 5 'G閞er dans InfoVersionWinEx
Case Else
strWindowsVersion = "Windows NT v" & CStr(.dwMajorVersion) & "." & CStr(.dwMinorVersion) & "." & CStr(.dwBuildNumber)
End Select
Select Case UCase$(clsRegistre.GetRegValue(HKEY_LOCAL_MACHINE, "SYSTEM/CurrentControlSet/Control/ProductOptions", "ProductType"))
Case "WINNT"
strWindowsVersion = strWindowsVersion & " Professional "
Case "LANMANNT"
blnIsWinServer = True
strWindowsVersion = strWindowsVersion & " Server "
Case "SERVERNT"
blnIsWinServer = True
strWindowsVersion = strWindowsVersion & " Advanced Server "
End Select
Case VER_PLATFORM_WIN32s
blnIsWin32s = True
strWindowsVersion = "Win32s"
Case VER_PLATFORM_WIN32_CE
Case Else
strWindowsVersion = "ERROR"
End Select
strPssInfo = .szCSDVersion
If Len(strPssInfo) > 0 Then
If InStr(strPssInfo, Chr$(0)) > 0 Then
strPssInfo = Left$(strPssInfo, InStr(strPssInfo, Chr$(0)) - 1)
End If
If strPssInfo = " A " Or strPssInfo = " B " Or strPssInfo = " C " Then 'A=win98 SE, B et C=Win95 sr2
strWindowsVersion = strWindowsVersion & cstSeparGauche & "Version:" & CStr(.dwMajorVersion) & "." & CStr(.dwMinorVersion) & "." & CStr(.dwBuildNumber) & Trim(strPssInfo) & cstSeparDroite
'strWindowsVersion = strWindowsVersion & strPssInfo
End If
Else
strWindowsVersion = strWindowsVersion & cstSeparGauche & "Version:" & CStr(.dwMajorVersion) & "." & CStr(.dwMinorVersion) & "." & CStr(.dwBuildNumber) & cstSeparDroite
End If
End With
End Sub
Private Sub InfoVersionWindows()
If IsWinSuppNT4 Then 'Ca marche avec NT4 sp6 mais bon
InfoVersionWinEx
Else
InfoVersionWinStd
End If
End Sub
Private Sub IniVariables()
Set clsRegistre = New RegistryHandler
blnIEPresent = False
strIEVersion = vbNullString
strWindowsVersion = vbNullString
blnIsWin2K = False
blnIsWin32s = False
blnIsWin95 = False
blnIsWin98 = False
blnIsWin98SE = False
blnIsWin98ME = False
blnIsWin9x = False
blnIsWinNT = False
blnIsWinNT3 = False
blnIsWinNT4 = False
blnIsWinNT5 = False
blnIsWinNT6 = False
blnIsWinServer = False
blnIsWinXP = False
blnIsWinVista = False
blnIsWin7 = False
blnIsWin8 = False
blnIsWinCE = False
blnIsWinMediaCenter = False
blnIsWin64bit = False
blnIsWin2003 = False
blnIsWinHomeServer = False
blnIsWin2008 = False
End Sub
Private Function IsWinSuppNT4() As Boolean
Dim OSinfo As OSVERSIONINFO
Dim RetValue As Long
OSinfo.dwOSVersionInfoSize = Len(OSinfo)
OSinfo.szCSDVersion = Space$(128)
RetValue = GetVersion(OSinfo)
If (OSinfo.dwPlatformId = VER_PLATFORM_WIN32_NT) And (OSinfo.dwMajorVersion > 4) Then
IsWinSuppNT4 = True
Else
IsWinSuppNT4 = False
End If
End Function
Private Function LOWORD(ByVal lData As Long) As Long
If (lData And &HFFFF&) > &H7FFF& Then
lData = lData - &H10000
Else
lData = lData And &HFFFF&
End If
LOWORD = lData
End Function
Private Function TraduitIEVersion(strVers As String) As String
Dim strTexte As String
Dim strMonTableauTemp() As String
Dim intMonTableau(0 To 3) As Integer
Dim I As Byte
strMonTableauTemp = Split(strVers, ".")
ReDim Preserve strMonTableauTemp(0 To 3)
For I = 0 To 3
If strMonTableauTemp(I) = vbNullString Then
intMonTableau(I) = 0
Else
intMonTableau(I) = CInt(strMonTableauTemp(I))
End If
Next
Erase strMonTableauTemp
strTexte = vbNullString
Select Case intMonTableau(0)
Case 4
Select Case intMonTableau(1)
Case 40
Select Case intMonTableau(2)
Case 308
strTexte = "1.0 (Plus!)"
Case 420
strTexte = "2.0"
End Select
Case 70
Select Case intMonTableau(2)
Case 1155
strTexte = "3.0"
Case 1158
strTexte = "3.0 (OSR2)"
Case 1215
strTexte = "3.01"
Case 1300
strTexte = "3.02 ou 3.02a"
End Select
Case 71
Select Case intMonTableau(2)
Case 544
strTexte = "4.0 (SP1)"
Case 1008
Select Case intMonTableau(3)
Case 3
strTexte = "4.0 (SP2)"
End Select
Case 1712
Select Case intMonTableau(3)
Case 6
strTexte = "4.0"
End Select
End Select
Case 72
Select Case intMonTableau(2)
Case 2016
Select Case intMonTableau(3)
Case 8
strTexte = "4.01"
End Select
Case 3110
Select Case intMonTableau(3)
Case 8
strTexte = "4.01 (SP1)"
End Select
Case 3612
Select Case intMonTableau(3)
Case 1713
strTexte = "4.01 (SP2)"
End Select
End Select
End Select 'intMonTableau(0)=4
Case 5
Select Case intMonTableau(1)
Case 0
Select Case intMonTableau(2)
Case 518
Select Case intMonTableau(3)
Case 10
strTexte = "5 Beta 1"
End Select
Case 910
Select Case intMonTableau(3)
Case 1309
strTexte = "5 Beta 2"
End Select
Case 2014
Select Case intMonTableau(3)
Case 216
strTexte = "5"
End Select
Case 2314
Select Case intMonTableau(3)
Case 1003
strTexte = "5 (Office 2000)"
End Select
Case 2516
Select Case intMonTableau(3)
Case 1900
strTexte = "5.01 (Windows 2000 Beta 3)"
End Select
Case 2614
Select Case intMonTableau(3)
Case 3500
strTexte = "5 (Windows SE)"
End Select
Case 2919
Select Case intMonTableau(3)
Case 800
strTexte = "5.01 (Windows 2000 RC1)"
Case 3800
strTexte = "5.01 (Windows 2000 RC2)"
Case 6307
strTexte = "5.01"
End Select
Case 2920
Select Case intMonTableau(3)
Case 0
strTexte = "5.01 (Windows 2000)"
End Select
Case 3103
Select Case intMonTableau(3)
Case 1000
strTexte = "5.01 SP1 (Windows 2000 SP1)"
End Select
Case 3105
Select Case intMonTableau(3)
Case 106
strTexte = "5.01 SP1 (Windows 95/98 et Windows NT 4)"
End Select
Case 3314
Select Case intMonTableau(3)
Case 2101
strTexte = "5.01 SP2 (Windows 95/98 et Windows NT 4)"
End Select
Case 3315
Select Case intMonTableau(3)
Case 1000
strTexte = "5.01 SP2 (Windows 2000)"
End Select
Case 3502
Select Case intMonTableau(3)
Case 1000
strTexte = "5.01 SP3 (Windows 2000 SP3)"
End Select
Case 3700
Select Case intMonTableau(3)
Case 1000
strTexte = "5.01 SP4 'windows 2000 SP4)"
End Select
End Select 'intMontableau(0)=5;intMonTableau(1)=0
Case 50
Select Case intMonTableau(2)
Case 3825
Select Case intMonTableau(3)
Case 1300
strTexte = "5.5 Beta"
End Select
Case 4030
Select Case intMonTableau(3)
Case 2400
strTexte = "5.5 & Internet Tools Beta"
End Select
Case 4134
Select Case intMonTableau(3)
Case 100
strTexte = "5.5 Windows Me"
Case 600
strTexte = "5.5"
End Select
Case 4308
Select Case intMonTableau(3)
Case 2900
strTexte = "5.5 Advanced Secutity Privacy Beta"
End Select
Case 4522
Select Case intMonTableau(3)
Case 1800
strTexte = "5.5 SP1"
End Select
Case 4807
Select Case intMonTableau(3)
Case 2300
strTexte = "5.5 SP2"
End Select
End Select 'intMonTableau(0)=5; intMonTableau(1)=50
End Select 'intMonTableau(0)=5
Case 6
Select Case intMonTableau(1)
Case 0
Select Case intMonTableau(2)
Case 2462
Select Case intMonTableau(3)
Case 0
strTexte = "6 Beta"
End Select
Case 2479
Select Case intMonTableau(3)
Case 6
strTexte = "6 Beta Refresh"
End Select
Case 2600
Select Case intMonTableau(3)
Case 0
strTexte = "6"
End Select
Case 2800
Select Case intMonTableau(3)
Case 1106
strTexte = "6 SP1"
Case 1278
strTexte = "6 v.01 Developer Preview (SP1b Beta)"
Case 1314
strTexte = "6 v.04 Developer Preview (SP1b Beta)"
End Select
Case 2900
Select Case intMonTableau(3)
Case 2180
strTexte = "6 SP2"
End Select
Case 3663
Select Case intMonTableau(3)
Case 0
strTexte = "6 pour Windows Server 2003 RC1"
End Select
Case 3718
Select Case intMonTableau(3)
Case 0
strTexte = "6 pour Windows Server 2003 RC2"
End Select
Case 3790
Select Case intMonTableau(3)
Case 0
strTexte = "6 pour Windows Server 2003 "
Case 1830
strTexte = "6 Windows XP x64/Server 2003 SP1"
End Select
End Select 'intMonTableau(0)=6; intMonTableau(1)=0
End Select 'intMonTableau(0)=6
Case 7
Select Case intMonTableau(1)
Case 0
Select Case intMonTableau(2)
Case 5299
Select Case intMonTableau(3)
Case 0
strTexte = "7 Beta 2"
End Select
Case 5730
Select Case intMonTableau(3)
Case 1100
strTexte = "7 Windows XP/Server 2003"
Case 13
strTexte = "7 Windows XP/Server 2003"
End Select
Case 6000
Select Case intMonTableau(3)
Case 16386
strTexte = "7 Windows Vista"
Case 16441
strTexte = "7 Windows XP SP2 x64/Server 2003 SP2 x64"
Case 16711
strTexte = "7 Windows Vista"
End Select
End Select 'intMonTableau(0)=7; intMonTableau(1)=0
End Select 'intMonTableau(0)=7
Case 8
Select Case intMonTableau(1)
Case 0
Select Case intMonTableau(2)
Case 6001
Select Case intMonTableau(3)
Case 17184
strTexte = "8 Beta 1"
Case 18241
strTexte = "8 Beta 2"
End Select
Case 6801
Select Case intMonTableau(3)
Case 0
strTexte = "8 B閠a Windows 7 preBeta Build M3 PDC 2008"
End Select
End Select ''intMonTableau(0)=8; intMonTableau(1)=0
End Select 'intMonTableau(0)=8
End Select
If strTexte = vbNullString Then
TraduitIEVersion = strVers
Else
TraduitIEVersion = strTexte & cstSeparGauche & strVers & cstSeparDroite
End If
End Function
Private Sub Class_Initialize()
IniVariables
InfoVersionIE
InfoVersionWindows
Set clsRegistre = Nothing
End Sub
Property Get IEPresent() As Boolean
IEPresent = blnIEPresent
End Property
Property Get IEVersion() As String
IEVersion = strIEVersion
End Property
Property Get IsWin2003() As Boolean
IsWin2003 = blnIsWin2003
End Property
Property Get IsWinHomeServer() As Boolean
IsWinHomeServer = blnIsWinHomeServer
End Property
Property Get IsWin2008() As Boolean
IsWin2008 = blnIsWin2008
End Property
Property Get IsWinCE() As Boolean
IsWinCE = blnIsWinCE
End Property
Property Get IsWin2K() As Boolean
IsWin2K = blnIsWin2K
End Property
Property Get IsWin64bit() As Boolean
IsWin64bit = blnIsWin64bit
End Property
Property Get IsWin95() As Boolean
IsWin95 = blnIsWin95
End Property
Property Get IsWin98() As Boolean
IsWin98 = blnIsWin98
End Property
Property Get IsWin98ME() As Boolean
IsWin98ME = blnIsWin98ME
End Property
Property Get IsWin98SE() As Boolean
IsWin98SE = blnIsWin98SE
End Property
Property Get IsWin9x() As Boolean
IsWin9x = blnIsWin9x
End Property
Property Get IsWinMediaCenter() As Boolean
IsWinMediaCenter = blnIsWinMediaCenter
End Property
Property Get IsWinNT3() As Boolean
IsWinNT3 = blnIsWinNT3
End Property
Property Get IsWinNT4() As Boolean
IsWinNT4 = blnIsWinNT4
End Property
Property Get IsWinNT5() As Boolean
IsWinNT5 = blnIsWinNT5
End Property
Property Get IsWinNT6() As Boolean
IsWinNT6 = blnIsWinNT6
End Property
Property Get IsWinNT() As Boolean
IsWinNT = blnIsWinNT
End Property
Property Get IsWinServer() As Boolean
IsWinServer = blnIsWinServer
End Property
Property Get IsWinXP() As Boolean
IsWinXP = blnIsWinXP
End Property
Property Get IsWinVista() As Boolean
IsWinVista = blnIsWinVista
End Property
Property Get IsWin7() As Boolean
IsWin7 = blnIsWin7
End Property
Property Get IsWin8() As Boolean
IsWin8 = blnIsWin8
End Property
Property Get WindowsVersion() As String
WindowsVersion = strWindowsVersion
End Property
类模块RegistryHandler.cls
Option Explicit
'-------------------------------------------------------------------------------------------'
' 类模块： RegistryHandler.cls '
'-------------------------------------------------------------------------------------------'
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegEnumValue _
Lib "advapi32.dll" _
Alias "RegEnumValueA" (ByVal hKey As Long, _
ByVal dwIndex As Long, _
ByVal lpValueName As String, _
ByRef lpcbValueName As Long, _
ByVal lpReserved As Long, _
ByRef lpType As Long, _
ByRef lpData As Any, _
ByRef lpcbData As Long) As Long
Private Declare Function RegOpenKeyEx _
Lib "advapi32.dll" _
Alias "RegOpenKeyExA" (ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, _
ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueEx _
Lib "advapi32" _
Alias "RegQueryValueExA" (ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal lpReserved As Long, _
ByRef lpType As Long, _
ByVal lpData As String, _
ByRef lpcbData As Long) As Long
Private Declare Function RegQueryInfoKey _
Lib "advapi32.dll" _
Alias "RegQueryInfoKeyA" (ByVal hKey As Long, _
ByVal lpClass As String, _
ByRef lpcbClass As Long, _
ByVal lpReserved As Long, _
ByRef lpcSubKeys As Long, _
ByRef lpcbMaxSubKeyLen As Long, _
ByRef lpcbMaxClassLen As Long, _
ByRef lpcValues As Long, _
ByRef lpcbMaxValueNameLen As Long, _
ByRef lpcbMaxValueLen As Long, _
ByRef lpcbSecurityDescriptor As Long, _
ByRef lpftLastWriteTime As FILE_TIME) As Long
Private Const lngERROR_SUCCESS = 0&
Private Const lngERROR_FAILURE = 13&
Private Const lngNO_MORE_NODES = 259&
Private Const lngERROR_MORE_DATA = 234&
Private Const lngSYNCHRONIZE = &H100000
Private Const lngKEY_QUERY_VALUE = &H1
Private Const lngKEY_ENUMERATE_SUB_KEYS = &H8
Private Const lngKEY_NOTIFY = &H10
Private Const lngKEY_SET_VALUE = &H2
Private Const lngKEY_CREATE_SUB_KEY = &H4
Private Const lngKEY_CREATE_LINK = &H20
Private Const lngSTANDARD_RIGHTS_ALL = &H1F0000
Private Const lngKEY_ALL_ACCESS = ((lngSTANDARD_RIGHTS_ALL Or lngKEY_QUERY_VALUE Or lngKEY_SET_VALUE Or lngKEY_CREATE_SUB_KEY Or lngKEY_ENUMERATE_SUB_KEYS Or lngKEY_NOTIFY Or lngKEY_CREATE_LINK) And (Not lngSYNCHRONIZE))
Private Const lngREG_SZ = 1
Private Const lngREG_BINARY = 3
Private Const lngREG_DWORD = 4
Private Const ERROR_SUCCESS = 0&
' Declare Windows API types...
Private Type FILE_TIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Enum HKEYS
HKEY_CLASSES_ROOT = &H80000000
HKEY_CURRENT_USER = &H80000001
HKEY_LOCAL_MACHINE = &H80000002
HKEY_USERS = &H80000003
End Enum
Private Function EnumerateRegistryValuesByHandle(ByVal vhKeyHandle As Long, _
ByRef rvntValues As Variant) As String
Dim strValue As String
Dim lngData As Long, lngDataLen As Long, lngValueLen As Long, lngReturn As Long, lngIndex As Long
Dim lngValueType As Long
Dim strNodes() As String
' then loop through the nodes under the 'base node'...
Do
lngValueLen = 2000
strValue = String$(lngValueLen, 0)
lngDataLen = 2000
' and read the names of all the nodes under it...
lngReturn = RegEnumValue(vhKeyHandle, lngIndex, ByVal strValue, lngValueLen, 0&, lngValueType, ByVal lngData, lngDataLen)
strValue = Left$(strValue, lngValueLen)
' checking for problems.
If lngReturn <> lngERROR_SUCCESS And lngReturn <> lngNO_MORE_NODES Then
End If
' Add each node into an array...
ReDim Preserve strNodes(0 To 1, 0 To lngIndex)
strNodes(0, lngIndex) = CStr(lngValueType)
strNodes(1, lngIndex) = strValue
lngIndex = lngIndex + 1
' and loop until the enumeration return fails.
Loop While lngReturn <> lngNO_MORE_NODES
rvntValues = strNodes()
Erase strNodes
End Function
Private Function ReadRegistryValue(ByVal vhKeyHandle As Long, _
ByVal vstrValueName As String, _
ByRef rvntValue As Variant) As String
Dim strValueName As String, strData As String
Dim lngReturn As Long, lngIndex As Long, lngValuesCount As Long, lngValueType As Long, lngValueLen As Long
Dim lngValueMax As Long, lngData As Long, lngDataLen As Long
Dim blnData As Boolean
Dim vntValues As Variant
Dim typFileTime As FILE_TIME
' Check that all required variables have been passed...
If vhKeyHandle <= 0 Then
End If
If vstrValueName = "" Then
End If
' and enumerate the keys to see what type of value is stored in the one to return. First get the number of values
' and the maximum name length of those stored in the passed key...
lngReturn = RegQueryInfoKey(vhKeyHandle, "", 0&, 0&, 0&, 0&, 0&, lngValuesCount, lngValueMax, 0&, 0&, typFileTime)
If lngReturn <> lngERROR_SUCCESS Then
End If
lngValueLen = Len(vstrValueName) + 1
' then loop through the values until the requested value name is found.
Call EnumerateRegistryValuesByHandle(vhKeyHandle, vntValues)
For lngIndex = 0 To UBound(vntValues, 2)
lngReturn = lngERROR_FAILURE
strValueName = vntValues(1, lngIndex)
' Check that the currently enumerated key is the one requested...
If LCase$(vstrValueName) = LCase$(strValueName) Then
lngValueType = vntValues(0, lngIndex)
lngValueLen = Len(strValueName)
' and, depending on the value type, read and return the stored value...
Select Case lngValueType
Case lngREG_BINARY
' it's a binary value...
lngDataLen = 1
lngReturn = RegEnumValue(vhKeyHandle, lngIndex, strValueName, lngValueLen, 0&, lngValueType, blnData, lngDataLen)
rvntValue = blnData
Exit For
Case lngREG_DWORD
' it's a DWord...
lngDataLen = 4
lngReturn = RegEnumValue(vhKeyHandle, lngIndex, strValueName, lngValueLen, 0&, lngValueType, lngData, lngDataLen)
rvntValue = lngData
Exit For
Case lngREG_SZ
' it's a string value.
lngDataLen = 2048
strData = String$(lngDataLen, 0)
lngReturn = RegQueryValueEx(vhKeyHandle, strValueName, 0&, lngValueType, strData, lngDataLen)
rvntValue = Left$(strData, lngDataLen - 1)
Exit For
End Select
End If
Next
If lngReturn <> lngERROR_SUCCESS And lngReturn <> lngERROR_MORE_DATA Then
End If
End Function
Public Function GetRegValue(RootKey As HKEYS, _
sKey As String, _
sValueName As String) As Variant
Dim hKeyHandle As Long
Dim vTemp As Variant
Dim lngRet As Long
lngRet = RegOpenKeyEx(RootKey, sKey, 0&, lngKEY_ALL_ACCESS, hKeyHandle)
If lngRet = ERROR_SUCCESS Then
ReadRegistryValue hKeyHandle, sValueName, vTemp
Call RegCloseKey(hKeyHandle)
Else
vTemp = vbNullString
End If
GetRegValue = vTemp
End Function