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

Тема в разделе "Visual Basic 6 / Сценарии VBScript, JScript", создана пользователем Kиpилл, 30 июн 2015.

  1. Kиpилл
    Оффлайн

    Kиpилл Команда форума Администратор

    Лучший автор месяца

    Сообщения:
    12.224
    Симпатии:
    4.979
    Я использовал такой вариант:

    Код (vb.net):

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

        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
         
           

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

    Код (vb.net):
    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
    Может еще варианты?
     
    Последнее редактирование: 30 июн 2015
  2. Dragokas
    Оффлайн

    Dragokas Very kind Developer Команда форума Супер-Модератор Разработчик Клуб переводчиков

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

    Kиpилл Команда форума Администратор

    Лучший автор месяца

    Сообщения:
    12.224
    Симпатии:
    4.979
    +
    Если не затруднит)

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

    Dragokas Very kind Developer Команда форума Супер-Модератор Разработчик Клуб переводчиков

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

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

    Правила пользования просты. Сначала создаешь экземпляр класса:
    Код (Text):
    Dim OSVer As New clsOSInfo
    Перед выходом - уничтожаешь:
    Код (Text):
    Set OSVer = Nothing
    В коде формы все вместе это выглядит так:
    Код (vb.net):
    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
    Сам код класса:
    Код (vb.net):
    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 - дробная

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

    Вложения:

    • proj.zip
      Размер файла:
      8,4 КБ
      Просмотров:
      4
    Последнее редактирование: 30 июн 2015
    Kиpилл нравится это.
  5. Kиpилл
    Оффлайн

    Kиpилл Команда форума Администратор

    Лучший автор месяца

    Сообщения:
    12.224
    Симпатии:
    4.979
    Че то беда)
    upload_2015-7-1_2-11-0.png


    Ладно,поутру уже буду лопатить.
     
  6. Dragokas
    Оффлайн

    Dragokas Very kind Developer Команда форума Супер-Модератор Разработчик Клуб переводчиков

    Сообщения:
    4.492
    Симпатии:
    4.307
    А что ты пытаешься сделать, написав переменную на голом месте.
    Выведи ее в Msgbox или в окно отладки через Debug.? как у меня в примере.
     
  7. Kиpилл
    Оффлайн

    Kиpилл Команда форума Администратор

    Лучший автор месяца

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

Поделиться этой страницей