VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Registry"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
 
Option Explicit
'--------------------------
'Объявить в модуле
'Public Reg As New Registry
'--------------------------
 
Private Const ERROR_SUCCESS As Long = 0
Private Const ERROR_NO_MORE_ITEMS As Long = 259
Private Const BUFFER_SIZE As Long = 255
 
'===============================
Public Enum REG_HKEY
    HKEY_CLASSES_ROOT = &H80000000
    HKEY_CURRENT_CONFIG = &H80000005
    HKEY_CURRENT_USER = &H80000001
    HKEY_DYN_DATA = &H80000006
    HKEY_LOCAL_MACHINE = &H80000002
    HKEY_PERFORMANCE_DATA = &H80000004
    HKEY_USERS = &H80000003
    HKEY_PERF_ROOT = HKEY_LOCAL_MACHINE
End Enum
 
Public Enum REG_TYPE
    REG_SZ = 1&
    REG_EXPAND_SZ = 2&
    REG_BINARY = 3&
    REG_DWORD = 4&
    REG_MULTI_SZ = 7&
End Enum
 
Private Const REG_OPTION_NON_VOLATILE As Long = &H0&
Private Const STANDARD_RIGHTS_ALL As Long = &H1F0000
Private Const SYNCHRONIZE As Long = &H100000
Private Const READ_CONTROL As Long = &H20000
Private Const STANDARD_RIGHTS_READ As Long = (READ_CONTROL)
Private Const STANDARD_RIGHTS_WRITE As Long = (READ_CONTROL)
Private Const KEY_CREATE_LINK As Long = &H20&
Private Const KEY_CREATE_SUB_KEY As Long = &H4&
Private Const KEY_ENUMERATE_SUB_KEYS As Long = &H8&
Private Const KEY_NOTIFY As Long = &H10&
Private Const KEY_QUERY_VALUE As Long = &H1&
Private Const KEY_SET_VALUE As Long = &H2&
Private Const KEY_READ As Long = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Private Const KEY_WRITE As Long = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
Private Const KEY_EXECUTE As Long = (KEY_READ)
Private Const KEY_ALL_ACCESS As Long = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
Private Const KEY_WOW64_64KEY As Long = &H100&
Private Const KEY_WOW64_32KEY As Long = &H200&
Private Const REG_CREATED_NEW_KEY As Long = &H1
Private Const REG_OPENED_EXISTING_KEY As Long = &H2
 
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As Any) As Long
Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes As Any, phkResult As Long, lpdwDisposition As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As REG_HKEY) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
 
Public Function DelKey(ByVal hKey As REG_HKEY, ByVal strPath As String, ByVal strValue As String, Optional ByVal x64 As Boolean = False) As Boolean
    Dim Ret As Long, KEY_WOW  As Long
    If x64 Then
        KEY_WOW = KEY_WOW64_64KEY
    Else
        KEY_WOW = KEY_WOW64_32KEY
    End If
    RegOpenKeyEx hKey, strPath, 0, KEY_ALL_ACCESS Or KEY_WOW, Ret
    If Ret <> 0 Then
        RegDeleteValue Ret, strValue
    End If
    RegCloseKey Ret
End Function
 
Public Function DelSection(ByVal hKey As REG_HKEY, ByVal strPath As String, Optional ByVal x64 As Boolean = False) As Boolean
    Dim Ret As Long, KEY_WOW  As Long
    If x64 Then
        KEY_WOW = KEY_WOW64_64KEY
    Else
        KEY_WOW = KEY_WOW64_32KEY
    End If
    RegOpenKeyEx hKey, strPath, 0, KEY_ALL_ACCESS Or KEY_WOW, Ret
    If Ret <> 0 Then
        RegDeleteKey hKey, strPath
    End If
    RegCloseKey Ret
End Function
 
'Запись ключа в реестр
Public Function SetKey(ByVal hKey As REG_HKEY, ByVal strPath As String, ByVal strValue As String, ByVal VarData As Variant, ByVal nType As REG_TYPE, Optional ByVal x64 As Boolean = False) As Boolean
    Dim Ret As Long, KEY_WOW  As Long, Result As Long, L As Long
    If x64 Then
        KEY_WOW = KEY_WOW64_64KEY
    Else
        KEY_WOW = KEY_WOW64_32KEY
    End If
    If RegCreateKeyEx(hKey, strPath, 0, nType, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS Or KEY_WOW, ByVal 0&, Ret, Result) = ERROR_SUCCESS Then
        Select Case nType
          Case REG_SZ
            RegSetValueEx Ret, strValue, 0, REG_SZ, ByVal CStr(VarData), Len(CStr(VarData))
          Case REG_DWORD
            RegSetValueEx Ret, strValue, 0, REG_DWORD, CLng(VarData), 4
          Case REG_BINARY
            RegSetValueEx Ret, strValue, 0, REG_BINARY, CByte(VarData), 4
        End Select
    End If
    RegCloseKey Ret
End Function
 
 
'Чтение ключа из реестра
Public Function GetKey(ByVal hKey As REG_HKEY, ByVal strPath As String, ByVal strValue As String, ByVal defData As Variant, Optional ByVal x64 As Boolean = False)
    Dim Ret As Long, KEY_WOW  As Long
    If x64 Then
        KEY_WOW = KEY_WOW64_64KEY
    Else
        KEY_WOW = KEY_WOW64_32KEY
    End If
    RegOpenKeyEx hKey, strPath, 0, KEY_READ Or KEY_WOW, Ret
    GetKey = RegQueryStringValue(Ret, strValue, defData)
    RegCloseKey Ret
End Function
 
Private Function RegQueryStringValue(ByVal hKey As Long, ByVal strValueName As String, ByVal defData)
    Dim lResult As Long, lValueType As Long, lDataBufSize As Long
    lResult = RegQueryValueEx(hKey, strValueName, 0, lValueType, ByVal 0, lDataBufSize)
    If lResult = 0 Then
        Select Case lValueType
          Case REG_SZ
            Dim DataSz As String
            DataSz = String(lDataBufSize + 1, Chr$(0))
            lResult = RegQueryValueEx(hKey, strValueName, 0, 0, ByVal DataSz, lDataBufSize)
            If lResult = 0 Then
                RegQueryStringValue = Left$(DataSz, InStr(1, DataSz, Chr$(0)) - 1)
            Else
                RegQueryStringValue = defData
            End If
          Case REG_DWORD
            Dim DataDword As Long
            lResult = RegQueryValueEx(hKey, strValueName, 0, 0, DataDword, lDataBufSize)
            If lResult = 0 Then
                RegQueryStringValue = DataDword
            Else
                RegQueryStringValue = defData
            End If
          Case REG_BINARY
            Dim DataBinary As Integer
            lResult = RegQueryValueEx(hKey, strValueName, 0, 0, DataBinary, lDataBufSize)
            If lResult = 0 Then
                RegQueryStringValue = DataBinary
            Else
                RegQueryStringValue = defData
            End If
        End Select
    Else
        RegQueryStringValue = defData
    End If
End Function
 
Public Function GetKeys(ByVal hKey As REG_HKEY, ByVal strPath As String, Optional ByVal x64 As Boolean = False) As String()
    Dim Cnt As Long, Ret As Long, nRet As Long, nRetData As Long, KEY_WOW  As Long
    Dim sName As String, sData As String
    Dim Keys() As String
    If x64 Then
        KEY_WOW = KEY_WOW64_64KEY
    Else
        KEY_WOW = KEY_WOW64_32KEY
    End If
'    Ret = BUFFER_SIZE
    'Open a registry key
    If RegOpenKeyEx(hKey, strPath, 0, KEY_READ Or KEY_WOW, Ret) = ERROR_SUCCESS Then
        'initialize
        sName = Space(BUFFER_SIZE)
        sData = Space(BUFFER_SIZE)
        nRet = BUFFER_SIZE
        nRetData = BUFFER_SIZE
        'enumerate the values
        While RegEnumValue(Ret, Cnt, sName, nRet, 0, ByVal 0&, ByVal sData, nRetData) <> ERROR_NO_MORE_ITEMS
            'show data
            If nRet > 0 Then
                ReDim Preserve Keys(Cnt)
                Keys(Cnt) = Left$(sName, nRet)
            End If
            'prepare for next value
            sName = Space(BUFFER_SIZE)
            sData = Space(BUFFER_SIZE)
            nRetData = BUFFER_SIZE
            nRet = BUFFER_SIZE
            Cnt = Cnt + 1
        Wend
        'Close the registry key
        RegCloseKey Ret
    End If
    ReDim Preserve Keys(Cnt)
    GetKeys = Keys
End Function
 
Public Function GetSections(ByVal hKey As REG_HKEY, ByVal strPath As String, Optional ByVal x64 As Boolean = False) As String()
    Dim Cnt As Long, sName As String, sData As String, Ret As Long, RetData As Long, nRet As Long, KEY_WOW  As Long
    Dim Sections() As String
    If x64 Then
        KEY_WOW = KEY_WOW64_64KEY
    Else
        KEY_WOW = KEY_WOW64_32KEY
    End If
    'Open the registry key
    If RegOpenKeyEx(hKey, strPath, 0, KEY_ALL_ACCESS Or KEY_WOW, Ret) = ERROR_SUCCESS Then
        'Create a buffer
        sName = Space(BUFFER_SIZE)
        nRet = BUFFER_SIZE
        'Enumerate the keys
        While RegEnumKeyEx(Ret, Cnt, sName, nRet, ByVal 0&, vbNullString, ByVal 0&, ByVal 0&) <> ERROR_NO_MORE_ITEMS
            'Show the enumerated key
            If nRet > 0 Then
                ReDim Preserve Sections(Cnt)
                Sections(Cnt) = Left$(sName, nRet)
            End If
            'prepare for the next key
            sName = Space(BUFFER_SIZE)
            nRet = BUFFER_SIZE
            Cnt = Cnt + 1
        Wend
        'close the registry key
        RegCloseKey hKey
    End If
    ReDim Preserve Sections(Cnt)
    GetSections = Sections
End Function

Option Explicit
 
Dim WithEvents Component As VBControlExtender
Event ObjectEvent(Info As EventInfo)
 
 
Public Property Get Obj() As Variant
    'От сюда можно получить доступ к свойствам "Component"
    Set Obj = Component.object
End Property
 
Private Sub UserControl_Initialize()
    'Варианты инициализации
    Set Component = RegSvr32("Dialogs.ocx", "dlgColor")
'    Set Component = RegSvr32("Dialogs.ocx", "dlgOpenSave")
'    Set Component = RegSvr32("Dialogs.ocx", "dlgBrawser")
End Sub
 
Private Function RegSvr32(ByVal Name$, Optional ByVal Class$) As Object
    Const r = "."
    Dim Byt() As Byte, File$, f&, j$()
    j = Split(Trim(Name), r, 2): j(1) = LCase(j(1))
    File = App.Path & "\" & Name
    On Error Resume Next
    f = GetAttr(File) And Not vbDirectory
    If f > 0 And Len(Class) Then
        GoTo FileExist:
    ElseIf Len(Class) Then
        Byt = LoadResData(Name, j(1))
        f = FreeFile
        Open File For Binary As #f
        Put #f, 1, Byt
        Close #f
FileExist:
''        Set Component = Nothing
        For f = 0 To 1 '''' Call Shell("RegSvr32 /s /u " & Name) 'Отмена регистрации
            Select Case LCase(j(1))
            Case "ocx": Licenses.Add j(0) & r & Class
                Set RegSvr32 = Controls.Add(j(0) & r & Class, Class)
            Case "dll": Set RegSvr32 = CreateObject(j(0) & r & Class)
            End Select
            If Err Then
                Call Shell("RegSvr32 /s " & Name) 'Регистрация
                Err.Clear 'Сброс ошибки
            Else: Exit For
            End If
        Next
    End If
End Function

Option Explicit
'
'   Анализ, синтактический разбор, и получение полной информации о групповом проекте
'   © FelixMacintosh (Антихакер32™)
'
Const r13 = vbCrLf, r59 = ";", r46 = ".", r47 = "/", r34 = """", r58 = ":", r32 = " "
 
Public Enum OperatorFlags '# = Деректива // $ = Декларация // % = Процедура // @ - Блок
    [@Выражение] = 0
    [$Option]
    [$DefType]
    [#Открывающий]
    [#Вариантный]
    [#Закрывающий]
    [#Константа]
    [$Константа]
    [$Открывающий]
    [$Закрывающий]
    [$Declare]
    [$Событие]
    [$Переменная]
    [%Открывающий] 'Процедурный открывающий
    [%Закрывающий]
    [@Открывающий]
    [@Вариантный]
    [@Закрывающий]
    [_Attribute] 'Скрытые параметры которые не отображаются в браузере
    [_Коментарий]
    [_Не_Лэйбл]
End Enum
 
Public Type tOperatorsInfo
    Flag As OperatorFlags
    OperatorLine As String
End Type
 
Public Type tLineInfo
    TabIndex As Long
    Label As String
    Line As String
    Operators() As tOperatorsInfo
    Coment As String
End Type
 
Public Type tModulInfo
    Name As String
    Attribute As String
    TextModule As String
    LinesInfo() As tLineInfo
End Type
 
Public Type tProjectInfo
    Name As String
    Version As String
    Company As String
    Modules() As tModulInfo
End Type
 
Public Type tGlobalInfo
    Projects() As tProjectInfo
End Type
 
Private Type myInfo
    OperatorKeys As Object
    OperatorItems As Object
    fso As Object
    mCDr As String
    bProcPart As Boolean
    IndexRepair As Long
    TabIndex As Long
    Back As Long
End Type
 
Dim t As myInfo, g As tGlobalInfo
Event AddingOperators(NewOperators As Variant, Flag As OperatorFlags)
Private Function OperatorsInfo(List, Line$, Label$) As tOperatorsInfo()
    '
    'Разбивает строку на операторы
    '
    Dim f&, j$(), j1$(), lab& '0 не проверен// 1 проверен // 2 назначен
    Dim mOperatorsInfo() As tOperatorsInfo
    j = List: Label = ""
    
    For f = 0 To UBound(j)
        t.TabIndex = t.TabIndex + t.Back: t.Back = 0 'Сброс
        j(f) = Trim$(j(f))
      
        If lab = 0 Then  'Проверяем лейбл это или нет
            If IsNumeric(j(f)) Then 'Если первый оператор число
                lab = 2: Label = j(f) & IIf(UBound(j) > 0, r58, vbNullString) 'Условия вставки двоеточия
            ElseIf f = 0 And UBound(j) > 0 And InStr(1, j(f), r32) = 0 _
            And InStr(1, j(f), r46) = 0 Then 'Проверяем лейбл это или нет
                lab = IIf(t.OperatorKeys.Exists(j(f)), 1, 2) '[Найден/Не найден] в списке операторов
                If lab = 2 Then Label = j(f) & ":" 'За строковым лейблом следующий оператор
            Else: lab = 1
                j1 = Split(j(f), , 2)
                If IsNumeric(j1(0)) Then 'Проверка если в первом операторе идет число
                    Label = j1(0): j(f) = j1(1)
                End If
            End If
        End If
        If lab <> 2 Then
            ReDim Preserve mOperatorsInfo(Ubn(mOperatorsInfo) + 1)
            With mOperatorsInfo(Ubn(mOperatorsInfo))
                .OperatorLine = j(f)
                .Flag = GetOpFlag(.OperatorLine, Line)
                'Определение для открывающих операторов
                Select Case .Flag
                Case [#Открывающий], [$Открывающий], [%Открывающий], [@Открывающий]
                    t.Back = 1
                Case Else
                    Select Case .Flag
                    Case [#Закрывающий], [$Закрывающий], [%Закрывающий], [@Закрывающий]
                        t.TabIndex = t.TabIndex - 1
                    Case [#Вариантный], [@Вариантный]
                        t.TabIndex = t.TabIndex - 1
                        t.Back = 1
                    End Select
                End Select
            End With
        End If
    Next
    OperatorsInfo = mOperatorsInfo
    
End Function
 
 
 
Public Function GetProject(FileName$) As tGlobalInfo
    '
    'Главная функция класса которая возвращает
    'полную информацию о проекте или группе проектов
    'Арг: Файловый путь с типом VBP // VBG
    '
    Erase g.Projects 'Обнуление прежних данных
    IO_Text (FileName)
    GetProject = g
    On Error GoTo 0
End Function
 
Private Function IO_Text(FileName$, Optional rec&)
    Const FindName = "Name="
    Const FindVersion = "MajorVer=/MinorVer=/RevisionVer="
    Const FindCompany = "VersionCompanyName="
    '//======
    Dim textFile$, j$(), j1$(), f&, f1&, AbsVBP$
    Dim Group() As tProjectInfo
    If rec = 0 Then t.mCDr = CurDir$
    On Error Resume Next '//= Игнорировать ошибки !
    Select Case LCase(t.fso.GetExtensionName(FileName$))
    Case "vbg"
        ChDir t.fso.GetParentFolderName(FileName$)
        textFile = t.fso.OpenTextFile(FileName).ReadAll
        j = Split(textFile, r13)
        For f = 0 To UBound(j)
            Err.Clear: AbsVBP = Trim$(Split(j(f), "=", 2)(1))
            If Err = 0 And t.fso.FileExists(AbsVBP) Then
                IO_Text t.fso.GetAbsolutePathName(AbsVBP), rec + 1
            End If
        Next
    Case "vbp"
        ChDir t.fso.GetParentFolderName(FileName$)
        textFile = t.fso.OpenTextFile(FileName).ReadAll
        j = Split(textFile, r13)
        j1 = Split(FindVersion, r47)
        ReDim Preserve g.Projects(Ubn(g.Projects) + 1)
        For f = 0 To UBound(j)
            Err.Clear: AbsVBP = Trim$(Split(j(f), "=", 2)(1))
            If InStr(1, AbsVBP, r59) Then AbsVBP = Trim$(Split(AbsVBP, r59, 2)(1))
            If t.fso.FileExists(AbsVBP) Then
                IO_Text t.fso.GetAbsolutePathName(AbsVBP), rec + 1
            End If
            With g.Projects(Ubn(g.Projects))
                For f1 = 0 To 2 'Добавление версии
                    If InStr(1, j(f), j1(f1), 1) = 1 Then
                        If f1 Then .Version = .Version & r46
                        .Version = .Version & Trim$(Mid$(j(f), Len(j1(f1)) + 1))
                    End If
                Next
                If InStr(1, j(f), FindName, 1) = 1 Then 'Добавление Name
                    .Name = Trim$(Mid$(j(f), Len(FindName) + 1))
                    .Name = Mid$(.Name, 2, Len(.Name) - 2) 'Без внутренних кавычек
                ElseIf InStr(1, j(f), FindCompany, 1) = 1 Then 'Добавление Company
                    .Company = Trim$(Mid$(j(f), Len(FindCompany) + 1))
                    .Company = Mid$(.Company, 2, Len(.Company) - 2) 'Без внутренних кавычек
                End If
            End With
        Next
    Case "frm", "bas", "cls", "ctl", "dsr", "dob"
        'Создание массива модулей
        If Ubn(g.Projects) < 0 Then ReDim Preserve g.Projects(Ubn(g.Projects) + 1) 'Если стартовым файлом был только модуль
        With g.Projects(Ubn(g.Projects))
            ReDim Preserve .Modules(Ubn(.Modules) + 1)
            .Modules(Ubn(.Modules)) = CreateModule(FileName)
        End With
    End Select
    If rec = 0 Then ChDir t.mCDr
End Function
 
Private Function CreateModule(FileName) As tModulInfo
    Const r = "Attribute VB_Name ="
    Dim AbsText As String, n&, j$(), b As Boolean
    AbsText = t.fso.OpenTextFile(FileName).ReadAll
    On Error Resume Next '//= Игнорировать ошибки !
    With CreateModule
        n = StartVbTx(AbsText)
        .Attribute = Left$(AbsText, n - 1)
        .TextModule = Mid$(AbsText, n)
        If Len(.Attribute) Then
            n = InStr(1, .Attribute, r)
            .Name = Split(Mid$(.Attribute, n), r34, 3)(1)
        End If
        .TextModule = Replace(.TextModule, " _" & r13, r32)
        j = Split(.TextModule, r13)
        .LinesInfo = LinesInfo_(j)
    End With
End Function
 
Private Function LinesInfo_(Lines() As String) As tLineInfo()
    Dim f&, TxLine$, lab&, hstr$, cmnt&, Coment$, Label$
    Dim myLinesInfo() As tLineInfo, b As Boolean
    On Error Resume Next '//= Игнорировать ошибки !
    With t
        .bProcPart = False
        .TabIndex = 0
    End With
    For f = 0 To UBound(Lines)
        TxLine = Trim$(Lines(f)): lab = 0 'Значение определение лейбла для новой строки
        If Len(TxLine) Then
            StringsHide TxLine, hstr 'Скрыть информацию в кавычках
            cmnt = InstrComent(TxLine)
            If cmnt Then Coment = Mid$(TxLine, cmnt): TxLine = Left$(TxLine, cmnt - 1) Else Coment = ""
            TxLine = ReDist(TxLine) 'Сокращение пробелов
            TxLine = Replace(TxLine, r58, vbCr) 'Замена двоеточия
            TxLine = Replace(TxLine, vbCr & r32, vbCr) 'Замена двоеточия и пробела
            StringsRepair TxLine, hstr 'Восстановить информацию в кавычках
            ReDim Preserve myLinesInfo(Ubn(myLinesInfo) + 1)
            With myLinesInfo(Ubn(myLinesInfo))
                .Operators = OperatorsInfo(Split(TxLine, vbCr), TxLine, Label$)
                .Label = Label
                .Coment = Coment
                StringsRepair .Coment, hstr  'Восстановить информацию в кавычках для коментария
                
                b = .Operators(0).Flag = [_Attribute]
                If Len(.Label) Or b Then
                    'Такой вот трюк не устанавливает индекс отступа _
                    если строка начинаеться с лейбла или атрибута
                Else: .TabIndex = t.TabIndex
                End If
                .Line = Lines(f)
            End With
        End If
    Next
    LinesInfo_ = myLinesInfo
End Function
 
Private Function GetOpFlag(Operator As String, Line$) As OperatorFlags
    '
    'Проверяет оператор по отдельным словам и возвращает значение OperatorFlags
    'Арг: Оператор // Строка целиком ! (без коментария)
    '
    Dim f&, j$(), sb$
    j = Split(Operator)
    For f = 0 To UBound(j)
        If f > 2 Then Exit For
        If f Then
            sb = sb & r32
        End If
        sb = sb & j(f)
        If sb = "If" Or sb = "#If" Then
            If StrComp(Right$(Line, 4), "Then", 1) = 0 Then
                GetOpFlag = t.OperatorKeys(sb): Exit For
            End If
        ElseIf t.OperatorKeys.Exists(sb) Then GetOpFlag = t.OperatorKeys(sb)
        End If
    Next
    
    If GetOpFlag > 0 And f > 1 Then
        If LCase(j(1)) = "as" Then
            'Такой глюк может случиться если какойто "умник" _
            в названиях переменных в блоке Type _
            будет использовать ключевые слова _
            например:  Type As String // или Next As Long
            GetOpFlag = [@Выражение] 'Сброс к обычному выражению
        End If
    End If
    If GetOpFlag = [%Открывающий] Then t.bProcPart = True
    
 
End Function
 
 
Private Sub StringsHide(tx$, hstr$)
    '
    'Прячет текст находящийся в кавычках
    '
    Dim f&, f1&, j$()
    j = Split(tx, r34)
    hstr = "": t.IndexRepair = 0
    For f = 1 To UBound(j) Step 2
        For f1 = 1 To Len(j(f))
            hstr = hstr & Mid$(j(f), f1, 1)
            Mid$(j(f), f1, 1) = vbNullChar
        Next
    Next
    tx = Join(j, r34)
End Sub
 
Private Sub StringsRepair(tx$, hstr$)
    '
    'Восстанавливает текст находящийся в кавычках
    '
    Dim n&: n = 1
    With t: Do
            n = InStr(n, tx, vbNullChar)
            If n Then
                .IndexRepair = .IndexRepair + 1
                Mid$(tx, n, 1) = Mid$(hstr, .IndexRepair, 1)
            End If
        Loop While n
    End With
End Sub
 
 
Private Function StartVbTx&(ByVal AbsText$)
    '
    'Возврат позиции начала видимого текста без атрибутов
    '
    Dim f&, I&, j$(), b As Boolean
    StartVbTx = 1
    j = Split(AbsText, r13)
 
    For f = 0 To UBound(j)
        I = InStr(1, j(f), "Attribute VB_", 1)
        If I = 1 And Not b Then
            b = True
        ElseIf I <> 1 And b Then Exit Function
        End If
        StartVbTx = StartVbTx + Len(j(f)) + 2
    Next
    If Not b Then StartVbTx = Sgn(Len(AbsText))
End Function
 
 
Public Sub AddOperators(OperKeys As Variant, item As OperatorFlags)
    '
    'Можно добавить оператор или список операторов под одним значением
    'для последующего синтактичесого анализа
    '
    Dim f&, DicItems As Object: On Error Resume Next '//= Игнорировать ошибки !
    Set DicItems = CreateObject("Scripting.Dictionary"): DicItems.CompareMode = 1
    If IsArray(OperKeys) Then
        For f = 0 To UBound(OperKeys)
            t.OperatorKeys.Add OperKeys(f), item
            DicItems.Add OperKeys(f), item
        Next
        t.OperatorItems.Add item, DicItems
    Else
        t.OperatorKeys.Add OperKeys, item
        DicItems.Add OperKeys, item
        t.OperatorItems.Add item, DicItems
    End If
End Sub
 
Private Sub CreateOperators()
    Dim s1$(), s2$(), s3$(), f1&, f2&, f3&, sb$
    Dim NewOperators As Variant, Flag As OperatorFlags
    If t.OperatorKeys Is Nothing Then
        Set t.OperatorKeys = CreateObject("Scripting.Dictionary"): t.OperatorKeys.CompareMode = 1
        Set t.OperatorItems = CreateObject("Scripting.Dictionary")
    Else: Exit Sub
    End If
    For f1 = 35 To 255
        Select Case f1
        Case 95
        Case 39 To 47, 57 To 63, 91 To 96, 123 To 126
            sb = sb & r13 & "Rem" & Chr(f1)
        End Select
    Next
    AddOperators Split("'" & r13 & "Rem " & sb, r13), [_Коментарий]
    AddOperators "Option", [$Option]
    AddOperators "Attribute", [_Attribute]
    '---------------------
    AddOperators "#If", [#Открывающий]
    AddOperators Split("#Else/#ElseIf", r47), [#Вариантный]
    AddOperators "#End If", [#Закрывающий]
    AddOperators "#Const", [#Константа]
    '-------------------------------------------------------------
    AddOperators Split("Public Const/Global Const", r47), [$Константа]
    AddOperators Split("Event/Public Event", r47), [$Событие]
    AddOperators Split("Public/Global", r47), [$Переменная]
    AddOperators Split("Public Declare/Private Declare/Declare", r47), [$Declare]
        
    s1 = Split("Public /Private /", r47)
    s2 = Split("Enum/Type", r47)
    sb = "" 'Опустошение сборки
    For f1 = 0 To UBound(s1): For f2 = 0 To UBound(s2)
            sb = sb & r47 & s1(f1) & s2(f2)
    Next: Next
    AddOperators Split(Mid$(sb, 2), r47), [$Открывающий]
    s1 = Split("Enum/Type", r47)
    sb = "" 'Опустошение сборки
    For f1 = 0 To UBound(s1)
        sb = sb & r47 & "End " & s1(f1)
    Next
    AddOperators Split(Mid$(sb, 2), r47), [$Закрывающий]
    '---------------------------------------------------------------
    s1 = Split("Public /Private /Friend /", r47)
    s2 = Split("Static /", r47)
    s3 = Split("Sub/Function/Property", r47)
    sb = "" 'Опустошение сборки
    For f1 = 0 To UBound(s1): For f2 = 0 To UBound(s2): For f3 = 0 To UBound(s3)
                sb = sb & r47 & s1(f1) & s2(f2) & s3(f3)
    Next: Next: Next
    AddOperators Split(Mid$(sb, 2), r47), [%Открывающий]
    s1 = Split("Sub/Function/Property", r47)
    sb = "" 'Опустошение сборки
    For f1 = 0 To UBound(s1)
        sb = sb & r47 & "End " & s1(f1)
    Next
    AddOperators Split(Mid$(sb, 2), r47), [%Закрывающий]
    AddOperators Split("Do/If/For/Select Case/With/While", r47), [@Открывающий]
    AddOperators Split("Else/ElseIf/Case", r47), [@Вариантный]
    AddOperators Split("End If/End Select/End With/Loop/Next/Wend", r47), [@Закрывающий]
    AddOperators Split("Close/End/Print/Randomize/Resume/Return/Stop", r47), [_Не_Лэйбл] '''Здесь слова исключающие что это лейбл
    AddOperators Split("DefBool/DefByte/DefInt/DefLng/DefCur/DefSng/DefDbl/DefDec/DefDate/DefStr/DefObj/DefVar", r47), [$DefType]
    RaiseEvent AddingOperators(NewOperators, Flag) 'Событие с возможностью добавления своих
    If Not IsEmpty(NewOperators) Then AddOperators NewOperators, Flag
End Sub
 
Private Sub Class_Initialize()
    Set t.fso = CreateObject("Scripting.FileSystemObject")
    CreateOperators
 
    
End Sub
 
 
Private Function InstrComent&(Line$)
    Dim s$, v, f&, max&, n&
    v = DicOperators([_Коментарий]).Keys
    max = Len(Line)
    For f = 0 To UBound(v): n = InStr(1, Line, v(f), 1)
        If n > 0 And n <= max Then max = n: InstrComent = max
        If n = 1 Then Exit For
    Next
End Function
 
Private Function ReDist$(ByVal tx As String)
    '
    'Reduce the distance
    'Заменить множество пробелов одним // d = сокращаемое значение
    '
    Const d = r32 & r32
    ReDist = Trim$(tx) '//Убрать также передние и задние пробелы
 
    While InStr(1, ReDist, d)
        ReDist = Replace(ReDist, d, r32)
    Wend
End Function
 
 
Private Function DicOperators(item As OperatorFlags) As Object
    Set DicOperators = t.OperatorItems(item)
End Function
 
Private Property Get Ubn&(Arr)
    Ubn = -1: On Error Resume Next: Ubn = UBound(Arr)
End Property

Private Sub Command1_Click()
    Dim sugList As SpellingSuggestions
    Dim sug As SpellingSuggestion
    Dim strSugList As String
    Dim strWord As String
    strWord = "Летела корова"
    Set sugList = GetSpellingSuggestions(Word:=strWord, SuggestionMode:=wdSpellword)
    If sugList.Count = 0 Then
        MsgBox "Слово без ошибок"
    Else
        For Each sug In sugList
            strSugList = strSugList & vbTab & sug.Name & vbLf
        Next sug
        MsgBox "Варианты замены слова """ & strWord & """:" & vbLf & strSugList
    End If
End Sub

Option Explicit
'
'© FelixMacintosh (CiberForum.ru)
'Определение текущей расскладки клавиатуры
'
Private Declare Function GetKeyboardLayoutName Lib "user32" Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long
Dim WithEvents lb As Label, WithEvents tm As Timer
Private Sub tm_Timer()
    Dim KeybLayoutName As String
    KeybLayoutName = String(9, 0)
    GetKeyboardLayoutName KeybLayoutName
    KeybLayoutName = Val(KeybLayoutName)
    Select Case KeybLayoutName
    Case 409
        lb.Caption = "Английская"
    Case 419
        lb.Caption = "Русская"
    End Select
End Sub
 
Private Sub Form_Load()
    Set lb = Controls.Add("VB.Label", "lb")
    Set tm = Controls.Add("VB.Timer", "tm")
    tm.Interval = 100
    lb.FontSize = 32
    lb.AutoSize = True
    lb.Visible = True
End Sub

Option Explicit
 
' Получить раскладку
 
Private Declare Function GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long
Private Declare Function VerLanguageName Lib "version.dll" Alias "VerLanguageNameW" (ByVal wLang As Long, ByVal szLang As Long, ByVal nSize As Long) As Long
 
Private Sub Form_Load()
    Dim n As Long, lid As Long, nam As String
    lid = GetKeyboardLayout(0)
    nam = Space(64)
    n = VerLanguageName(lid, StrPtr(nam), 128)
    nam = Left(nam, n)
    MsgBox nam
End Sub