Attribute VB_Name = "Module2"
'Преобразует и группирует номера УД
'by Ilyashev Anton 06562@bk.ru
' v. 0.6 2025

Option Explicit

' =========================
' Прогресс в строке состояния Word
' =========================
Private Sub ShowProgress(current As Long, total As Long, Optional label As String = "")
    If total = 0 Then
        Application.StatusBar = ""
        DoEvents
        Exit Sub
    End If

    Dim pct As Long
    pct = CLng((CDbl(current) / CDbl(total)) * 100)

    Dim filled As Long
    filled = CLng(pct / 5)   ' 20 блоков = 100%
    Dim barStr As String
    barStr = String(filled, ChrW(9608)) & String(20 - filled, ChrW(9617))

    Dim msg As String
    msg = IIf(Len(label) > 0, label & "  ", "") & _
          "[" & barStr & "] " & pct & "%"

    Application.StatusBar = msg
    DoEvents
End Sub

' =========================
' Вспомогательные функции
' =========================
Private Function CreateHttp() As Object
    On Error Resume Next
    Set CreateHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    If CreateHttp Is Nothing Then Set CreateHttp = CreateObject("MSXML2.ServerXMLHTTP")
    If CreateHttp Is Nothing Then Set CreateHttp = CreateObject("MSXML2.XMLHTTP.6.0")
    If CreateHttp Is Nothing Then Set CreateHttp = CreateObject("MSXML2.XMLHTTP")
    On Error GoTo 0
End Function

Private Function HttpPostJson(url As String, body As String) As String
    Dim http As Object
    Set http = CreateHttp()
    http.Open "POST", url, False
    http.setRequestHeader "Content-Type", "application/json; charset=utf-8"
    http.Send body
    HttpPostJson = http.responseText
End Function

Private Function MakePayloadFromSelection(selText As String) As String
    Dim s As String
    s = Trim(selText)
    s = Replace(s, vbCr, " ")
    s = Replace(s, vbLf, " ")
    s = Replace(s, vbTab, " ")
    s = Replace(s, ";", " ")
    s = Replace(s, ",", " ")
    s = Trim(Replace(Replace(Replace(s, "  ", " "), "  ", " "), "  ", " "))
    MakePayloadFromSelection = "{""input_data"":""" & s & """}"
End Function

' =========================
' Парсинг JSON
' =========================
Private Function ExtractNumberSubdivisionPairs(jsonText As String) As Collection
    Dim re As Object, m As Object, i As Long
    Set ExtractNumberSubdivisionPairs = New Collection

    Set re = CreateObject("VBScript.RegExp")
    re.Global = True
    re.IgnoreCase = True
    re.MultiLine = False
    re.Pattern = """number"":""([^""]+)""[\s\S]*?""subdivision"":""(([^""\\]|\\.)*)"""

    If re.Test(jsonText) Then
        Set m = re.Execute(jsonText)
        For i = 0 To m.Count - 1
            Dim num As String, subdRaw As String, subd As String
            num = m.Item(i).SubMatches(0)
            subdRaw = m.Item(i).SubMatches(1)
            subdRaw = Replace(subdRaw, "\""", """")
            subd = DecodeUnicode(subdRaw)
            ExtractNumberSubdivisionPairs.Add num & "|" & subd
        Next i
    End If
End Function

Private Function DecodeUnicode(textIn As String) As String
    Dim i As Long, n As Long, outStr As String, hex4 As String, ch As String
    n = Len(textIn): i = 1
    Do While i <= n
        If Mid$(textIn, i, 2) = "\u" And i + 5 <= n Then
            hex4 = Mid$(textIn, i + 2, 4)
            On Error Resume Next
            ch = ChrW(CLng("&H" & hex4))
            On Error GoTo 0
            If ch <> "" Then
                outStr = outStr & ch
                i = i + 6
            Else
                outStr = outStr & Mid$(textIn, i, 6)
                i = i + 6
            End If
        Else
            outStr = outStr & Mid$(textIn, i, 1)
            i = i + 1
        End If
    Loop
    DecodeUnicode = outStr
End Function

' =========================
' Основная процедура
' =========================
Sub ProcessNumbersWord(Optional ByVal groupMode As Boolean = False)
    Dim apiUrl As String
    apiUrl = "https://ud.ai-inf.ru/api/process"

    ' --- Шаг 1: считываем выделение ---
    ShowProgress 1, 3, "Подготовка запроса..."

    Dim inputStr As String
    inputStr = Selection.Text

    Dim payload As String
    payload = MakePayloadFromSelection(inputStr)

    ' --- Шаг 2: отправляем запрос ---
    ShowProgress 2, 3, "Запрос к серверу..."

    Dim resp As String
    resp = HttpPostJson(apiUrl, payload)

    ' --- Шаг 3: обрабатываем ответ ---
    ShowProgress 3, 3, "Обработка ответа..."

    If InStr(1, LCase$(resp), "<html", vbTextCompare) > 0 Or _
       InStr(1, resp, "<!doctype html", vbTextCompare) > 0 Then
        ShowProgress 0, 0
        Selection.Text = "(ошибка запроса: сервер вернул HTML/400)"
        Exit Sub
    End If

    Dim pairs As Collection
    Set pairs = ExtractNumberSubdivisionPairs(resp)

    Dim result As String
    If pairs.Count = 0 Then
        ShowProgress 0, 0
        Selection.Text = "(нет данных)"
        Exit Sub
    End If

    If groupMode = False Then
        Dim i As Long
        For i = 1 To pairs.Count
            Dim parts() As String
            parts = Split(pairs(i), "|")
            If UBound(parts) = 1 Then
                If Len(result) > 0 Then result = result & ", "
                result = result & parts(0) & " - " & parts(1)
            End If
        Next i
    Else
        Dim groupDict As Object
        Set groupDict = CreateObject("Scripting.Dictionary")
        Dim j As Long, kv() As String, num As String, subd As String
        For j = 1 To pairs.Count
            kv = Split(pairs(j), "|")
            If UBound(kv) = 1 Then
                num = kv(0): subd = kv(1)
                If Len(subd) = 0 Then subd = "(нет данных)"
                If Not groupDict.Exists(subd) Then
                    groupDict(subd) = num
                Else
                    groupDict(subd) = groupDict(subd) & ", " & num
                End If
            End If
        Next j
        Dim key As Variant
        For Each key In groupDict.Keys
            If Len(result) > 0 Then result = result & "; "
            result = result & groupDict(key) & " - " & key
        Next key
    End If

    ' --- Готово ---
    ShowProgress 0, 0
    Selection.Text = result
End Sub

' =========================
' Обёртки для меню Word
' =========================
Public Sub ProcessNumbersWord_NoGroup()
    Call ProcessNumbersWord(False)
End Sub

Public Sub ProcessNumbersWord_Grouped()
    Call ProcessNumbersWord(True)
End Sub