Форум по VBA и MS Office

Sub SaveAsPDF()

    Dim path As String, DocName As String, ContControl As ContentControl
   
'1. Запись в переменную пути, где надо сохранить файл. На конце слеш не указывайте.
    path = "d:\ФИАС"
   
'2. Запись в переменную "DocName" имени активного файла без расширения.
    DocName = ActiveDocument.Name
    DocName = Left(DocName, InStrRev(DocName, ".") - 1)
   
'3. Присваиваем имя "ContControl" элементу управления с тегом "список".
    For Each ContControl In ActiveDocument.ContentControls
        If ContControl.Tag = "список" Then
            Exit For
        End If
    Next ContControl
   
'4. Вставка в шапку письма исходящего номера
    Selection.HomeKey Unit:=6    'wdStory
    Selection.MoveDown Unit:=wdLine, Count:=13
    Selection.MoveRight Unit:=wdCharacter, Count:=11
'удалить 6 знаков справа
    Selection.TypeBackspace
    Selection.TypeBackspace
    Selection.TypeBackspace
    Selection.TypeBackspace
    Selection.TypeBackspace
    Selection.TypeBackspace
'вставить 00+дата
    Selection.TypeText text:="00" & Format(Date, "ddmm")
   
'5. Сохранение файла в pdf-формате.
    ActiveDocument.ExportAsFixedFormat _
        OutputFileName:=path & "\" & _
                        DocName & "_" & Format(Date, "ddmm") & "_" & _
                        ContControl.Range.text & ".pdf", _
        ExportFormat:=wdExportFormatPDF
       
'6. Увеличение номера документа на 1.
    IncreaseDocNumber
   
End Sub

Sub IncreaseDocNumber()

    Dim text1, text2, DigitsCount As Long
   
    '1) Запись номера документа в переменную "text1".
    text1 = ActiveDocument.Tables(1).Cell(3, 3).Range.text
    ' Удаление с конца двух символов ячейки.
    text1 = Left(text1, Len(text1) - 2)
    '2) Разбивка текста на две части по правому слешу.
    text1 = Split(text1, "/", 2)
    '3) Разбивка второй части по пробелу на две части.
    text2 = Split(text1(1), " ", 2)
    '4) Запоминаем, сколько цифр в числе.
    DigitsCount = Len(text2(0))
    '5) Добавление к числу единицы.
    text2(0) = text2(0) + 1
    '6) Добавление спереди к числу нужного кол-ва нулей.
    text2(0) = Format(text2(0), String(DigitsCount, "0"))
    '7) Запись изменённой второй части обратно в массив "text1".
    text1(1) = Join(text2, " ")
    '8) Соединение частей обратно.
    text1 = Join(text1, "/")
    '9) Запись данных обратно в файл.
    ActiveDocument.Tables(1).Cell(3, 3).Range.text = text1

End Sub

Sub SaveAsPDF()

    Dim path As String, DocName As String, ContControl As ContentControl
    Dim text1, text2, DigitsCount As Long

'1. Запись в переменную пути, где надо сохранить файл. На конце слеш не указывайте.
    path = "d:\Ф"
   
'2. Запись в переменную "DocName" имени активного файла без расширения.
    DocName = ActiveDocument.Name
    DocName = Left(DocName, InStrRev(DocName, ".") - 1)
   
'3. Присваиваем имя "ContControl" элементу управления с тегом "список".
    For Each ContControl In ActiveDocument.ContentControls
        If ContControl.Tag = "список" Then
            Exit For
        End If
    Next ContControl

'4  Запись номера документа в переменную "text1".
    text1 = ActiveDocument.Tables(1).Cell(3, 3).Range.text
'   Удаление с конца двух символов ячейки.
    text1 = Left(text1, Len(text1) - 2)
'  Разбивка текста на две части по правому слешу.
    text1 = Split(text1, "/", 2)
'   Разбивка второй части по пробелу на две части.
    text2 = Split(text1(1), " ", 2)
'   Запоминаем, сколько цифр в числе.
    DigitsCount = Len(text2(0))
'   Добавление к числу единицы.
    text2(0) = text2(0) + 1
'   Добавление спереди к числу нужного кол-ва нулей.
    text2(0) = Format(text2(0), String(DigitsCount, "0"))
'   Запись изменённой второй части обратно в массив "text1".
    text1(1) = Join(text2, " ")
'   Соединение частей обратно.
    text1 = Join(text1, "/")
'   Запись данных обратно в файл.
    ActiveDocument.Tables(1).Cell(3, 3).Range.text = text1
   
'5. Сохранение файла в pdf-формате.
    ActiveDocument.ExportAsFixedFormat _
        OutputFileName:=path & "\" & _
                        DocName & "_" & Format(Date, "ddmm") & "_" & _
                        ContControl.Range.text & ".pdf", _
        ExportFormat:=wdExportFormatPDF
       
End Sub