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

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

Code:

---

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

---

Quote:

---

Originally Posted by gmayor

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

Code:

---

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

---

---

:clap: Fantastic thank you so much that works a treat. :yes