---

Sub MinimalParseNetworkManual()
    Dim wd As Object, doc As Object
    Dim sh As Worksheet
    Dim networkPath As String, f As String
    Dim r As Long
    Dim driveLetter As String
    Dim fd As Object
    
    ' ===== ВЫБОР ПАПКИ =====
    Set fd = CreateObject("Shell.Application").BrowseForFolder(0, "Выберите папку на \\mipcnet.org\vdi", 0, 0)
    If fd Is Nothing Then Exit Sub
    networkPath = fd.Items.Item.path & "\"
    
    ' Проверяем что путь начинается с \\mipcnet.org
    If Left(networkPath, 14) <> "\\mipcnet.org\" Then
        MsgBox "Выберите папку на \\mipcnet.org\vdi", vbCritical
        Exit Sub
    End If
    
    driveLetter = "Z:"
    
    ' ===== ПОДКЛЮЧАЕМ =====
    On Error Resume Next
    Shell "net use " & driveLetter & " /delete /yes", 0
    On Error GoTo 0
    
    Shell "net use " & driveLetter & " """ & networkPath & """ /persistent:no", 0
    Application.Wait (Now + TimeValue("0:00:03"))
    
    If Dir(driveLetter & "\", vbDirectory) = "" Then
        MsgBox "Не удалось подключить " & driveLetter, vbCritical
        Exit Sub
    End If
    
    ' ===== РАБОТА =====
    Set sh = ThisWorkbook.Sheets(1)
    sh.Cells.Clear
    r = 2
    
    Set wd = CreateObject("Word.Application")
    wd.Visible = False
    
    f = Dir(driveLetter & "\*.doc*")
    
    If f = "" Then
        MsgBox "Нет Word файлов!", vbCritical
        Shell "net use " & driveLetter & " /delete /yes", 0
        Exit Sub
    End If
    
    Do While f <> "" And r <= 51
        On Error Resume Next
        Set doc = wd.Documents.Open(driveLetter & "\" & f)
        
        If Err.Number = 0 Then
            sh.Cells(r, 1) = f
            sh.Cells(r, 2) = Left(doc.Range.Text, 500)
            sh.Cells(r, 3) = doc.Tables.Count
            doc.Close False
            r = r + 1
        Else
            sh.Cells(r, 1) = f
            sh.Cells(r, 2) = "Ошибка: " & Err.Description
            r = r + 1
        End If
        
        f = Dir()
    Loop
    
    Shell "net use " & driveLetter & " /delete /yes", 0
    wd.Quit False
    
    MsgBox "Готово! Обработано " & r - 2 & " файлов", vbInformation
End Sub