Option Explicit
'
' © Кривоус Анатолий Анатольевич (The trick), 2014
' Модифицированно Антихакер32 (CyberForum.ru)
' Класс, для использования DLL и OCX без регистрации
'
Private Const CLSID_TLI As String = "{8B21775E-717D-11CE-AB5B-D41203C10000}"
Dim oTLI As Object, cTLI As GUID, sTLI As String
Dim mObject As Object, mPath$
Const Def_MiscStatus = 131473
Dim CollPaths As New Collection, NumColl&
Dim CollObj As New Collection
 
Private Sub CollAdd(Obj As Object, Path$)
    On Error Resume Next
    If Obj Is Nothing Then Exit Sub
    CollObj.Add Obj, Obj.Name
    CollPaths.Add Path, Path
End Sub
 
Public Function CreateObject_Int(ByVal Path$, Optional Interface) As Object
    'Использование библиотеки без регистрации
    '
    Dim sClsID$, cID As GUID, ProgID$, Item&, bEx As Boolean
    Dim TLI As Object, CC As Object
    Set TLI = oTLI.TypeLibInfoFromFile(Path)
    If IsMissing(Interface) Then
 
        For Each CC In TLI.CoClasses
            bEx = True: Exit For
        Next
    ElseIf IsNumeric(Interface) Then
 
        For Each CC In TLI.CoClasses
            Item = Item + 1: If Item = Interface Then bEx = True: Exit For
        Next
        If CC Is Nothing Then Err.Raise 1, , "Нет в коллекции CoClasses"
    ElseIf InStr(1, Interface, "{") Then
        Interface = Trim(Interface)
 
        For Each CC In TLI.CoClasses
            If Interface = CC.GUID Then bEx = True: Exit For
        Next
    Else: Interface = Trim(Interface)
        For Each CC In TLI.CoClasses
            If StrComp(Interface, CC.Name, 1) = 0 Then bEx = True: Exit For
        Next
    End If
    If bEx Then
        sClsID = CC.GUID
        CLSIDFromString StrPtr(sClsID), cID
        Set CreateObject_Int = CreateObjectEx(Path, cID)
        CollAdd CreateObject_Int, Path
    End If
 
End Function
 
Public Function ControlsAdd_Int(ByVal Path$, Parent As Object, Optional ByVal Interface, Optional _
ByVal Name$, Optional Container As Object, Optional LicensesKey$) As Object
    Dim sClsID$, cID As GUID, ProgID$, i&, Item&, bEx As Boolean
    Dim TLI As Object, CC As Object
    Set TLI = oTLI.TypeLibInfoFromFile(Path)
 
    If IsMissing(Interface) Then
        'Проверяются в коллекции CoClasses только контроллы
        '
        For Each CC In TLI.CoClasses
            If Not (CC.DefaultEventInterface Is Nothing) Then bEx = True: Exit For
        Next
    ElseIf IsNumeric(Interface) Then
 
        For Each CC In TLI.CoClasses
            'Если в Interface стоит номер,
            'то присвоение, по его очередности, в числе контроллов
            '
            If Not (CC.DefaultEventInterface Is Nothing) Then
                Item = Item + 1: If Item = Interface Then bEx = True: Exit For
            End If
        Next
        If CC Is Nothing Then Err.Raise 1, , "Нет в коллекции CoClasses"
    ElseIf InStr(1, Interface, "{") Then
        Interface = Trim(Interface)
 
        For Each CC In TLI.CoClasses
 
            If Not (CC.DefaultEventInterface Is Nothing) Then
                If Interface = CC.GUID Then bEx = True: Exit For
            End If
        Next
    Else: Interface = Trim(Interface)
 
        For Each CC In TLI.CoClasses
 
            If Not (CC.DefaultEventInterface Is Nothing) Then
                If StrComp(Interface, CC.Name, 1) = 0 Then bEx = True: Exit For
            End If
        Next
    End If
 
    If bEx Then
        sClsID = CC.GUID
        ProgID = TLI.Name & "." & CC.Name
 
        If Len(Name) = 0 Then
            Do: i = i + 1
                If Not ObjExists(Parent, CC.Name & i) Then Exit Do
            Loop
            Name = CC.Name & i
        ElseIf ObjExists(Parent, Name) Then
            Err.Raise 1, , "Объект с именем: " & Name & " существует"
        End If
 
        If Not LicensesExists(ProgID) Then
            gLicensesKey = LicensesKey
            CLSIDFromString StrPtr(sClsID), cID
            Set ControlsAdd_Int = ControlsAdd(Path, cID, ProgID, Def_MiscStatus, Parent, Name)
            CollAdd ControlsAdd_Int, Path
        Else
            Set ControlsAdd_Int = Parent.Controls.Add(ProgID, Name, IIf(Container Is Nothing, Parent, Container))
        End If
    End If
End Function
 
Private Function LicensesExists(ProgID$) As Boolean
    On Error Resume Next
 
    If IsError(Licenses(ProgID).LicenseKey) Then
    Else: LicensesExists = True
    End If
End Function
 
Private Function ObjExists(Parent As Object, Name$) As Boolean
    On Error Resume Next
 
    If IsError(Parent.Controls(Name)) Then
    Else: ObjExists = True
    End If
End Function
 
Public Function GetTypeLibInfoFromFile(ByVal Path$) As Object
    Set GetTypeLibInfoFromFile = oTLI.TypeLibInfoFromFile(Path)
End Function
 
Private Sub Class_Initialize()
    sTLI = App.Path & "\TLBINF32.DLL"
    CLSIDFromString StrPtr(CLSID_TLI), cTLI
    Set oTLI = CreateObjectEx(sTLI, cTLI)
End Sub
 
Private Sub Class_Terminate()
    Dim v
    Set oTLI = Nothing
    Call UnloadLibrary(sTLI) 'Выгружаем TLI
    '================
    For Each v In CollObj: Set v = Nothing: Next
    'Выгружаем библиотеки
    For Each v In CollPaths: Call UnloadLibrary(CStr(v)): Next
End Sub

Option Explicit
'
'Модуль для сохранения (или применения) настроек в файле
'первая в программе должна выполнится SettingsAdd
'при загрузке и при сохранении настроек, будут обращения по именам из коллекции
'© Антихакер32 (CyberForum.ru).
'
Const q$ = "[", w$ = "]", rv$ = "=", t = ".", rm = "_"
Const prompt = _
"Данные для применения настроек пусты" & vbCrLf & _
"Необходимо указать с помощью SettingsAdd", ErrNum = 101
Const m_Def_FileName = "Settings.ini"
Dim m_FileName$, m_fso As Object
Dim f&, j$(), s$, u&, v, Key$, mApply As Boolean
Dim Co As New Collection, coDat As New Collection
 
Public Sub SettingsAdd(Obj As Object, ParamArray arg())
    'Необходимо указать форму или контрол, и имена свойств для сохранения
    'напимер: SettingsAdd Form1, "left","top"
    Dim SingleObject As Object, count&
    v = arg: ReDim Preserve v(UBound(v) + 2)
    If UBound(v) = 1 Or Obj Is Nothing Then Exit Sub '>>Выход
    On Error Resume Next
    If Not TypeName(Obj) = "Object" Then
        Set SingleObject = Obj: GoTo 101
    Else
        For Each SingleObject In Obj
101
            Key = GetKey(SingleObject): If KeyExists(Key) Then Co.Remove (Key)
            Set v(UBound(v) - 1) = SingleObject: v(UBound(v)) = Key: Co.Add v, Key
        Next
    End If
End Sub
 
Private Function KeyExists(Key$) As Boolean
    'Возвращает утверждение о наличии ключа
    On Error Resume Next
    KeyExists = Not IsError(Co(Key))
End Function
 
Private Function GetFso() As Object
    If m_fso Is Nothing Then Set m_fso = CreateObject("scripting.FileSystemObject")
    Set GetFso = m_fso
End Function
 
Private Function GetKey(Obj As Object)
    On Error Resume Next
    GetKey = Obj.Name: GetKey = Obj.Parent.Name & t & GetKey: GetKey = GetKey & rm & Obj.Index
End Function
 
Public Sub ApplySettings(Obj As Object)
    'Применение настроек для одного указанного объекта
    If coDat.count = 0 Then mApply = True: LoadSettingsINI: mApply = False
    On Error GoTo ERRR
    v = Co(GetKey(Obj)): u = UBound(v)
    For f = 0 To u - 2: CallByName v(u - 1), v(f), VbLet, coDat(v(u) & t & v(f)): Next
ERRR:
End Sub
 
Public Sub LoadSettingsINI(Optional FileName$ = m_Def_FileName)
    'Загрузка и приминение всех настроек
    'Арг. имя файла (по умолчанию "Settings.ini")
    Dim f2&, j1$(), j2$(), j3$()
    If Co.count = 0 Then Err.Raise ErrNum, , prompt
    On Error Resume Next
    m_FileName = App.Path & "\" & FileName
    If Not GetFso.FileExists(m_FileName) Then SaveSettingsINI
    s = GetFso.OpenTextFile(m_FileName).ReadAll
    j = Split(s, q)
    For f = 1 To UBound(j)
        j1 = Split(j(f), w)
        j2 = Split(j1(1), vbCrLf)
        For f2 = 1 To UBound(j2) - 1
            j3 = Split(j2(f2), rv)
            coDat.Add j3(1), j1(0) & t & j3(0)
    Next: Next
    If mApply Then Exit Sub '>>Если вызванно процедурой ApplySettings
    For Each v In Co: u = UBound(v) '---------Применение настроек
        For f = 0 To u - 2
            CallByName v(u - 1), v(f), VbLet, coDat(v(u) & t & v(f))
    Next: Next
End Sub
 
Public Sub SaveSettingsINI()
    'Сохранение настроек
    If Co.count = 0 Then Err.Raise ErrNum, , prompt
    If Len(m_FileName) = 0 Then m_FileName = App.Path & "\" & m_Def_FileName
    With GetFso.CreateTextFile(m_FileName)
        On Error Resume Next
        For Each v In Co
            u = UBound(v)
            v(u - 1).WindowState = 0
            .WriteLine q & v(u) & w
            For f = 0 To u - 2
                 .WriteLine v(f) & rv & CStr(CallByName(v(u - 1), v(f), VbGet))
    Next: Next: End With
End Sub

Option Explicit
 
Sub Main()
    Dim sFile   As String
    Dim ff      As Integer
    Dim Size    As Long
    Dim Rest    As Long
    
    sFile = Command()
    
    If Len(sFile) = 0 Then MsgBox "Использование: " & App.EXEName & " " & "file.txt": End
    
    ff = FreeFile()
    
    sFile = UnQuote(sFile)
    
    Open sFile For Binary Access Read Write As #ff
        Size = LOF(ff)
        Rest = 4 - (Size Mod 4)
        If Rest <> 0 And Rest <> 4 Then
            Put #ff, Size + 1, String$(Rest, Chr$(0))
        End If
    Close #ff
    
End Sub
 
Function UnQuote(Str As String) As String   ' Убрать обрамление кавычками
    Dim s As String: s = Str
    Do While Left$(s, 1&) = """"
        s = Mid$(s, 2&)
    Loop
    Do While Right$(s, 1&) = """"
        s = Left$(s, Len(s) - 1&)
    Loop
    UnQuote = s
End Function

Option Explicit
 
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 GetVersionEx Lib "kernel32.dll" Alias "GetVersionExW" (lpVersionInformation As Any) 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 lstrlen Lib "kernel32.dll" Alias "lstrlenW" (ByVal lpString As Long) As Long
'Private Declare Function ConvertStringSidToSid Lib "advapi32.dll" Alias "ConvertStringSidToSidW" (ByVal StringSid As Long, Sid As Long) As Long
'Private Declare Function ConvertSidToStringSid Lib "advapi32.dll" Alias "ConvertSidToStringSidW" (ByVal Sid As Long, StringSid 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 Sub Form_Load()
    Dim sLog$
    sLog = sLog & "UserType:        " & GetUserType() & vbCrLf
    sLog = sLog & "UAC Elevated:    " & IsElevated() & vbCrLf
    sLog = sLog & "Integrity Level: " & GetIntegrityLevel() & vbCrLf
    Debug.Print sLog
    MsgBox sLog
    End
End Sub
 
Function IsElevated(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, если пользователь состоит в группе "Администраторы"
    Dim inf(68) As Long: inf(0) = 276: GetVersionEx inf(0): If inf(1) < 6 Then IsElevated = (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
            IsElevated = (dwIsElevated <> 0)
        End If
        
        CloseHandle hToken
    End If
    Exit Function
ErrorHandler:
    Debug.Print Err; Now; "clsOSInfo.IsElevated"
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:
    Debug.Print Err; Now; "clsOSInfo.GetUserType"
End Function
 
'Function SID_2_String(pSid As Long) As String
'    Dim lpString As Long
'    Dim sSid     As String
'    If ConvertSidToStringSid(pSid, lpString) Then
'        sSid = Space$(lstrlen(lpString) \ 2)
'        CopyMemory ByVal StrPtr(sSid), ByVal lpString, Len(sSid) * 2
'        LocalFree lpString
'        SID_2_String = sSid
'    End If
'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
    
    Dim inf(68) As Long: inf(0) = 276: GetVersionEx inf(0): If inf(1) < 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:
    Debug.Print Err; Now; "clsOSInfo.GetIntegrityLevel"
End Function