VB 6 Как лучше определить версию, разрядность и язык ОС на VB6?

[Кирилл]

Я использовал такой вариант:

'определение битности ОС

    For Each objOStype In GetObject("winmgmts:").InstancesOf("Win32_ComputerSystem")
        'WScript.Echo "PC type = " & objOStype.SystemType
        strOSbit = objOStype.SystemType
    Next
    
    If LCase(strOSbit) = "x86-based pc" Then
        OSbit = "32bit"
    End If
    If LCase(strOSbit) = "x64-based pc" Then
        OSbit = "64bit"
    End If

'определение OS, SP, Language

    For Each objOSinfo In GetObject("winmgmts:").InstancesOf("Win32_OperatingSystem")
        'WScript.Echo "Name = " & objOSinfo.Caption &VBCR _
        '   & "Version = " & objOSinfo.CSDVersion &VBCR _
        '   & "Language = " & objOSinfo.OSLanguage
        strNameOS = objOSinfo.Caption
        strSPver = objOSinfo.CSDVersion
        strOSLang = objOSinfo.OSLanguage
    Next
    
    If strOSLang = "9" Or strOSLang = "1033" Then
        OSLang = "English"
    End If
    If strOSLang = "1049" Then
        OSLang = "Russian"
    End If
    
    dNameOS = Split(strNameOS, " ")
    'WScript.Echo NameOS
  
    For Each NameOS In dNameOS
  
    If NameOS = "XP" Then
            NameOS = "XP"
            Exit For
    End If
    If NameOS = "2003" Or NameOS = "2003," Then
            NameOS = "2003"
            Exit For
    End If
    If NameOS = "2008" Then
            NameOS = "2008"
            Exit For
    End If
    If NameOS = "Vista" Then
            NameOS = "Vista"
            Exit For
    End If
    If NameOS = "7" Then
            NameOS = "7"
            Exit For
    End If
    If NameOS = "2008R2" Then
            NameOS = "2008R2"
            Exit For
    End If
    If NameOS = "8" Then
            NameOS = "8"
            Exit For
    End If
    If NameOS = "8.1" Then
            NameOS = "8.1"
            Exit For
    End If
    If NameOS = "10" Then
            NameOS = "10"
            Exit For
    End If
    Next
  
  
        Rem & "Система: " & NameOS
        Rem & "Язык: " & OSLang _
        REM & "Разрядность: " & OSbit
        Rem & "SP: " & strSPver
  
    
     Dim WshNetwork As Object
        Set WshNetwork = CreateObject("WScript.Network")
        Label1.Caption = "Имя компьютера: " & WshNetwork.ComputerName
        Label2.Caption = "Имя пользователя: " & WshNetwork.UserName
        Label3.Caption = "Домен: " & WshNetwork.UserDomain
        Label4.Caption = "Windows " & NameOS & "*" & OSbit
        winxp.Caption = NameOS
        Set WshNetwork = Nothing

Но он троит при росте кода,переменные с текстом (например ХР) читаются с ошибкой.

If NameOS = 10 Then
        GoTo Combo_win_8:
    ElseIf NameOS = 8.1 Then
        GoTo Combo_win_8:
    ElseIf NameOS = 8 Then
        GoTo Combo_win_8:
    ElseIf NameOS = Vista Then
        GoTo Combo_win_7:
    ElseIf NameOS = 7 Then
        GoTo Combo_win_7:
    ElseIf NameOS = XP Then
        GoTo Combo_win_XP:
    ElseIf NameOS = 2003 Then
        GoTo NoWinCombo1:
    ElseIf NameOS = 2008 Then
         GoTo NoWinCombo1:
    ElseIf NameOS = "2008R2" Then
        GoTo NoWinCombo1:
    End If

Может еще варианты?

 

[Dragokas]

Могу тебе дать мой на WinAPI. WMI может не работать у пользователя, особенно у такого, для которого требуется проверить целостность системных файлов,
а значит есть подозрения что задеты и файлы ядра WMI. Кроме того тип запуска ее службы можно самостоятельно выставить на "Отключено".
Только какой язык тебе нужен? Их как минимум три:
1) язык установки ОС
2) язык, выбранный для отображения в диалоговых окнах
3) язык для программ, не поддерживающих Юникод

 

[Кирилл]

язык, выбранный для отображения в диалоговых окнах

+

Могу тебе дать мой на WinAPI

Если не затруднит)

А то я уже несколько вариантов пробовал,на выходе фигня.

 

[Dragokas]

Держи. Там определение всех 3 видов языков, только не забывай, что если:

3) язык для программ, не поддерживающих Юникод

выбран английский, то написав по-русски в программе на VB6 будут крякозяблики.
Это конечно, можно победить, но ценой крови Вообщем смогу помочь только сделать юникодный MsgBox (ему все равно какой в системе язык).

Это класс, который писал я. Там очень много всего. Просто введи фразу osver. (и знак точки) и во всплывающей подсказке выбирай то, что тебе интересно.
С классами ты еще не работал. Но это проще всего.
Подключаешь этот файл к проекту. Правый клик в окне "Project" -> Add -> Add File... -> clsOsInfo.cls
или правый клик "Project" -> Add -> Add Class Module + вставить код класса и дать ему имя clsOSInfo

Правила пользования просты. Сначала создаешь экземпляр класса:

Dim OSVer As New clsOSInfo

Перед выходом - уничтожаешь:

Set OSVer = Nothing

В коде формы все вместе это выглядит так:

Option Explicit

Dim OSVer As New clsOSInfo

Private Sub Form_Load()
    Debug.Print "Название ОС: "; OSVer.OSName
    Debug.Print "Версия SP: "; OSVer.SPVer
    Debug.Print "Язык, отображаемый в диалогах: "; OSVer.LangNonUnicodeCode; " Название: "; OSVer.LangNonUnicodeName
    OSVer.IsVistaOrLater
    OSVer.MajorMinor
    End
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set OSVer = Nothing
End Sub

Сам код класса:

Спойлер

Option Explicit

' Класс OSInfo by Alex Dragokas
' ver 1.4.6
'

Private Type OSVERSIONINFOEX
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion(255) As Byte
    wServicePackMajor As Integer
    wServicePackMinor As Integer
    wSuiteMask As Integer
    wProductType As Byte
    wReserved As Byte
End Type

Private Type SID_IDENTIFIER_AUTHORITY
    value(0 To 5) As Byte
End Type

Private Type SID_AND_ATTRIBUTES
    Sid As Long
    Attributes As Long
End Type

Private Type TOKEN_GROUPS
    GroupCount As Long
    Groups(20) As SID_AND_ATTRIBUTES
End Type

Private Declare Function GetUserDefaultUILanguage Lib "kernel32.dll" () As Long
Private Declare Function GetSystemDefaultUILanguage Lib "kernel32.dll" () As Long
Private Declare Function GetSystemDefaultLCID Lib "kernel32.dll" () As Long
Private Declare Function GetUserDefaultLCID Lib "kernel32.dll" () As Long
Private Declare Function IsWow64Process Lib "kernel32.dll" (ByVal hProc As Long, bWow64Process As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32.dll" Alias "GetVersionExW" (lpVersionInformation As OSVERSIONINFOEX) As Long
Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
Private Declare Function GetProductInfo Lib "kernel32.dll" (ByVal dwOSMajorVersion As Long, ByVal dwOSMinorVersion As Long, ByVal dwSpMajorVersion As Long, ByVal dwSpMinorVersion As Long, pdwReturnedProductType As Long) As Long
Private Declare Function CheckTokenMembership Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal SidToCheck As Long, IsMember As Long) As Long
Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function GetTokenInformation Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal TokenInformationClass As Long, TokenInformation As Any, ByVal TokenInformationLength As Long, ReturnLength As Long) As Long
Private Declare Function OpenThreadToken Lib "advapi32" (ByVal ThreadHandle As Long, ByVal DesiredAccess As Long, ByVal OpenAsSelf As Long, TokenHandle As Long) As Long
Private Declare Function GetCurrentThread Lib "kernel32" () As Long
Private Declare Function GetCurrentProcess Lib "kernel32.dll" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Source As Any, ByVal lSize As Long)
Private Declare Function GetMem4 Lib "msvbvm60.dll" (Src As Any, Dst As Any) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function LocalFree Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Sub FreeSid Lib "advapi32.dll" (ByVal pSid As Long)
Private Declare Function AllocateAndInitializeSid Lib "advapi32.dll" (pIdentifierAuthority As Any, ByVal nSubAuthorityCount As Byte, ByVal nSubAuthority0 As Long, ByVal nSubAuthority1 As Long, ByVal nSubAuthority2 As Long, ByVal nSubAuthority3 As Long, ByVal nSubAuthority4 As Long, ByVal nSubAuthority5 As Long, ByVal nSubAuthority6 As Long, ByVal nSubAuthority7 As Long, lpPSid As Long) As Long
Private Declare Function IsValidSid Lib "advapi32" (ByVal pSid As Long) As Long
Private Declare Function GetSidSubAuthority Lib "advapi32.dll" (ByVal pSid As Long, ByVal nSubAuthority As Long) As Long
Private Declare Function GetSidSubAuthorityCount Lib "advapi32.dll" (ByVal pSid As Long) As Long
Private Declare Function EqualSid Lib "advapi32.dll" (pSid1 As Any, pSid2 As Any) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExW" (ByVal hKey As Long, ByVal lpSubKey As Long, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegQueryValueExStr Lib "advapi32.dll" Alias "RegQueryValueExW" (ByVal hKey As Long, ByVal lpValueName As Long, ByVal lpReserved As Long, lpType As Long, ByVal szData As Long, lpcbData As Long) As Long
Private Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExW" (ByVal hKey As Long, ByVal lpValueName As Long, ByVal lpReserved As Long, lpType As Long, szData As Long, lpcbData As Long) As Long

Private Const SM_SERVERR2               As Long = 89&
Private Const VER_NT_WORKSTATION        As Long = 1&
Private Const VER_SUITE_STORAGE_SERVER  As Long = &H2000&
Private Const VER_SUITE_DATACENTER      As Long = &H80&
Private Const VER_SUITE_PERSONAL        As Long = &H200&
Private Const VER_SUITE_ENTERPRISE      As Long = 2&
Private Const SM_CLEANBOOT              As Long = 67&
Private Const LOCALE_SYSTEM_DEFAULT     As Long = &H800&
Private Const LOCALE_USER_DEFAULT       As Long = &H400&
Private Const LOCALE_SENGLANGUAGE       As Long = &H1001&

Dim osi As OSVERSIONINFOEX

Dim OSName_             As String
Dim Family_             As String
Dim Bitness_            As String
Dim Edition_            As String
Dim MajorMinor_         As Single
Dim SPver_              As Single
Dim IsSafeBoot_         As Boolean
Dim IsElevated_         As Boolean
Dim IntegrityLevel_     As String
Dim UserType_           As String
Dim IsVistaOrLater_     As Boolean
Dim LangSystemName_     As String
Dim LangSystemCode_     As Long
Dim LangDisplayName_    As String
Dim LangDisplayCode_    As Long
Dim LangNonUnicodeName_ As String
Dim LangNonUnicodeCode_ As Long
Dim t ' not used


Private Sub Class_Initialize()
    On Error Resume Next
 
    Dim dec             As Single
    Dim ProductType     As Long
 
    LangDisplayCode_ = GetUserDefaultUILanguage Mod &H10000
    LangDisplayName_ = GetLangNameByCultureCode(LangDisplayCode_)
 
    LangSystemCode_ = GetSystemDefaultUILanguage Mod &H10000
    LangSystemName_ = GetLangNameByCultureCode(LangSystemCode_)
 
    LangNonUnicodeCode_ = GetSystemDefaultLCID Mod &H10000
    LangNonUnicodeName_ = GetLangNameByCultureCode(LangNonUnicodeCode_)
 
    osi.dwOSVersionInfoSize = Len(osi)
    GetVersionEx osi
 
    Family_ = IIf(osi.dwMajorVersion >= 6, "Vista", "NT")
    IsVistaOrLater_ = (osi.dwMajorVersion >= 6)
 
    Bitness_ = IIf(IsWin64, "x64", "x32")
 
    IsSafeBoot_ = (GetSystemMetrics(SM_CLEANBOOT) > 0) ' 0 - Normal boot, 1 - Fail-safe boot, 2 - Fail-safe with network boot
 
    ' OS Major + Minor
    dec = osi.dwMinorVersion
    If dec <> 0 Then Do: dec = dec / 10: Loop Until dec < 1
    MajorMinor_ = osi.dwMajorVersion + dec
 
    ' Service Pack Major + Minor
    dec = osi.wServicePackMinor
    If dec <> 0 Then Do: dec = dec / 10: Loop Until dec < 1
    SPver_ = osi.wServicePackMajor + dec
    
    Select Case MajorMinor_
        Case 10
            If osi.wProductType = VER_NT_WORKSTATION Then
                OSName_ = "Windows 10"
            Else
                OSName_ = "Windows 10 Server"
            End If
        Case 6.4
            OSName_ = "Windows 10 Technical Preview"
        Case 6.3
            If osi.wProductType = VER_NT_WORKSTATION Then
                OSName_ = "Windows 8.1"
            Else
                OSName_ = "Windows Server 2012 R2"
            End If
        Case 6.2
            If osi.wProductType = VER_NT_WORKSTATION Then
                OSName_ = "Windows 8"
            Else
                OSName_ = "Windows Server 2012"
            End If
        Case 6.1
            If osi.wProductType = VER_NT_WORKSTATION Then
                OSName_ = "Windows 7"
            Else
                OSName_ = "Windows Server 2008 R2"
            End If
        Case 6
            If osi.wProductType = VER_NT_WORKSTATION Then
                OSName_ = "Windows Vista"
            Else
                OSName_ = "Windows Server 2008"
            End If
        Case 5.2
            If GetSystemMetrics(SM_SERVERR2) Then
                OSName_ = "Windows Server 2003 R2"
            ElseIf osi.wSuiteMask And VER_SUITE_STORAGE_SERVER Then
                OSName_ = "Windows Storage Server 2003"
            ElseIf osi.wProductType = VER_NT_WORKSTATION And Bitness_ = "x64" Then
                OSName_ = "Windows XP"
                Edition_ = "Professional"
            Else
                OSName_ = "Windows Server 2003"
            End If
        Case 5.1
            OSName_ = "Windows XP"
            If osi.wSuiteMask = VER_SUITE_PERSONAL Then
                Edition_ = "Home Edition"
            Else
                Edition_ = "Professional"
            End If
        Case 5
            OSName_ = "Windows 2000"
            If osi.wProductType = VER_NT_WORKSTATION Then
                Edition_ = "Professional"
            Else
                If osi.wSuiteMask And VER_SUITE_DATACENTER Then
                    Edition_ = "Datacenter Server"
                ElseIf osi.wSuiteMask And VER_SUITE_ENTERPRISE Then
                    Edition_ = "Advanced Server"
                Else
                    Edition_ = "Server"
                End If
            End If
        Case Else
            OSName_ = "Windows Unknown" & "(ver. " & MajorMinor_ & ") (" & "Build: " & osi.dwBuildNumber & ")" & " Registry's data: " & GetWindowsNameFromRegistry()
    End Select

    'Редакция
    If Edition_ = "" Then
        If MajorMinor_ >= 6 Then
            If GetProductInfo(osi.dwMajorVersion, osi.dwMinorVersion, osi.wServicePackMajor, osi.wServicePackMinor, ProductType) Then
                Edition_ = GetProductName(ProductType)
            End If
        End If
    End If
 
    IsElevated_ = IsProcessElevated()
 
    IntegrityLevel_ = GetIntegrityLevel()
 
    UserType_ = GetUserType()
End Sub

Function GetWindowsNameFromRegistry() As String
    On Error GoTo ErrorHandler

    Const HKEY_LOCAL_MACHINE    As Long = &H80000002
    Const KEY_QUERY_VALUE       As Long = &H1&

    Dim OSName As String
    Dim hKey As Long
    Dim ordType As Long
    Dim cData As Long

    RegOpenKeyEx HKEY_LOCAL_MACHINE, StrPtr("SOFTWARE\Microsoft\Windows NT\CurrentVersion"), 0&, KEY_QUERY_VALUE, hKey
    RegQueryValueExLong hKey, StrPtr("ProductName"), 0&, ordType, 0&, cData
 
    If cData > 1 Then
        OSName = String$(cData - 1&, 0&)
        RegQueryValueExStr hKey, StrPtr("ProductName"), 0&, ordType, StrPtr(OSName), cData
    End If
 
    If hKey <> 0 Then RegCloseKey hKey
 
    GetWindowsNameFromRegistry = OSName
ErrorHandler:
End Function

Function IsProcessElevated(Optional hProcess As Long) As Boolean
    On Error GoTo ErrorHandler
 
    Const TOKEN_QUERY           As Long = &H8&
    Const TokenElevation        As Long = 20&
 
    Dim hToken           As Long
    Dim dwLengthNeeded   As Long
    Dim dwIsElevated     As Long
 
    ' < Win Vista. Устанавливаем true, если пользователь состоит в группе "Администраторы"
    If osi.dwMajorVersion < 6 Then IsProcessElevated = (GetUserType() = "Administrator"): Exit Function

    If hProcess = 0 Then hProcess = GetCurrentProcess()
 
    If OpenProcessToken(hProcess, TOKEN_QUERY, hToken) Then

        If 0 <> GetTokenInformation(hToken, TokenElevation, dwIsElevated, 4&, dwLengthNeeded) Then
            IsProcessElevated = (dwIsElevated <> 0)
        End If
     
        CloseHandle hToken
    End If
ErrorHandler:
End Function

Public Function GetUserType(Optional hProcess As Long) As String
    On Error GoTo ErrorHandler

    Const TOKEN_QUERY                   As Long = &H8&
    Const SECURITY_NT_AUTHORITY         As Long = 5&
    Const TokenGroups                   As Long = 2&
    Const SECURITY_BUILTIN_DOMAIN_RID   As Long = &H20&
    Const DOMAIN_ALIAS_RID_ADMINS       As Long = &H220&
    Const DOMAIN_ALIAS_RID_USERS        As Long = &H221&
    Const DOMAIN_ALIAS_RID_GUESTS       As Long = &H222&
    Const DOMAIN_ALIAS_RID_POWER_USERS  As Long = &H223&

    Dim hProcessToken   As Long
    Dim BufferSize      As Long
    Dim psidAdmin       As Long
    Dim psidPower       As Long
    Dim psidUser        As Long
    Dim psidGuest       As Long
    Dim lResult         As Long
    Dim i               As Long
    Dim tpTokens        As TOKEN_GROUPS
    Dim tpSidAuth       As SID_IDENTIFIER_AUTHORITY
 
    GetUserType = "Unknown"
    tpSidAuth.value(5) = SECURITY_NT_AUTHORITY
 
    ' в идеале, сначала нужно проверять токен, полученный от потока
    ' If Not OpenThreadToken(GetCurrentThread(), TOKEN_QUERY, True, hProcessToken) Then
    ' ограничимся токеном процесса, т.к. пока не планируем более 1 потока
 
    If hProcess = 0 Then hProcess = GetCurrentProcess()
    If 0 = OpenProcessToken(hProcess, TOKEN_QUERY, hProcessToken) Then Exit Function
 
    If hProcessToken Then

        ' Определяем требуемый размер буфера
        GetTokenInformation hProcessToken, ByVal TokenGroups, 0&, 0&, BufferSize
     
        If BufferSize Then
            ReDim InfoBuffer((BufferSize \ 4) - 1) As Long  ' Переводим размер byte -> Long
         
            ' Получаем информацию о SID-ах групп, ассоциированных с этим токеном
            If 0 <> GetTokenInformation(hProcessToken, ByVal TokenGroups, InfoBuffer(0), BufferSize, BufferSize) Then
         
                ' Заполняем структуру из буфера
                Call CopyMemory(tpTokens, InfoBuffer(0), Len(tpTokens))
         
                ' Получаем SID-ы каждого типа пользователей
                lResult = AllocateAndInitializeSid(tpSidAuth, 2&, SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, 0&, 0&, 0&, 0&, 0&, 0&, psidAdmin)
                lResult = AllocateAndInitializeSid(tpSidAuth, 2&, SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_POWER_USERS, 0&, 0&, 0&, 0&, 0&, 0&, psidPower)
                lResult = AllocateAndInitializeSid(tpSidAuth, 2&, SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_USERS, 0&, 0&, 0&, 0&, 0&, 0&, psidUser)
                lResult = AllocateAndInitializeSid(tpSidAuth, 2&, SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_GUESTS, 0&, 0&, 0&, 0&, 0&, 0&, psidGuest)
         
                If IsValidSid(psidAdmin) And IsValidSid(psidPower) And IsValidSid(psidUser) And IsValidSid(psidGuest) Then
               
                    For i = 0 To tpTokens.GroupCount
                        ' Берем SID каждой из ассоциированных групп
                        If IsValidSid(tpTokens.Groups(i).Sid) Then
                            ' Проверяем на соответствие
                            If EqualSid(ByVal tpTokens.Groups(i).Sid, ByVal psidAdmin) Then
                                GetUserType = "Administrator":  Exit For
                            ElseIf EqualSid(ByVal tpTokens.Groups(i).Sid, ByVal psidPower) Then
                                GetUserType = "Power User":     Exit For
                            ElseIf EqualSid(ByVal tpTokens.Groups(i).Sid, ByVal psidUser) Then
                                GetUserType = "Limited User":   Exit For
                            ElseIf EqualSid(ByVal tpTokens.Groups(i).Sid, ByVal psidGuest) Then
                                GetUserType = "Guest":          Exit For
                            End If
                        End If
                    Next
                End If
                If psidAdmin Then FreeSid psidAdmin
                If psidPower Then FreeSid psidPower
                If psidUser Then FreeSid psidUser
                If psidGuest Then FreeSid psidGuest
            End If
        End If
        CloseHandle hProcessToken
    End If
    Exit Function
ErrorHandler:
    If hProcessToken Then CloseHandle hProcessToken
End Function

Function GetIntegrityLevel(Optional hProcess As Long) As String       'https://msdn.microsoft.com/en-us/library/bb625966.aspx?f=255
    On Error GoTo ErrorHandler
 
    Const SECURITY_MANDATORY_UNTRUSTED_RID          As Long = 0&
    Const SECURITY_MANDATORY_LOW_RID                As Long = &H1000&
    Const SECURITY_MANDATORY_MEDIUM_RID             As Long = &H2000&
    Const SECURITY_MANDATORY_HIGH_RID               As Long = &H3000&
    Const SECURITY_MANDATORY_SYSTEM_RID             As Long = &H4000&
    Const SECURITY_MANDATORY_PROTECTED_PROCESS_RID  As Long = &H5000&
 
    Const TokenIntegrityLevel       As Long = 25&
    Const TOKEN_QUERY               As Long = &H8&
    Const ERROR_INSUFFICIENT_BUFFER As Long = &H7A&
 
    Dim hToken           As Long
    Dim dwLengthNeeded   As Long
    Dim bTIL()           As Byte
    Dim pSidSub          As Long
    Dim dwIntegrityLevel As Long
    Dim pSidAuthCnt      As Long
    Dim SidAuthCnt       As Long
    Dim pILSid           As Long
    Dim ILevel           As String
 
    If osi.dwMajorVersion < 6 Then GetIntegrityLevel = "Not supported": Exit Function ' < Win Vista
 
    ILevel = "Unknown"
 
    If hProcess = 0 Then hProcess = GetCurrentProcess()
 
    If OpenProcessToken(hProcess, TOKEN_QUERY, hToken) Then
 
        GetTokenInformation hToken, TokenIntegrityLevel, 0&, 0&, dwLengthNeeded
     
        If ERROR_INSUFFICIENT_BUFFER = Err.LastDllError Then
     
            ReDim bTIL(dwLengthNeeded - 1)
     
            If 0 <> GetTokenInformation(hToken, TokenIntegrityLevel, bTIL(0), dwLengthNeeded, dwLengthNeeded) Then
     
                GetMem4 bTIL(0), pILSid
             
                If IsValidSid(pILSid) Then

                    pSidAuthCnt = GetSidSubAuthorityCount(pILSid)
                 
                    If pSidAuthCnt Then
                 
                        GetMem4 ByVal pSidAuthCnt, SidAuthCnt
                     
                        If SidAuthCnt Then
                     
                            pSidSub = GetSidSubAuthority(pILSid, SidAuthCnt - 1)
                 
                            If pSidSub Then GetMem4 ByVal pSidSub, dwIntegrityLevel
                 
                            Select Case dwIntegrityLevel
                         
                                Case Is < SECURITY_MANDATORY_UNTRUSTED_RID
                                    ILevel = "Unknown"
                                Case Is < SECURITY_MANDATORY_LOW_RID
                                    ILevel = "Untrusted"
                                Case Is < SECURITY_MANDATORY_MEDIUM_RID
                                    ILevel = "Low"
                                Case Is < SECURITY_MANDATORY_HIGH_RID
                                    ILevel = "Medium"
                                Case Is < SECURITY_MANDATORY_SYSTEM_RID
                                    ILevel = "High"
                                Case Is < SECURITY_MANDATORY_PROTECTED_PROCESS_RID
                                    ILevel = "System"
                                Case Else
                                    ILevel = "ProtectedProcess"
                            End Select
                        End If
                    End If
                    FreeSid pILSid
                End If
            End If
        End If
        CloseHandle hToken
    End If
    GetIntegrityLevel = ILevel
    Exit Function
ErrorHandler:
    If hToken Then CloseHandle hToken
End Function

Function GetProductName(ProductType As Long) As String
    On Error Resume Next
 
    Dim ProductName As String
 
    Select Case ProductType
    Case &H6&
        ProductName = "Business"
    Case &H10&
        ProductName = "Business N"
    Case &H12&
        ProductName = "HPC Edition"
    Case &H40&
        ProductName = "Server Hyper Core V"
    Case &H65&
        ProductName = "" '"Windows 8"
    Case &H62&
        ProductName = "N" ' "Windows 8 N"
    Case &H63&
        ProductName = "China" ' "Windows 8 China"
    Case &H64&
        ProductName = "Single Language" ' "Windows 8 Single Language"
    Case &H50&
        ProductName = "Server Datacenter (EI)"
    Case &H8&
        ProductName = "Server Datacenter (FI)"
    Case &HC&
        ProductName = "Server Datacenter (CI)"
    Case &H27&
        ProductName = "Server Datacenter without Hyper-V (CI)"
    Case &H25&
        ProductName = "Server Datacenter without Hyper-V (FI)"
    Case &H4&
        ProductName = "Enterprise"
    Case &H46&
        ProductName = "Not supported"
    Case &H54&
        ProductName = "Enterprise N (EI)"
    Case &H1B&
        ProductName = "Enterprise N"
    Case &H48&
        ProductName = "Server Enterprise (EI)"
    Case &HA&
        ProductName = "Server Enterprise (FI)"
    Case &HE&
        ProductName = "Server Enterprise (CI)"
    Case &H29&
        ProductName = "Server Enterprise without Hyper-V (CI)"
    Case &HF&
        ProductName = "Server Enterprise for Itanium-based Systems"
    Case &H26&
        ProductName = "Server Enterprise without Hyper-V (FI)"
    Case &H3B&
        ProductName = "Windows Essential Server Solution Management"
    Case &H3C&
        ProductName = "Windows Essential Server Solution Additional"
    Case &H3D&
        ProductName = "Windows Essential Server Solution Management SVC"
    Case &H3E&
        ProductName = "Windows Essential Server Solution Additional SVC"
    Case &H2&
        ProductName = "Home Basic"
    Case &H43&
        ProductName = "Not supported"
    Case &H5&
        ProductName = "Home Basic N"
    Case &H3&
        ProductName = "Home Premium"
    Case &H44&
        ProductName = "Not supported"
    Case &H1A&
        ProductName = "Home Premium N"
    Case &H22&
        ProductName = "Windows Home Server 2011"
    Case &H13&
        ProductName = "Windows Storage Server 2008 R2 Essentials"
    Case &H2A&
        ProductName = "Microsoft Hyper-V Server"
    Case &H1E&
        ProductName = "Windows Essential Business Server Management Server"
    Case &H20&
        ProductName = "Windows Essential Business Server Messaging Server"
    Case &H1F&
        ProductName = "Windows Essential Business Server Security Server"
    Case &H4C&
        ProductName = "Windows MultiPoint Server Standard (FI)"
    Case &H4D&
        ProductName = "Windows MultiPoint Server Premium (FI)"
    Case &H30&
        ProductName = "Professional"
    Case &H45&
        ProductName = "Not supported"
    Case &H31&
        ProductName = "Professional N"
    Case &H67&
        ProductName = "Professional with Media Center"
    Case &H36&
        ProductName = "Server For SB Solutions EM"
    Case &H33&
        ProductName = "Server For SB Solutions"
    Case &H37&
        ProductName = "Server For SB Solutions EM"
    Case &H18&
        ProductName = "Windows Server 2008 for Windows Essential Server Solutions"
    Case &H23&
        ProductName = "Windows Server 2008 without Hyper-V for Windows Essential Server Solutions"
    Case &H21&
        ProductName = "Server Foundation"
    Case &H32&
        ProductName = "Windows Small Business Server 2011 Essentials"
    Case &H9&
        ProductName = "Windows Small Business Server"
    Case &H19&
        ProductName = "Small Business Server Premium"
    Case &H3F&
        ProductName = "Small Business Server Premium (CI)"
    Case &H38&
        ProductName = "Windows MultiPoint Server"
    Case &H4F&
        ProductName = "Server Standard (EI)"
    Case &H7&
        ProductName = "Server Standard"
    Case &HD&
        ProductName = "Server Standard (CI)"
    Case &H24&
        ProductName = "Server Standard without Hyper-V"
    Case &H28&
        ProductName = "Server Standard without Hyper-V (CI)"
    Case &H34&
        ProductName = "Server Solutions Premium"
    Case &H35&
        ProductName = "Server Solutions Premium (CI)"
    Case &HB&
        ProductName = "Starter"
    Case &H42&
        ProductName = "Not supported"
    Case &H2F&
        ProductName = "Starter N"
    Case &H17&
        ProductName = "Storage Server Enterprise"
    Case &H2E&
        ProductName = "Storage Server Enterprise (CI)"
    Case &H14&
        ProductName = "Storage Server Express"
    Case &H2B&
        ProductName = "Storage Server Express (CI)"
    Case &H60&
        ProductName = "Storage Server Standard (EI)"
    Case &H15&
        ProductName = "Storage Server Standard"
    Case &H2C&
        ProductName = "Storage Server Standard (CI)"
    Case &H5F&
        ProductName = "Storage Server Workgroup (EI)"
    Case &H16&
        ProductName = "Storage Server Workgroup"
    Case &H2D&
        ProductName = "Storage Server Workgroup (CI)"
    Case &H0&
        ProductName = "An unknown product"
    Case &H1&
        ProductName = "Ultimate"
    Case &H47&
        ProductName = "Not supported"
    Case &H1C&
        ProductName = "Ultimate N"
    Case &H11&
        ProductName = "Web Server (FI)"
    Case &H1D&
        ProductName = "Web Server (CI)"
    Case Else
        ProductName = "Unknown Edition"
    End Select

    GetProductName = ProductName
End Function


Function GetLangNameByCultureCode(CultureCode As Long) As String
    Dim Lang$
    Select Case CultureCode
        Case &H419&
            'Lang = "ru-RU"
            Lang = "RU"
        Case &H409&
            'Lang = "en-US"
            Lang = "EN"
        Case &H422&
            'Lang = "uk-UA"
            Lang = "UA"
        Case &H423&
            Lang = "be-BY"
        Case &H402&
            'Lang = "bg-BG"
            Lang = "BG"
        Case &H436&
            Lang = "af-ZA"
        Case &H41C&
            Lang = "sq-AL"
        Case &H1401&
            Lang = "ar-DZ"
        Case &H3C01&
            Lang = "ar-BH"
        Case &HC01&
            Lang = "ar-EG"
        Case &H801&
            Lang = "ar-IQ"
        Case &H2C01&
            Lang = "ar-JO"
        Case &H3401&
            Lang = "ar-KW"
        Case &H3001&
            Lang = "ar-LB"
        Case &H1001&
            Lang = "ar-LY"
        Case &H1801&
            Lang = "ar-MA"
        Case &H2001&
            Lang = "ar-OM"
        Case &H4001&
            Lang = "ar-QA"
        Case &H401&
            Lang = "ar-SA"
        Case &H2801&
            Lang = "ar-SY"
        Case &H1C01&
            Lang = "ar-TN"
        Case &H3801&
            Lang = "ar-AE"
        Case &H2401&
            Lang = "ar-YE"
        Case &H42B&
            Lang = "hy-AM"
        Case &H82C&
            Lang = "Cy-az-AZ"
        Case &H42C&
            Lang = "Lt-az-AZ"
        Case &H42D&
            Lang = "eu-ES"
        Case &H403&
            Lang = "ca-ES"
        Case &H804&
            Lang = "zh-CN"
        Case &HC04&
            Lang = "zh-HK"
        Case &H1404&
            Lang = "zh-MO"
        Case &H1004&
            Lang = "zh-SG"
        Case &H404&
            Lang = "zh-TW"
        Case &H4&
            Lang = "zh-CHS"
        Case &H7C04&
            Lang = "zh-CHT"
        Case &H41A&
            Lang = "hr-HR"
        Case &H405&
            Lang = "cs-CZ"
        Case &H406&
            Lang = "da-DK"
        Case &H465&
            Lang = "div-MV"
        Case &H813&
            Lang = "nl-BE"
        Case &H413&
            Lang = "nl-NL"
        Case &HC09&
            Lang = "en-AU"
        Case &H2809&
            Lang = "en-BZ"
        Case &H1009&
            Lang = "en-CA"
        Case &H2409&
            Lang = "en-CB"
        Case &H1809&
            Lang = "en-IE"
        Case &H2009&
            Lang = "en-JM"
        Case &H1409&
            Lang = "en-NZ"
        Case &H3409&
            Lang = "en-PH"
        Case &H1C09&
            Lang = "en-ZA"
        Case &H2C09&
            Lang = "en-TT"
        Case &H809&
            Lang = "en-GB"
        Case &H3009&
            Lang = "en-ZW"
        Case &H425&
            Lang = "et-EE"
        Case &H438&
            Lang = "fo-FO"
        Case &H429&
            Lang = "fa-IR"
        Case &H40B&
            Lang = "fi-FI"
        Case &H80C&
            Lang = "fr-BE"
        Case &HC0C&
            Lang = "fr-CA"
        Case &H40C&
            Lang = "fr-FR"
        Case &H140C&
            Lang = "fr-LU"
        Case &H180C&
            Lang = "fr-MC"
        Case &H100C&
            Lang = "fr-CH"
        Case &H456&
            Lang = "gl-ES"
        Case &H437&
            Lang = "ka-GE"
        Case &HC07&
            Lang = "de-AT"
        Case &H407&
            Lang = "de-DE"
        Case &H1407&
            Lang = "de-LI"
        Case &H1007&
            Lang = "de-LU"
        Case &H807&
            Lang = "de-CH"
        Case &H408&
            Lang = "el-GR"
        Case &H447&
            Lang = "gu-IN"
        Case &H40D&
            Lang = "he-IL"
        Case &H439&
            Lang = "hi-IN"
        Case &H40E&
            Lang = "hu-HU"
        Case &H40F&
            Lang = "is-IS"
        Case &H421&
            Lang = "id-ID"
        Case &H410&
            Lang = "it-IT"
        Case &H810&
            Lang = "it-CH"
        Case &H411&
            Lang = "ja-JP"
        Case &H44B&
            Lang = "kn-IN"
        Case &H43F&
            Lang = "kk-KZ"
        Case &H457&
            Lang = "kok-IN"
        Case &H412&
            Lang = "ko-KR"
        Case &H440&
            Lang = "ky-KZ"
        Case &H426&
            Lang = "lv-LV"
        Case &H427&
            Lang = "lt-LT"
        Case &H42F&
            Lang = "mk-MK"
        Case &H83E&
            Lang = "ms-BN"
        Case &H43E&
            Lang = "ms-MY"
        Case &H44E&
            Lang = "mr-IN"
        Case &H450&
            Lang = "mn-MN"
        Case &H414&
            Lang = "nb-NO"
        Case &H814&
            Lang = "nn-NO"
        Case &H415&
            Lang = "pl-PL"
        Case &H416&
            Lang = "pt-BR"
        Case &H816&
            Lang = "pt-PT"
        Case &H446&
            Lang = "pa-IN"
        Case &H418&
            Lang = "ro-RO"
        Case &H44F&
            Lang = "sa-IN"
        Case &HC1A&
            Lang = "Cy-sr-SP"
        Case &H81A&
            Lang = "Lt-sr-SP"
        Case &H41B&
            Lang = "sk-SK"
        Case &H424&
            Lang = "sl-SI"
        Case &H2C0A&
            Lang = "es-AR"
        Case &H400A&
            Lang = "es-BO"
        Case &H340A&
            Lang = "es-CL"
        Case &H240A&
            Lang = "es-CO"
        Case &H140A&
            Lang = "es-CR"
        Case &H1C0A&
            Lang = "es-DO"
        Case &H300A&
            Lang = "es-EC"
        Case &H440A&
            Lang = "es-SV"
        Case &H100A&
            Lang = "es-GT"
        Case &H480A&
            Lang = "es-HN"
        Case &H80A&
            Lang = "es-MX"
        Case &H4C0A&
            Lang = "es-NI"
        Case &H180A&
            Lang = "es-PA"
        Case &H3C0A&
            Lang = "es-PY"
        Case &H280A&
            Lang = "es-PE"
        Case &H500A&
            Lang = "es-PR"
        Case &HC0A&
            Lang = "es-ES"
        Case &H380A&
            Lang = "es-UY"
        Case &H200A&
            Lang = "es-VE"
        Case &H441&
            Lang = "sw-KE"
        Case &H81D&
            Lang = "sv-FI"
        Case &H41D&
            Lang = "sv-SE"
        Case &H45A&
            Lang = "syr-SY"
        Case &H449&
            Lang = "ta-IN"
        Case &H444&
            Lang = "tt-RU"
        Case &H44A&
            Lang = "te-IN"
        Case &H41E&
            Lang = "th-TH"
        Case &H41F&
            Lang = "tr-TR"
        Case &H420&
            Lang = "ur-PK"
        Case &H843&
            Lang = "Cy-uz-UZ"
        Case &H443&
            Lang = "Lt-uz-UZ"
        Case &H42A&
            Lang = "vi-VN"
        Case Else
            Lang = "unknown"
    End Select
    GetLangNameByCultureCode = Lang
End Function

Public Function IsWin64() As Boolean           ' Разрядность ОС
    On Error Resume Next
    Dim lIsWin64 As Long
    IsWow64Process GetCurrentProcess, lIsWin64
    IsWin64 = CBool(lIsWin64)
End Function

Public Property Get Family() As String
    Family = Family_
End Property

Public Property Get Bitness() As String
    Bitness = Bitness_
End Property

Public Property Get Major() As Long
    Major = osi.dwMajorVersion
End Property

Public Property Get Minor() As Long
    Minor = osi.dwMinorVersion
End Property

Public Property Get MajorMinor() As Single
    MajorMinor = MajorMinor_
End Property

Public Property Get Build() As Long
    Build = osi.dwBuildNumber
End Property

Public Property Get SPVer() As Single
    SPVer = SPver_
End Property

Public Property Get OSName() As String
    OSName = OSName_
End Property

Public Property Get Edition() As String
    Edition = Edition_
End Property

Public Property Get IsElevated() As Boolean
    IsElevated = IsElevated_
End Property

Public Property Get IntegrityLevel() As String
    IntegrityLevel = IntegrityLevel_
End Property

Public Property Get UserType() As String
    UserType = UserType_
End Property

Public Property Get IsSafeBoot() As Boolean
    IsSafeBoot = IsSafeBoot_
End Property

Public Property Get LangSystemCode() As Long
    LangSystemCode = LangSystemCode_
End Property

Public Property Get LangSystemName() As String
    LangSystemName = LangSystemName_
End Property

Public Property Get LangNonUnicodeCode() As Long
    LangNonUnicodeCode = LangNonUnicodeCode_
End Property

Public Property Get LangNonUnicodeName() As String
    LangNonUnicodeName = LangNonUnicodeName_
End Property

Public Property Get LangDisplayCode() As Long
    LangDisplayCode = LangDisplayCode_
End Property

Public Property Get LangDisplayName() As String
    LangDisplayName = LangDisplayName_
End Property

Public Property Get IsVistaOrLater() As Boolean
    IsVistaOrLater = IsVistaOrLater_
End Property

Для использования в ветвлениях кода, которые зависимы от версии ОС,
я в основном использую эти 2 переменные моего класса:
OSVer.IsVistaOrLater - булеановская
OSVer.MajorMinor - дробная

И заодно тебе спасибо, нашел одну критическую ошибку в нем.

 

[Кирилл]

Че то беда)

Ладно,поутру уже буду лопатить.

 

[Dragokas]

А что ты пытаешься сделать, написав переменную на голом месте.
Выведи ее в Msgbox или в окно отладки через Debug.? как у меня в примере.

 

[Кирилл]

Да,перечитал на свежую голову - все предельно ясно,класс - супер.
Очень много информации выдает,все необходимое под что я пытался портянку в полкилометра собрать))
Спасибо.