Сохранить файл Word в PDF с нужным названием

[Mix100]

А если сам номер исходящего поместить в некое поле, с которого макрос сможет считать инфо и подставить к названию файла?
Тут не важно в начале или в конце, главное подсказать макросу от куда именно взять информацию

[Mix100]

Кто то может макрос подправить. На этапе перезаписывания файла, когда спрашивают и вводишь новое имя, то ошибка возникает (стоит офис 2010)
В макросе стоит мой путь сохранения D:\YandexDisk\1C Счета и договора\

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:\YandexDisk\1C Счета и договора\"  'Сохранить файл 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

[Serge_Bliznykov]

судя по всему Вы код брали тут - https://www.thespreadsheetguru.com/t...cel-worksheets

простите, а откуда взялась "2" (двойка) вот здесь?

Сообщение от Mix100

Set doc = ActiveDocument.SaveAs2(ActiveDocument.TempPath & _
     "\" & FileName & ".doc", wdFormatDocument)

[Serge_Bliznykov]

как вариант предлагаю такой код:

Option Explicit

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, DirFile As String, FolderName As String
Dim FileName As String
Dim myPath As String
Dim UniqueName As Boolean
Dim UserAnswer As Integer

UniqueName = False

'Store Information About Word File
'Сохранить информацию о файле Word
  myPath = ActiveDocument.FullName
  'CurrentFolder = ActiveDocument.Path & "\"  'Сохранить файл pdf там же где и doc
  CurrentFolder = "D:\YandexDisk\1C Счета и договора\"  'Сохранить файл 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 IsValidFileName(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 "Файл " & FileName & ".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 IsValidFileName(sFileName As String) As Boolean
    Dim lstIllegal As Variant
    Dim i As Long
    Dim result As Boolean
    
    lstIllegal = Array("/", "\", ":", "*", "?", "<", ">", "|", """")
    result = True
    
    For i = LBound(lstIllegal) To UBound(lstIllegal)
        If InStr(1, sFileName, lstIllegal(i)) > 0 Then
            result = False
            Exit Function
        End If
    Next i
    IsValidFileName = result
End Function

[Mix100]

Serge_Bliznykov, огромное спасибо все работает

Сообщение от Serge_Bliznykov

как вариант предлагаю такой код:

[Mix100]

Иду вабанк )
1. Как к самому названию файла
FileName = Mid(myPath, InStrRev(myPath, "\") + 1, _
InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1)

прицепить дату "DDMMYYYY"

2. Как заставить макросом не спрашивать о перезаписи http://prntscr.com/jjl12f, а сразу выдать окно с вводом нового названия. Хочу убрать лишнее действие

3. И открыть папку с сохраненным файлом (нужно что бы отправить его по почте)
Ве енд.

[Serge_Bliznykov]

Сообщение от Mix100

1. Как к самому названию файла
FileName = Mid(myPath, InStrRev(myPath, "\") + 1, _
InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1)

прицепить дату "DDMMYYYY"

попробуйте так:

FileName = Mid(myPath, InStrRev(myPath, "\") + 1, _
   InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1) &  Format(Now(), "DDMMYYYY")

внимание. код не проверял!

Сообщение от Mix100

2. Как заставить макросом не спрашивать о перезаписи http://prntscr.com/jjl12f, а сразу выдать окно с вводом нового названия. Хочу убрать лишнее действие

очевидно, нужно убрать

Сообщение от Serge_Bliznykov

UserAnswer = MsgBox("Файл уже существует. Нажмите " & _
"[Yes] что бы перезаписать. Нажмите [No] что бы переименовать.", vbYesNoCancel)

чтобы не переписывать логику, можете это заменить на

UserAnswer = vbNo

Сообщение от Mix100

3. И открыть папку с сохраненным файлом (нужно что бы отправить его по почте)

попробуйте что-то вроде:

Shell "EXPLORER.EXE" & " " & Chr(34) & CurrentFolder & Chr(34), vbNormalFocus

внимание. код не проверял!

[Mix100]

Открытие папки

Сообщение от Serge_Bliznykov

Shell "EXPLORER.EXE" & " " & Chr(34) & CurrentFolder & Chr(34), vbNormalFocus

Код добавил в конце фукции, открывает просто проводник, а нужно именно папку с сохраненным файлом (путь в макросе есть).

[Serge_Bliznykov]

Сообщение от Mix100

Работает, но получается слитно название и дата, типа КП от Фирмы21052018.pdf
- Тут необходимо добавить пробел перед датой
- Сразу же как урок для меня, как добавить текст в конце даты (например префикс буду ставить, что бы КП не повторялись и не перезаписывались в один день. Можно конечно добавить время, но префикс симпатичней и иерархия логична

так. понятно.
Вам нужно просто пояснить, как формируются строчки на VBA, тогда таких вопросов не будет.
знак & - означает конкатенацию (слияние) строк.

mypath = "aa"
ss = mypath & "bb"

в переменной ss будет "aabb"
если мы хотим в середину переменной вставить дату, тогда

ss = mypath & Format(Now(), "DDMMYYYY") & "bb"

в переменной ss будет "aa21052018bb"

если нужно добавить пробел перед датой, то так и запишем

ss = mypath & " " & Format(Now(), "DDMMYYYY") & "bb"

в переменной ss будет "aa 21052018bb"


в коде пробел вставим так:

FileName = Mid(myPath, InStrRev(myPath, "\") + 1, _
   InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1) & " " & Format(Now(), "DDMMYYYY") 'к названию подставлена дата

Так понятней?


а строчку с Shell "EXPLORER.EXE" .... Вы вставили не туда!

попробуйте вставить сюда:

  'MsgBox "PDF Saved in the Folder: " & FolderName
  MsgBox "Файл " & FileName & ".pdf создан в указанную папку"

  Shell "EXPLORER.EXE" & " " & Chr(34) & CurrentFolder & Chr(34), vbNormalFocus

[Mix100]

Сообщение от Serge_Bliznykov

ss = mypath & " " & Format(Now(), "DDMMYYYY") & "bb"

Спасибо, теперь понятно.
Я пошел своим кривым путем и сделал так ) "_DD.MM.YYYY_1"

Сообщение от Serge_Bliznykov

а строчку с Shell "EXPLORER.EXE" .... Вы вставили не туда!
попробуйте вставить сюда:

Тоже, решил другим кривым путем, в конце функции добавил код:
'Dim Path
'Path = "D:\YandexDisk\1C Счета и договора\"
'Shell "cmd /c start """" explorer.exe " & Path, vbHide

Понятно, что все это эксперимент, Ваше подсказки проще и логичнее. С кодом пока все. Вам Serge_Bliznykov огромное спасибо. Надеюсь всем пригодиться этот код, кто отсылает большое количество КП.