Consulting

Results 1 to 4 of 4

Thread: Delete last page from multiple word files and convert to pdf

  1. #1

    Delete last page from multiple word files and convert to pdf

    This macro works only for the first document in the folder for deleting the last page and saving to pdf, all of the files are saving to pdf, but i need to delete the past page in every word document first. please can you help me get this to work on every word file in the folder. so that each document is reduced from two pages to one page and saved as one page in the pdf. many thanks


    Sub merge()
    'Sub ConvertWordsToPdfs()
    Dim xIndex As String
    Dim xDlg As FileDialog
    Dim xFolder As Variant
    Dim xNewName As String
    Dim xFileName As String
    Set xDlg = Application.FileDialog(msoFileDialogFolderPicker)
    If xDlg.Show <> -1 Then Exit Sub
    Dim lngCharacters As Long
    Dim r As Range


    With ActiveDocument
    lngCharacters = .GoTo(wdGoToPage, wdGoToLast).Start
    Set r = .Range(lngCharacters - 1, .Range.End)
    r.Delete
    End With

    xFolder = xDlg.SelectedItems(1) + ""
    xFileName = Dir(xFolder & "*.*", vbNormal)
    While xFileName <> ""
    If ((Right(xFileName, 4)) <> ".doc" Or Right(xFileName, 4) <> ".docx") Then
    xIndex = InStr(xFileName, ".") + 1
    xNewName = Replace(xFileName, Mid(xFileName, xIndex), "pdf")
    Documents.Open FileName:=xFolder & xFileName, _
    ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
    PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
    WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
    wdOpenFormatAuto, XMLTransform:=""
    ActiveDocument.ExportAsFixedFormat OutputFileName:=xFolder & xNewName, _
    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
    ActiveDocument.Close
    End If
    xFileName = Dir()
    Wend
    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

  2. #2
    Based on your code I think you will find the following should work

    Sub merge()
    'Sub ConvertWordsToPdfs()
    Dim oDoc As Document
    Dim sIndex As String
    Dim fDlg As FileDialog
    Dim sFolder As String
    Dim sNewName As String
    Dim sFileName As String
    Dim lngCharacters As Long
    Dim r As Range
    
    
        Set fDlg = Application.FileDialog(msoFileDialogFolderPicker)
        If fDlg.Show <> -1 Then Exit Sub
    
    
        sFolder = fDlg.SelectedItems(1)
    
    
        Do Until Right(sFolder, 1) = "\"
            sFolder = sFolder & "\"
        Loop
    
    
        sFileName = Dir(sFolder & "*.doc?")
    
    
        While sFileName <> ""
            Set oDoc = Documents.Open(FileName:=sFolder & sFileName, _
                                      ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
                                      PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
                                      WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
                                      wdOpenFormatAuto, XMLTransform:="")
            With oDoc
                lngCharacters = .GoTo(wdGoToPage, wdGoToLast).Start
                Set r = .Range(lngCharacters - 1, .Range.End)
                r.Delete
            End With
    
    
            sIndex = InStr(sFileName, ".") + 1
            sNewName = Replace(sFileName, Mid(sFileName, sIndex), "pdf")
    
    
            oDoc.ExportAsFixedFormat OutputFileName:=sFolder & sNewName, _
                                     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
            oDoc.Close 0
            sFileName = Dir()
        Wend
        Set oDoc = Nothing
        Set r = Nothing
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3

    Thumbs up

    Quote Originally Posted by gmayor View Post
    Based on your code I think you will find the following should work

    Sub merge()
    'Sub ConvertWordsToPdfs()
    Dim oDoc As Document
    Dim sIndex As String
    Dim fDlg As FileDialog
    Dim sFolder As String
    Dim sNewName As String
    Dim sFileName As String
    Dim lngCharacters As Long
    Dim r As Range
    
    
        Set fDlg = Application.FileDialog(msoFileDialogFolderPicker)
        If fDlg.Show <> -1 Then Exit Sub
    
    
        sFolder = fDlg.SelectedItems(1)
    
    
        Do Until Right(sFolder, 1) = "\"
            sFolder = sFolder & "\"
        Loop
    
    
        sFileName = Dir(sFolder & "*.doc?")
    
    
        While sFileName <> ""
            Set oDoc = Documents.Open(FileName:=sFolder & sFileName, _
                                      ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
                                      PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
                                      WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
                                      wdOpenFormatAuto, XMLTransform:="")
            With oDoc
                lngCharacters = .GoTo(wdGoToPage, wdGoToLast).Start
                Set r = .Range(lngCharacters - 1, .Range.End)
                r.Delete
            End With
    
    
            sIndex = InStr(sFileName, ".") + 1
            sNewName = Replace(sFileName, Mid(sFileName, sIndex), "pdf")
    
    
            oDoc.ExportAsFixedFormat OutputFileName:=sFolder & sNewName, _
                                     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
            oDoc.Close 0
            sFileName = Dir()
        Wend
        Set oDoc = Nothing
        Set r = Nothing
    End Sub

  4. #4
    Fantastic thank you so much that works a treat.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •