Printing only first page of multiple PDF's

Hi there, does anyone know a code that can be implied within a macro in Outlook to print all the pages except for the last one of a PDF?

The code I current have to print PDF's from an email is:

Sub OpenDossierFolder()

Dim sPath

Dim iReply As String

iReply = InputBox("Dossiernummer:")

If iReply = "" Then

Exit Sub

Else

sPath = "\\nlsvfil001\trismd\Trisdigdocs\" & iReply & "\"

Shell "C:\Windows\Explorer.exe """ & sPath & "", vbNormalFocus

End If

End Sub

Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _

ExtString As String, DestFolder As String)

Dim ns As NameSpace

Dim Inbox As MAPIFolder

Dim SubFolder As MAPIFolder

Dim Item As Object

Dim Atmt As Attachment

Dim FileName As String

Dim MyDocPath As String

Dim I As Integer

Dim wsh As Object

Dim fs As Object

Dim sDate As Date

Dim aDate As String

On Error GoTo ThisMacro_err

Set ns = GetNamespace("MAPI")

Set Inbox = ns.GetDefaultFolder(olFolderInbox)

Set SubFolder = Inbox.Folders(OutlookFolderInInbox)

I = 0

' Check subfolder for messages and exit of none found

If SubFolder.Items.Count = 0 Then

MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _

vbInformation, "Nothing Found"

Set SubFolder = Nothing

Set Inbox = Nothing

Set ns = Nothing

Exit Sub

End If

'Create DestFolder if DestFolder = ""

If DestFolder = "" Then

Set wsh = CreateObject("WScript.Shell")

Set fs = CreateObject("Scripting.FileSystemObject")

MyDocPath = wsh.SpecialFolders.Item("mydocuments")

DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")

If Not fs.FolderExists(DestFolder) Then

1. fs.CreateFolder DestFolder

End If

End If

If Right(DestFolder, 1) <> "\" Then

DestFolder = DestFolder & "\"

End If

' Check each message for attachments and extensions

For Each Item In SubFolder.Items

For Each Atmt In Item.Attachments

If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then

sDate = Item.SentOn

aDate = Format(sDate, "yyyymmddhhmm")

FileName = DestFolder & aDate & Item.SenderName & " " & Atmt.FileName

1. Atmt.SaveAsFile FileName

I = I + 1

End If

Next Atmt

Next Item

' Show this message when Finished

If I > 0 Then

' MsgBox "De PDF bestanden staan in de map: " _

' & DestFolder, vbInformation, "Finished!"

Else

MsgBox "No attached files in your mail.", vbInformation, "Finished!"

End If

' Clear memory

ThisMacro_exit:

Set SubFolder = Nothing

Set Inbox = Nothing

Set ns = Nothing

Set fs = Nothing

Set wsh = Nothing

'Set DestFolder = Nothing

Exit Sub

' Error information

ThisMacro_err:

MsgBox "An unexpected error has occurred." _

& vbCrLf & "Please note and report the following information." _

& vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _

& vbCrLf & "Error Number: " & Err.Number _

& vbCrLf & "Error Description: " & Err.Description _

, vbCritical, "Error!"

Resume ThisMacro_exit

'-----------------------------------------

End Sub

Sub Saveattachementstofolder()

Dim ns As NameSpace

Dim Inbox As MAPIFolder

Dim SubFolder As MAPIFolder

Dim Msg As MailItem

Dim Messages As Selection

Dim ObjFolder As Outlook.Folder

Dim oMailItem As MailItem

Dim myCopiedItem As Outlook.MailItem

Dim x As Object

Dim olDestFolder As Outlook.MAPIFolder

Dim strFilelocation As String

strFilelocation = "C:\Facturen\"

On Error Resume Next

Kill (strFilelocation & ("*.*"))

On Error GoTo 0

Set ns = Application.GetNamespace("MAPI")

Set Inbox = ns.GetDefaultFolder(olFolderInbox)

Set SubFolder = Inbox.Folders("Facturen printen")

Set ObjFolder = SubFolder

'Set ObjFolder = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Folders("Facturen printen")

Set Messages = ActiveExplorer.Selection

If Messages.Count = 0 Then

Exit Sub

End If

'-----------------------------------------

For Each Msg In Messages

1. Msg.Move ObjFolder

Next

'-----------------------------------------

If Dir(strFilelocation, vbDirectory) = vbNullString Then

MkDir strFilelocation

End If

SaveEmailAttachmentsToFolder "Facturen printen", "", "C:\Facturen"

Shell "Explorer.exe /e,C:\Facturen", vbNormalFocus

Set olDestFolder = ns.GetDefaultFolder(olFolderInbox)

Set olDestFolder = olDestFolder.Folders("RIO RINTO")

Set olDestFolder = olDestFolder.Folders("Rio Tinto INVOICES")

Set ns = Nothing

Set Inbox = Nothing

Set SubFolder = Nothing

'-----------------------------------------

For Each Msg In ObjFolder.Items

1. Msg.Move olDestFolder

Next

For Each Msg In ObjFolder.Items

1. Msg.Move olDestFolder

Next

For Each Msg In ObjFolder.Items

1. Msg.Move olDestFolder

Next

For Each Msg In ObjFolder.Items

1. Msg.Move olDestFolder

Next

For Each Msg In ObjFolder.Items

1. Msg.Move olDestFolder

Next

For Each Msg In ObjFolder.Items

1. Msg.Move olDestFolder

Next

For Each Msg In ObjFolder.Items

1. Msg.Move olDestFolder

Next

For Each Msg In ObjFolder.Items

1. Msg.Move olDestFolder

Next

For Each Msg In ObjFolder.Items

1. Msg.Move olDestFolder

Next

For Each Msg In ObjFolder.Items

1. Msg.Move olDestFolder

Next

'-----------------------------------------

Set ns = Nothing

Set Inbox = Nothing

Set SubFolder = Nothing

Set Msg = Nothing

Set Messages = Nothing

Set ObjFolder = Nothing

Set oMailItem = Nothing

Set myCopiedItem = Nothing

Set x = Nothing

Set olDestFolder = Nothing

'Set strFilelocation = Nothing

End Sub

Sub batfile()

Dim batPath As String: batPath = "C:\bat\"

Call Shell(Environ$("COMSPEC") & " /c " & batPath & "\batchprint.bat", vbNormalFocus)

End Sub

Thanks in advance!