Word макрос для сохранения в pdf

' ----------------------------------------------------------------------------
' Как документ word сохранить в pdf формате
' ExportAsFixedFormat.vbs
' ----------------------------------------------------------------------------
Option Explicit
 
dim oWord, oDoc, oSel, oFont, oShell, oRange, oPars, cur_dir, REnd
 
set oWord = WScript.CreateObject("Word.Application")   
set oShell = WScript.CreateObject("WScript.Shell")
set oDoc = oWord.Documents                                           
oDoc.Add()                                                                           
set oSel = oWord.Selection                                                   
oWord.Visible = True                                                           
set oFont = oSel.Font
set oRange = oDoc(1).Range()
 
'Текущий каталог
cur_dir = oShell.CurrentDirectory
 
with oFont
    .Size = 20
    .Name = "Times New Roman"
    .Bold=true
    .Colorindex=2
end with
 
oSel.TypeText "Word - сохранение в PDF"
 
with oFont
    .Size = 12
    .Bold=false
    .Colorindex=0
end with
 
With oSel
     .TypeParagraph
     .TypeParagraph
End With
 
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    '   документ word сохранить в pdf
With WScript
     call TXInsert("Name: ", .Name & "")
     call TXInsert("FullName: ", .FullName & "")
     call TXInsert("ScriptName: ", .Name & "")
     call TXInsert("ScriptFullName: ", .FullName & "")
     call TXInsert("Path: ", .Path & "")
     call TXInsert("Version: ", .Version & "")
     call TXInsert("Application: ", .Application & "")
     call TXInsert("Timeout: ", .Timeout & "")
     call TXInsert("BuildVersion: ", .BuildVersion & "")
End With
 
set oPars = oRange.Paragraphs
REnd = oPars(oPars.Count).Range.End       
 
call LRange(4,7)
With oRange
     ' Сохраняем абзацы с 4 по 7 в PDF формате
     .ExportAsFixedFormat cur_dir & "WscInfo_VBS.pdf", 17, true
 
     .setRange 0, REnd
     ' Сохраняем весь документ Word в PDF формате
     .ExportAsFixedFormat cur_dir & "WscInfoFull_VBS.pdf", 17, true
End With
 
' Используем метод SaveAs для сохранения документа
oDoc(1).SaveAs cur_dir & "WscInfoFull_SaveAs_VBS.pdf", 17
 
' процедура выбора диапазона
Sub LRange(a, b)
     With oRange
                 .setRange 0, REnd
                 .setRange oPars(a).Range.Start, oPars(b).Range.End
     End With
End Sub
 
' Процедура для форматирования шрифта и вставки абзаца                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              как сохранить ворд в пдф
Sub TXInsert(a, b)
     With oSel
                 oFont.Bold=true
                 .TypeText a
                 .EndOf
                 oFont.Bold=false
                 .TypeText b
                 .TypeParagraph
     End With
End Sub

Sub Word_ExportPDF()
‘https://www.thespreadsheetguru.com/the-code-vault/microsoft-word-vba-to-save-document-as-a-pdf-in-same-folder
‘PURPOSE: Generate A PDF Document From Current Word Document
‘NOTES: PDF Will Be Saved To Same Folder As Word Document File
‘SOURCE: www.TheSpreadsheetGuru.com/the-code-vault

Dim CurrentFolder As String
Dim FileName As String
Dim myPath As String
Dim UniqueName As Boolean

UniqueName = False

‘Store Information About Word File
‘Сохранить информацию о файле Word
  myPath = ActiveDocument.FullName
  ‘CurrentFolder = ActiveDocument.Path & «»  ‘Сохранить файл pdf там же где и doc
  CurrentFolder = «D:YandexDisk1C Счета и договора»  ‘Сохранить файл pdf по пути..
  FileName = Mid(myPath, InStrRev(myPath, «») + 1, _
   InStrRev(myPath, «.») — InStrRev(myPath, «») — 1)

‘Does File Already Exist?
‘Уже существует ли файл?
  Do While UniqueName = False
    DirFile = CurrentFolder & FileName & «.pdf»
    If Len(Dir(DirFile)) <> 0 Then
      UserAnswer = MsgBox(«Файл уже существует. Нажмите » & _
       «[Yes] что бы перезаписать. Нажмите [No] что бы переименовать.», vbYesNoCancel)

            If UserAnswer = vbYes Then
        UniqueName = True
      ElseIf UserAnswer = vbNo Then
        Do
          ‘Retrieve New File Name
          ‘Получить новое имя файла
            FileName = InputBox(«Укажите новое имя файла » & _
             «(спросит снова, если вы указали недопустимое имя файла)», _
             «Введите имя файла», FileName)

                    ‘Exit if User Wants To
          ‘Выход, если пользователь хочет
            If FileName = «False» Or FileName = «» Then Exit Sub
        Loop While ValidFileName(FileName) = False
      Else
        Exit Sub ‘Cancel
      End If
    Else
      UniqueName = True
    End If
  Loop

  ‘Save As PDF Document
‘Сохранить как документ в формате PDF
  On Error GoTo ProblemSaving
    ActiveDocument.ExportAsFixedFormat _
     OutputFileName:=CurrentFolder & FileName & «.pdf», _
     ExportFormat:=wdExportFormatPDF
  On Error GoTo 0

‘Confirm Save To User
‘Подтвердить Сохранить пользователю
  With ActiveDocument
    FolderName = Mid(.Path, InStrRev(.Path, «») + 1, Len(.Path) — InStrRev(.Path, «»))
  End With

    ‘MsgBox «PDF Saved in the Folder: » & FolderName
  MsgBox «Файл pdf создан в указанную папку»

Exit Sub

‘Error Handlers
ProblemSaving:
  ‘MsgBox «There was a problem saving your PDF. This is most commonly caused» & _
   » by the original PDF file already being open.»
  MsgBox «Не удалось скопировать»
  Exit Sub

End Sub
Function ValidFileName(FileName As String) As Boolean
‘PURPOSE: Determine If A Given Word Document File Name Is Valid
‘SOURCE: www.TheSpreadsheetGuru.com/the-code-vault

Dim TempPath As String
Dim doc As Document

‘Determine Folder Where Temporary Files Are Stored
  TempPath = Environ(«TEMP»)

‘Create a Temporary XLS file (XLS in case there are macros)
  On Error GoTo InvalidFileName
    Set doc = ActiveDocument.SaveAs2(ActiveDocument.TempPath & _
     «» & FileName & «.doc», wdFormatDocument)
  On Error Resume Next

‘Delete Temp File
  Kill doc.FullName

‘File Name is Valid
  ValidFileName = True

Exit Function

‘ERROR HANDLERS
InvalidFileName:
‘File Name is Invalid
  ValidFileName = False

End Function