MyTetra Share
Делитесь знаниями!
WinApi (считать параметры системы)
Время создания: 31.07.2019 22:37
Раздел: !Закладки - VBA
Запись: adgaver/mytetra_base_New/master/base/1487158245px3o5l4gz7/text.html на raw.githubusercontent.com


Найдите текущий язык пользователя

Function fun_OS_Lang() As Integer

fun_OS_Lang = Application.International(XlApplicationInternational.xlCountryCode)

End Function


Select Case Application.International(xlApplicationInternational.xlCountryCode)

   Case 1: Call MsgBox("English") 
   Case 33: Call MsgBox("French") 
   Case 49: Call MsgBox("German") 
   Case 81: Call MsgBox("Japanese") 
End Select 




'===============================================================

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
 

Так же в этом разделе:
 
MyTetra Share v.0.55
Яндекс индекс цитирования