Word VBA: конвертирование пакетных файлов Word в PDF с именем из содержимого таблицы в каждом документе - PullRequest
Новая
       42

Word VBA: конвертирование пакетных файлов Word в PDF с именем из содержимого таблицы в каждом документе

0 голосов
/ 23 октября 2018

Попытка собрать макрос, который преобразует пакет файлов слов в PDF с именами файлов, извлекаемыми из содержимого таблицы в каждом файле слов.

Я нашел один макрос, который преобразует открытый документ в PDF с правильнымимя файла и другое, которое преобразует пакет файлов выбранных слов в PDF.

У меня проблемы с их объединением, чтобы получить PDF-файлы с правильным именем файла.Любая помощь или предложения будут с благодарностью!

Sub Open_File_To_PDF()

Dim StrFilename As String  
Dim StrNm As String  
Dim StrCat As String

StrNm = Split(ActiveDocument.Tables(1).Cell(5, 1).Range.Text, vbCr)(0) 
StrCat = Split(ActiveDocument.Tables(1).Cell(2, 1).Range.Text, vbCr)(0) 
StrFilename = StrCat & "_" & StrNm & ".pdf"

    ActiveDocument.ExportAsFixedFormat OutputFileName:= _
        StrFilename, _
        ExportFormat:=wdExportFormatPDF, OpenAfterExport:=True, OptimizeFor:= _
        wdExportOptimizeForPrint, Range:=wdExportAllDocument, Item:= _
        wdExportDocumentContent, IncludeDocProps:=False, KeepIRM:=True, _
        CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=True, UseISO19005_1:=False
 End Sub

Sub ConvertDocmInDirToPDF()

Dim filePath As String
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Show
    On Error Resume Next
    filePath = .SelectedItems(1)
End With

If filePath = "" Then Exit Sub
If Right(filePath, 1) <> "\" Then filePath = filePath & "\"

Application.ScreenUpdating = False

Dim currFile As String
currFile = Dir(filePath & "*.docm")

Do While currFile <> ""

    Documents.Open (filePath & currFile)
    Documents(currFile).ExportAsFixedFormat _
        OutputFileName:=filePath & Left(currFile, Len(currFile) - Len(".docm")) & ".pdf", _
        ExportFormat:=wdExportFormatPDF, _
        OpenAfterExport:=False, _
        OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
        From:=1, To:=1, Item:=wdExportDocumentContent, IncludeDocProps:=True, _
        KeepIRM:=True, CreateBookmarks:=wdExportCreateNoBookmarks, _
        DocStructureTags:=True, BitmapMissingFonts:=True, UseISO19005_1:=False
    Documents(currFile).Close

    currFile = Dir()
Loop

Application.ScreenUpdating = True

End Sub

1 Ответ

0 голосов
/ 25 октября 2018

Попробуйте: 

Sub ConvertDocs2PDFs()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document
strDocNm = ActiveDocument.FullName
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    With wdDoc
      .SaveAs FileName:=Split(.FullName, ".doc")(0) & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
      .Close SaveChanges:=False
    End With
  End If
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
...