Option Compare Text

  '  Dim WA As New Word.Application
  '  Dim WD As Object
    
Dim Picture_count As Integer
Const MaxRowsIn = 500
Const isdocx = ".docx"
'Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub connect_lib() ' В данном случае Word
'On Error Resume Next
'    Dim iReference As Object, iReferences As Object    'или Variant
'    Set iReferences = ThisWorkbook.VBProject.References
'    For Each iReference In iReferences
'        If (iReference.IsBroken) Then _
'           iReferences.Remove Reference:=iReference
'    Next
'ThisWorkbook.VBProject.References.AddFromFile Application.Path & Application.PathSeparator & "MSWORD.OLB"
Call GooseExpert1

End Sub
Sub GooseExpert1()

Picture_count = 0
    If (Sheets("Common Data").Cells(4, 53) = "1") Then
        TempFileName = "template_tower1.dotx"
    Else
        If (Sheets("Common Data").Cells(4, 53) = "2") Then
        TempFileName = "template_tower2.dotx"
    Else
        TempFileName = "template_tower4.dotx"
    End If
    End If
    TempPath = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, TempFileName)
   ' NewFolder = NewFolderName & Application.PathSeparator
    Dim row As Range ', pi As New ProgressIndicator
  '  r = Cells(Rows.Count, "A").End(xlUp).row: rc = r - 2
  '  If rc < 1 Then MsgBox "Строк для обработки не найдено", vbCritical: Exit Sub

    Dim WA As Object 'New Word.Application
    Dim WD As Object
    Set WA = CreateObject("Word.Application")
 
    Dim lLastRow As Long
    Dim lLastCol As Long

    Dim sFileName As String
  '  For Each row In ActiveSheet.Rows("3:" & r)
  '      With row
            BSFNname = Trim$(Sheets("Common Data").Cells(3)) ' & Trim$(Sheets("Common Data").Cells(3))
            Filename = BSFNname & isdocx
            Filename = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, Filename)
'            pi.StartNewAction p, p + a / 3, "Создание нового файла на основании шаблона", BSFNname
        
            Set WD = WA.Documents.Add(TempPath): DoEvents

    '        pi.StartNewAction p + a / 3, p + a * 2 / 3, "Замена данных ...", BSFNname
            Flag = 0
            For i = 1 To 201 ' MaxRowsIn
                FindText = Trim$(Sheets("Common Data").Cells(i, 1))
                ReplaceText = Trim$(Sheets("Common Data").Cells(i, 3))
   
                ' так почему-то заменяет не всё
                'WA.Selection.Find.Execute FindText, , , , , , , wdFindContinue, False, ReplaceText, True

           '     pi.line3 = "Заменяется поле " & FindText
                If (Len(ReplaceText) > 100) Then
                    WA.Selection.Find.ClearFormatting
                    WA.Selection.Find.Execute FindText:=FindText, Wrap:=wdFindContinue
                    If WA.Selection.Find.Found = True Then WA.Selection.Text = ReplaceText 'много символов
                Else
                
                ' КОД ДЛЯ ПЕРВЫХ ВЕРХНИХ И НИЖНИХ КОЛОНТИТУТОЛОВ
  WA.ActiveWindow.ActivePane.View.SeekView = 5  ' активировать первый верхний колонтитул
  With WA.Selection.Find
                     .Text = FindText
                     .Replacement.Text = ReplaceText
                     .Forward = True
                     .Wrap = 1
                     .Format = False: .MatchCase = False
                     .MatchWholeWord = False
                     .MatchWildcards = False
                     .MatchSoundsLike = False
                     .MatchAllWordForms = False
                     .Execute Replace:=2
                 End With
  WA.ActiveWindow.ActivePane.View.SeekView = 2 ' активировать первый нижний колонтитул
  With WA.Selection.Find
                     .Text = FindText
                     .Replacement.Text = ReplaceText
                     .Forward = True
                     .Wrap = 1
                     .Format = False: .MatchCase = False
                     .MatchWholeWord = False
                     .MatchWildcards = False
                     .MatchSoundsLike = False
                     .MatchAllWordForms = False
                     .Execute Replace:=2
                 End With
          
                WA.ActiveWindow.ActivePane.View.SeekView = 0
                WA.Selection.WholeStory
                WA.Browser.Next
                ' КОНЕЦ КОДА ДЛЯ ПЕРВЫХ ВЕРХНИХ И НИЖНИХ КОЛОНТИТУТОЛОВ
                
                With WD.Range.Find
                    .Text = FindText
                    .Replacement.Text = ReplaceText
                    .Forward = True
                    .Wrap = 1
                    .Format = False: .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                    .Execute Replace:=2
                End With
                End If
                DoEvents
            Next i
         '   pi.StartNewAction p + a * 2 / 3, p + a, "Сохранение файла ...", BSFNname, " "
    With WD.Sections(1)
        With .Footers(wdHeaderFooterPrimary).Range.Find
            .Text = "{rep_bas_name}"
            .Replacement.Text = Sheets("Common Data").Cells(1, 3).Text
            .Forward = True
            .Wrap = 1
            .Format = False: .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute Replace:=2
        End With
    End With
Application.CutCopyMode = True
With WD
Picture_count = Picture_count + 1
    .Bookmarks("pic1").Range.Select
    FolderPic = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "Pic1\")
    Dim coll As Collection
    If Dir(FolderPic, vbDirectory) = "" Then
        MsgBox "No Folder Pic1" & folder$ & "»", vbCritical, "No Folder "
        GoTo pict_1
    End If
    Set coll = FilenamesCollection(FolderPic, ".jpg")
    For i = 1 To coll.Count
          
       WA.Selection.InlineShapes.AddPicture Filename:=coll.Item(i)
       WA.Selection.TypeParagraph
    Next i
pict_1: End With
Application.CutCopyMode = False
Application.CutCopyMode = True
With WD
Picture_count = Picture_count + 1
    .Bookmarks("pic2").Range.Select
    FolderPic = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "Pic2\")
    If Dir(FolderPic, vbDirectory) = "" Then
        MsgBox "No Folder Pic1" & folder$ & "»", vbCritical, "No Folder "
        GoTo pict_2
    End If
          
       WA.Selection.InlineShapes.AddPicture Filename:=FolderPic & Range("BA2").Value ' & ".jpg" 'добавить, если в ячейке только имя, без расширения
       WA.Selection.TypeParagraph
pict_2: End With
'If Trim$(ActiveSheet.Cells(3, 6)) = "башня" Then
    'Worksheets("гусебашня").Activate
Dim st As String
Application.CutCopyMode = False
st = "Карта визуального осмотра антенных устройств (динамическая)"
Call sc(Begin_table, end_table, begin_column, end_column, st)
    
   ' Sheets("таблицы").Range(Sheets("таблицы").Cells(26, 1), Sheets("таблицы").Cells(28, 2)).Copy
    With WD
    Application.CutCopyMode = True
    Sheets("таблицы").Range(Sheets("таблицы").Cells(Begin_table, begin_column), Sheets("таблицы").Cells(end_table, end_column)).Copy
    'InsertParagraphAfter
        .Bookmarks("tab1").Range.PasteExcelTable _
        LinkedToExcel:=False, WordFormatting:=False, RTF:=False
        Application.CutCopyMode = False
    End With
    
  
    st = "Протокол ревизии и осмотра АМС (статика)"
    Call sc(Begin_table, end_table, begin_column, end_column, st)

    With WD
        Application.CutCopyMode = True
        Sheets("таблицы").Range(Sheets("таблицы").Cells(Begin_table, begin_column), Sheets("таблицы").Cells(end_table, end_column)).Copy
        .Bookmarks("tab3").Range.PasteExcelTable _
        LinkedToExcel:=False, WordFormatting:=False, RTF:=False
        Application.CutCopyMode = False
    End With
    
    st = "Протокол измерений осадок фундаментов и якорей АМС"
    Call sc(Begin_table, end_table, begin_column, end_column, st)

       
    If (Sheets("Common Data").Cells(7, 3) = "мачта") Then
        st = "Протокол проверки натяжения оттяжек"
    Else
        st = "Болты"
    End If
    Call sc(Begin_table, end_table, begin_column, end_column, st)

Application.CutCopyMode = True
op = Sheets("Common Data").Cells(42, 3).Text
Sheets(op).Activate
row_count = Sheets(op).Cells(1, 27).Value
Text = "AL3" + ":AQ" + CStr(2 + row_count)
Sheets(op).Range(Text).Select
Selection.Copy

Text = "AL" + CStr(14 + 2 * row_count)
    Sheets(op).Range(Text).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

Begin_table = 2 + 2 * Sheets(op).Cells(1, 27).Value + 9
end_table = Begin_table + 2 + Sheets(op).Cells(1, 27).Value
begin_column = 38
end_column = 43

    With WD
        Sheets(op).Range(Sheets(op).Cells(Begin_table, begin_column), Sheets(op).Cells(end_table, end_column)).Copy
        .Bookmarks("tab7").Range.PasteExcelTable _
        LinkedToExcel:=False, WordFormatting:=False, RTF:=False
        Application.CutCopyMode = False
    End With

'    st = "Таблица измерений кривизны поясов АМС"
'Call sc(Begin_table, end_table, begin_column, end_column, st)
    'lLastCol = Sheets("таблицы").Cells(10, Columns.Count).End(xlToLeft).Column
    'lLastRow = Sheets("таблицы").Cells(Rows.Count, 2).End(xlUp).row

  '  Sheets("таблицы").Range(Sheets("таблицы").Cells(Begin_table, begin_column), Sheets("таблицы").Cells(end_table, end_column)).Copy
  '  With WD
  '      .Bookmarks("tab6").Range.PasteExcelTable _
  '      LinkedToExcel:=False, WordFormatting:=False, RTF:=False
  '      Application.CutCopyMode = False
  '  End With
Application.CutCopyMode = True
    she = Sheets("Common Data").Cells(42, 3).Text
    Sheets(she).ChartObjects(1).Activate
    ActiveChart.ChartArea.Select
    ActiveChart.ChartArea.Copy
    With WD
        .Bookmarks("she1").Range.Paste
    End With
    Sheets(she).ChartObjects(2).Activate
    ActiveChart.ChartArea.Select
    ActiveChart.ChartArea.Copy
    With WD
        .Bookmarks("she3").Range.Paste
    End With
    Sheets(she).ChartObjects(3).Activate
    ActiveChart.ChartArea.Select
    ActiveChart.ChartArea.Copy
    With WD
        .Bookmarks("she2").Range.Paste
    End With
Application.CutCopyMode = False
' Sleep (1000)
'End If
'Worksheets(1).Activate

Call pic_ins("Pic3\", "pic3", "1_Общий вид", WD, WA)

Call pic_ins("Pic3\", "pic5", "2_Территория размещения АМС", WD, WA)
Call pic_ins("Pic4\", "pic6", "2_Территория размещения АМС", WD, WA)

Call pic_ins("Pic3\", "pic7", "3_Состояние фундаментов", WD, WA)
Call pic_ins("Pic4\", "pic8", "3_Состояние фундаментов", WD, WA)

Call pic_ins("Pic3\", "pic9", "4_Состояние шкафа", WD, WA)
Call pic_ins("Pic4\", "pic10", "4_Состояние шкафа", WD, WA)

Call pic_ins("Pic3\", "pic11", "5_Состояние оттяжек", WD, WA)
Call pic_ins("Pic4\", "pic12", "5_Состояние оттяжек", WD, WA)

Call pic_ins("Pic3\", "pic13", "6_Состояние металлоконструкции", WD, WA)
Call pic_ins("Pic4\", "pic14", "6_Состояние металлоконструкции", WD, WA)

Call pic_ins("Pic3\", "pic15", "7_Крепление и заземление АФУ", WD, WA)
Call pic_ins("Pic4\", "pic16", "7_Крепление и заземление АФУ", WD, WA)

Call pic_ins("Pic3\", "pic17", "8_Состояние огней СОМ", WD, WA)
Call pic_ins("Pic4\", "pic18", "8_Состояние огней СОМ", WD, WA)

Call pic_ins("Pic3\", "pic19", "9_Молниеотвод и заземление", WD, WA)
Call pic_ins("Pic4\", "pic20", "9_Молниеотвод и заземление", WD, WA)

Call pic_ins("Pic3\", "pic21", "10_Очистка территории", WD, WA)
Call pic_ins("Pic4\", "pic22", "10_Очистка территории", WD, WA)

Call pic_ins("Pic3\", "pic23", "11_Восстановление гидроизоляции фундамента", WD, WA)
Call pic_ins("Pic4\", "pic24", "11_Восстановление гидроизоляции фундамента", WD, WA)

Call pic_ins("Pic3\", "pic25", "12_Восстановленеи лакокрасочного покрытия", WD, WA)
Call pic_ins("Pic4\", "pic26", "12_Восстановленеи лакокрасочного покрытия", WD, WA)

Call pic_ins("Pic3\", "pic27", "13_Смазка болтов заземления", WD, WA)
Call pic_ins("Pic4\", "pic28", "13_Смазка болтов заземления", WD, WA)

    WD.SaveAs Filename
    DoEvents
    WD.Close False
    DoEvents
    WA.Quit False
    Set WA = Nothing
    Sheets("Common Data").Select
    Range("B1").Select
    Call CreateApp7
    UserForm1.Show
    Call appendix7_del
End Sub

Sub pic_ins(folder As String, pic As String, name_folder As String, WD As Object, WA As Object)

With WD
    .Bookmarks(pic).Range.Select
     '.Bookmarks(pic).Select
    FolderPic = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, folder + name_folder + "\")
    If Dir(FolderPic, vbDirectory) = "" Then
        MsgBox "No Folder Pic" & folder$ & "»", vbCritical, "No Folder "
        GoTo pict_3
    End If
    Set coll = FilenamesCollection(FolderPic, "*.jpg")
    For i = 1 To coll.Count
        Picture_count = Picture_count + 1
        With WA.Selection.InlineShapes.AddPicture(Filename:=coll.Item(i), _
                                               LinkToFile:=False, SaveWithDocument:=True)
            '.LockAspectRatio = -1
            dheight = 200 / .Width
            'ширина
            '.Width = 250
            .Width = .Width * dheight
            
            'высота
          '  .heihgt = 300
            .height = .height * dheight
        End With
            WA.Selection.TypeParagraph
            WA.Selection.TypeText Text:="Рисунок" + LTrim(Str(Picture_count)) + " "
            WA.Selection.TypeParagraph
          '  WA.Selection.InsertCaption Label:="Рисунок", TitleAutoText:="InsertCaption1", _
          '   Title:="", Position:=wdCaptionPositionAbove, ExcludeLabel:=0
    Next i
pict_3: End With
End Sub

Sub sc(Begin_table, end_table, begin_column, end_column, st As String)
    Begin_table = 0
    end_table = 0
    begin_column = 1
    end_column = 0

    For i = 1 To 1000 'Sheets("таблицы").Cells(Rows.Count, begin_column).End(xlUp).row + 1
        If (Sheets("таблицы").Cells(i, 1).Text = st) Then
            Begin_table = i + 1
            
        End If
        If ((Begin_table > 0) And (Trim$(Sheets("таблицы").Cells(i, begin_column).Text) = "") And (Not (Sheets("таблицы").Cells(i, begin_column).MergeCells))) Then
            end_table = i - 1
            Exit For
        End If
    Next i
    end_column = 25
   ' For i = begin_column To Sheets("таблицы").Cells(1, Columns.Count).End(xlToLeft).Column + 200
   '     If (Trim$(Sheets("таблицы").Cells(Begin_table, i).Text) = "") Then
   '         end_column = i - 1
   '         Exit For
   '     End If
   ' Next i
End Sub

Function NewFolderName() As String
    NewFolderName = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "goose_num_test " & Get_Now)
    MkDir NewFolderName
End Function

Function Get_Date() As String: Get_Date = Replace(Replace(DateValue(Now), "/", "-"), ".", "-"): End Function
Function Get_Time() As String: Get_Time = Replace(TimeValue(Now), ":", "-"): End Function
Function Get_Now() As String: Get_Now = Get_Date & " в " & Get_Time: End Function
Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
                             Optional ByVal SearchDeep As Long = 999) As Collection
    ' ???????? ? ???????? ????????? ???? ? ????? FolderPath,
    ' ????? ????? ??????? ?????? Mask (????? ???????? ?????? ????? ? ????? ??????/???????????)
    ' ? ??????? ?????? SearchDeep ? ????????? (???? SearchDeep=1, ?? ???????? ?? ???????????????).
    ' ?????????? ?????????, ?????????? ?????? ???? ????????? ??????
    ' (??????????? ??????????? ????? ????????? GetAllFileNamesUsingFSO)

    Set FilenamesCollection = New Collection    ' ??????? ?????? ?????????
    Set FSO = CreateObject("Scripting.FileSystemObject")    ' ??????? ????????? FileSystemObject
    GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep ' ?????
    Set FSO = Nothing: Application.StatusBar = False    ' ??????? ?????? ????????? Excel
End Function
 
Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
                                 ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
    ' ?????????? ??? ????? ? ???????? ? ????? FolderPath, ????????? ?????? FSO
    ' ??????? ????? ?????????????? ? ??? ??????, ???? SearchDeep > 1
    ' ????????? ???? ????????? ?????? ? ????????? FileNamesColl
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
    If Not curfold Is Nothing Then    ' ???? ??????? ???????? ?????? ? ?????

        ' ???????????????? ??? ?????? ??? ?????? ???? ? ???????????????
        ' ? ??????? ?????? ????? ? ?????? ????????? Excel
        ' Application.StatusBar = "????? ? ?????: " & FolderPath

        For Each fil In curfold.Files    ' ?????????? ??? ????? ? ????? FolderPath
            If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
        Next
        SearchDeep = SearchDeep - 1    ' ????????? ??????? ?????? ? ?????????
        If SearchDeep Then    ' ???? ???? ?????? ??????
            For Each sfol In curfold.SubFolders    ' ?????????? ??? ???????? ? ????? FolderPath
                GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
            Next
        End If
        Set fil = Nothing: Set curfold = Nothing    ' ??????? ??????????
    End If
End Function