Private Sub CommandButton1_Click()
' проверка наличия папки и вывод сообщения при ее отсутствии
If Len(Dir(Sheets("1").Cells(3, 1), vbDirectory)) = 0 Then MsgBox (" Ошибка" & Chr(13) & "Папка не найдена.") 'MkDir Sheets("1").Cells(3, 1)
If Len(Dir(Sheets("1").Cells(3, 1), vbDirectory)) = 0 Then GoTo Stopp:
'проверка наличия шаблона и вывод сообщения при его отсутствии
If Len(Dir$(Sheets("1").Cells(1, 1))) > 0 Then
Else: MsgBox (" Помилка!" & Chr(13) & "Шаблон не найден!" & Chr(13) & " Шаблон.")
End If
If Len(Dir$(Sheets("1").Cells(1, 1))) > 0 Then
Else: GoTo Stopp:
End If
Dim WordApp As Object
'Здесь нужно указать имя закладки, которая находится в шаблоне Word.
'В эту закладку будет вставляться текст из книги Excel.
Const sBookmark_1 As String = "Закладка_1"
Const sBookmark_2 As String = "Закладка_2"
Const sBookmark_3 As String = "Закладка_3"
Const sBookmark_4 As String = "Закладка_4"
Const sBookmark_5 As String = "Закладка_5"
Const sBookmark_6 As String = "Закладка_6"
Const sBookmark_7 As String = "Закладка_7"
Const sBookmark_8 As String = "Закладка_8"
Const sBookmark_9 As String = "Закладка_9"
Const sBookmark_10 As String = "Закладка_10"
If WordApp Is Nothing Then
Set WordApp = CreateObject("word.application")
End If
' проверка наличия файла и удаление его при наличии
Dim strFileName As String
Dim strFileTitle As String
strFileTitle = "Записка_" & Sheets("1").Cells(2, 2) & "_" & Sheets("1").Cells(2, 1) & ".docx"
strFileName = Sheets("1").Cells(3, 1) & "Записка_" & Sheets("1").Cells(2, 2) & "_" & Sheets("1").Cells(2, 1) & ".docx"
If Dir(strFileName) <> "" Then
Kill Sheets("1").Cells(3, 1) & "Записка_" & Sheets("1").Cells(2, 2) & "_" & Sheets("1").Cells(2, 1) & ".docx"
Else
End If
Dim sFileName As String, sNewFileName As String
' указываем шаблон и копируем его
sFileName = Sheets("1").Cells(1, 1)
sNewFileName = Sheets("1").Cells(3, 1) & "Записка_" & Sheets("1").Cells(2, 2) & "_" & Sheets("1").Cells(2, 1) & ".docx" ' "C:\1\"
FileCopy sFileName, sNewFileName
With WordApp
.Visible = False
.Documents.Open Filename:=Sheets("1").Cells(3, 1) & "Записка_" & Sheets("1").Cells(2, 2) & "_" & Sheets("1").Cells(2, 1) & ".docx"
End With
'Вставка текста в закладку.
s = 4 'Берем информацию из 4 строки (1)
WordApp.ActiveDocument.Bookmarks(sBookmark_1).Range.Text = Sheets("1").Cells(s, 4)
WordApp.ActiveDocument.Bookmarks(sBookmark_2).Range.Text = Sheets("1").Cells(s, 5)
WordApp.ActiveDocument.Bookmarks(sBookmark_3).Range.Text = Sheets("1").Cells(s, 6)
WordApp.ActiveDocument.Bookmarks(sBookmark_4).Range.Text = Sheets("1").Cells(s, 7)
WordApp.ActiveDocument.Bookmarks(sBookmark_5).Range.Text = Sheets("1").Cells(s, 8)
WordApp.ActiveDocument.Bookmarks(sBookmark_6).Range.Text = Sheets("1").Cells(s, 9)
WordApp.ActiveDocument.Bookmarks(sBookmark_7).Range.Text = Sheets("1").Cells(s, 10)
WordApp.ActiveDocument.Bookmarks(sBookmark_8).Range.Text = Sheets("1").Cells(s, 11)
WordApp.ActiveDocument.Bookmarks(sBookmark_9).Range.Text = Sheets("1").Cells(s, 12)
WordApp.ActiveDocument.Bookmarks(sBookmark_10).Range.Text = Sheets("1").Cells(s, 13)
'Удаление закладок
WordApp.ActiveDocument.Bookmarks(sBookmark_1).Delete
WordApp.ActiveDocument.Bookmarks(sBookmark_2).Delete
WordApp.ActiveDocument.Bookmarks(sBookmark_3).Delete
WordApp.ActiveDocument.Bookmarks(sBookmark_4).Delete
WordApp.ActiveDocument.Bookmarks(sBookmark_5).Delete
WordApp.ActiveDocument.Bookmarks(sBookmark_6).Delete
WordApp.ActiveDocument.Bookmarks(sBookmark_7).Delete
WordApp.ActiveDocument.Bookmarks(sBookmark_8).Delete
WordApp.ActiveDocument.Bookmarks(sBookmark_9).Delete
WordApp.ActiveDocument.Bookmarks(sBookmark_10).Delete
'Закрываем новый документ с сохранением.
WordApp.ActiveDocument.Close SaveChanges:=-1
'закрываем приложение Word
WordApp.Quit
Set WordApp = Nothing
Stopp:
End Sub
Private Sub CommandButton2_Click()
UserForm5.Hide
UserForm1.Show
End Sub
' Макрос запуска функции (находится ниже) для указания адреса шаблона
Private Sub CommandButton3_Click()
Filename$ = GetFilePath()
If Filename$ = "" Then Exit Sub
Sheets("1").Cells(1, 1) = Filename ' имя выбраного файла шаблона АТЛ пишется в лист1 яч.1.1
Label2.Caption = Sheets("1").Cells(1, 1)
Label2.ForeColor = RGB(255, 0, 0)
MsgBox "Вибраний файл: " & Filename$
End Sub
' Функция для указания адреса шаблона
Function GetFilePath(Optional ByVal Title As String = "Вибір шаблону записки:", _
Optional ByVal InitialPath As String = "c:\", _
Optional ByVal FilterDescription As String = "Файли шаблонів", _
Optional ByVal FilterExtention As String = "*.atl") As String
On Error Resume Next
With Application.FileDialog(msoFileDialogOpen)
.ButtonName = "Вибрати": .Title = Title:
.InitialFileName = GetSetting(Application.Name, "GetFilePath", "folder", InitialPath)
.Filters.Clear: .Filters.Add FilterDescription, FilterExtention
If .Show <> -1 Then Exit Function
GetFilePath = .SelectedItems(1)
folder$ = Left(.SelectedItems(1), InStrRev(.SelectedItems(1), "\"))
SaveSetting Application.Name, "GetFilePath", "folder", folder$
End With
End Function
' Выбор папки сохранения Ат. листов
Private Sub CommandButton4_Click()
Filefolder$ = GetFolderPath("Вибір папки для збереження записки", ThisWorkbook.Path)
If Filefolder$ = "" Then Exit Sub
Sheets("1").Cells(3, 1) = Filefolder$
Label1.Caption = Sheets("1").Cells(3, 1)
Label1.ForeColor = RGB(255, 0, 0)
MsgBox "Папка для збереження записки: " & Filefolder$
End Sub
' Функция выбора папки сохранения Ат. листов
Function GetFolderPath(Optional ByVal Title As String = "Выберите папку", _
Optional ByVal InitialPath As String = "c:\") As String
Dim PS As String: PS = Application.PathSeparator
With Application.FileDialog(msoFileDialogFolderPicker)
If Not Right$(InitialPath, 1) = PS Then InitialPath = InitialPath & PS
.ButtonName = "Вибрати папку": .Title = Title: .InitialFileName = InitialPath
If .Show <> -1 Then Exit Function
GetFolderPath = .SelectedItems(1)
If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS
End With
End Function
' Закрывает эксель при закрытии формы
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
ThisWorkbook.Save
Application.DisplayAlerts = True
Application.Quit
End Sub
|
