Delete last page from multiple word files and convert to pdf

[MacroHelp]

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

[gmayor]

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

[MacroHelp]

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

[MacroHelp]

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