Macro om word bijlages als pdf door te sturen

Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strcopiedfiles As String

' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")

' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection

' Set the Attachment folder.
strFolderpath = "C:\voorbeeld"

' Check each selected item for attachments. If attachments exist,
' save them to the strFolderPath folder and strip them from the item.
For Each objMsg In objSelection

    ' This code only strips attachments from mail items.
    ' If objMsg.class=olMail Then
    ' Get the Attachments collection of the item.
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
    strcopiedfiles = ""

    If lngCount > 0 Then

        ' We need to use a count down loop for removing items
        ' from a collection. Otherwise, the loop counter gets
        ' confused and only every other item is removed.

        For i = lngCount To 1 Step -1

            ' Save attachment before deleting from item.
            ' Get the file name.
            strFile = objAttachments.Item(i).FileName

            ' Combine with the path to the Temp folder.
            strFile = strFolderpath & strFile

            ' Save the attachment as a file.
            objAttachments.Item(i).SaveAsFile strFile

            'write the save as path to a string to add to the message
            'check for html and use html tags in link
            If objMsg.BodyFormat <> olFormatHTML Then
                strcopiedfiles = strcopiedfiles & vbCrLf & "<file://" & strFile & ">"
            Else
                strcopiedfiles = strcopiedfiles & "<br>" & "<a href='file://" & _
                strFile & "'>" & strFile & "</a>"
            End If
        Next i

        ' Adds the filename string to the message body and save it
        ' Check for HTML body
        If objMsg.BodyFormat <> olFormatHTML Then
            objMsg.Body = vbCrLf & "Het bestand/de betanden zijn opgeslagen op " & strcopiedfiles & " en de factuur is verstuurd naar xxx." & vbCrLf & objMsg.Body
        Else
            objMsg.HTMLBody = "<p>" & "Het bestand/de betanden zijn opgeslagen op " & strcopiedfiles & " en de factuur is verstuurd naar xxx."& "</p>" & objMsg.HTMLBody 
        End If
        objMsg.Save
    End If
Next

Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing

Dim email1 As String
Dim objMail As Outlook.MailItem
Dim strbody As String
Dim oldmsg As String
Dim senderaddress As String
Dim addresstype As Integer
Dim strsubject As String

email1 = "voorbeeld@voorbeeld.com"

Set objItem = GetCurrentItem()
objItem.UnRead = False
Set objMail = objItem.Forward

strbody = Replace(objItem.Body, objItem.Body, "")
objMail.To = email1
strsubject = "[ink]" & objItem.Subject
objMail.Subject = strsubject

objMail.Send

Set objItem = Nothing
Set objMail = Nothing

Dim myDestFolder As Folder
Dim ObjItem2 As Outlook.MailItem
Dim strMailboxName As String

strMailboxName = "voorbeeld1"
Set myDestFolder = Session.Folders(strMailboxName)
Set myDestFolder = myDestFolder.Folders("voorbeeld2")
Set myDestFolder = myDestFolder.Folders("Voorbeeld3")
Set ObjItem2 = GetCurrentItem()

ObjItem2.Move myDestFolder

End Sub

Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = _
objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = _
objApp.ActiveInspector.CurrentItem
Case Else
End Select
End Function