Option Compare Text
Dim Picture_count As Integer
Const MaxRowsIn = 500
Const isdocx = ".docx"
Sub connect_lib()
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)
Dim row As Range
Dim WA As Object
Dim WD As Object
Set WA = CreateObject("Word.Application")
Dim lLastRow As Long
Dim lLastCol As Long
Dim sFileName As String
BSFNname = Trim$(Sheets("Common Data").Cells(3))
Filename = BSFNname & isdocx
Filename = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, Filename)
Set WD = WA.Documents.Add(TempPath): DoEvents
Flag = 0
For i = 1 To 201
FindText = Trim$(Sheets("Common Data").Cells(i, 1))
ReplaceText = Trim$(Sheets("Common Data").Cells(i, 3))
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
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
WA.Selection.TypeParagraph
pict_2: End With
Dim st As String
Application.CutCopyMode = False
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("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
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
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
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)
dheight = 200 / .Width
.Width = .Width * dheight
.height = .height * dheight
End With
WA.Selection.TypeParagraph
WA.Selection.TypeText Text:="Рисунок" + LTrim(Str(Picture_count)) + " "
WA.Selection.TypeParagraph
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
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
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
Set FilenamesCollection = New Collection
Set FSO = CreateObject("Scripting.FileSystemObject")
GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep
Set FSO = Nothing: Application.StatusBar = False
End Function
Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
If Not curfold Is Nothing Then
For Each fil In curfold.Files
If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
Next
SearchDeep = SearchDeep - 1
If SearchDeep Then
For Each sfol In curfold.SubFolders
GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
Next
End If
Set fil = Nothing: Set curfold = Nothing
End If
End Function
)