本程序从法国网站（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 = NothingEnd Sub
类模块WinSysInfo.cls：Option Explicit'------------------------------------------------------------------------------'' 类模块： WinSysInfo.cls ''------------------------------------------------------------------------------'Private Declare Function GetModuleHandle _ Lib "kernel32" _ Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPrivate Declare Function LoadLibraryEx _ Lib "kernel32" _ Alias "LoadLibraryExA" (ByVal lpLibFileName As String, _ ByVal hFile As Long, _ ByVal dwFlags As Long) As LongPrivate Declare Function GetProcAddress _ Lib "kernel32" (ByVal hModule As Long, _ ByVal lpProcName As String) As LongPrivate Declare Function FreeLibrary _ Lib "kernel32" (ByVal hLibModule As Long) As LongPrivate Const DONT_RESOLVE_DLL_REFERENCES As Long = &H1
'D閠ection m閐ia centerPrivate Declare Function GetSystemMetrics _ Lib "user32" (ByVal nIndex As Long) As LongPrivate Const SM_MEDIACENTER = 87
'D閠ection version windowsPrivate Declare Function GetVersion _ Lib "kernel32" _ Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function GetVersionEx _ Lib "kernel32" _ Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFOEX) As LongPrivate Type OSVERSIONINFO dwOSVersionInfoSize As Long dwMajorVersion As Long dwMinorVersion As Long dwBuildNumber As Long dwPlatformId As Long szCSDVersion As String * 128End 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 ' ReservedEnd Type
Private Const VER_PLATFORM_WIN32_CE = 3Private Const VER_PLATFORM_WIN32_NT = 2Private Const VER_PLATFORM_WIN32_WINDOWS = 1Private Const VER_PLATFORM_WIN32s = 0Private Const VER_SERVER_NT As Long = &H80000000Private Const VER_WORKSTATION_NT As Long = &H40000000Private Const VER_NT_DOMAIN_CONTROLLER = &H2Private Const VER_NT_SERVER = &H3Private Const VER_NT_WORKSTATION = &H1Private Const VER_SUITE_SMALLBUSINESS As Long = &H1Private Const VER_SUITE_ENTERPRISE As Long = &H2Private Const VER_SUITE_BACKOFFICE As Long = &H4Private Const VER_SUITE_COMMUNICATIONS As Long = &H8Private Const VER_SUITE_TERMINAL As Long = &H10Private Const VER_SUITE_SMALLBUSINESS_RESTRICTED As Long = &H20Private Const VER_SUITE_EMBEDDEDNT As Long = &H40Private Const VER_SUITE_DATACENTER As Long = &H80Private Const VER_SUITE_SINGLEUSERTS As Long = &H100Private Const VER_SUITE_PERSONAL As Long = &H200Private Const VER_SUITE_BLADE As Long = &H400Private Const SM_STARTER = 88Private Const SM_SERVERR2 = 89
'R閏up閞ation dossier temporairePrivate 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 IntegerEnd 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 LongPrivate 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 LongPrivate 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 LongEnd Type
Enum HKEYS HKEY_CLASSES_ROOT = &H80000000 HKEY_CURRENT_USER = &H80000001 HKEY_LOCAL_MACHINE = &H80000002 HKEY_USERS = &H80000003End 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 strNodesEnd 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
