Искуственный интеллект

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