Office: (Office 2016) PDF als E-Mail Anhang nur die erste Seite

Hallo liebes Forum,
Den u. s. Code habe ich mir zusammengebastelt.
Das Makro sorgt dafür, dass die Datei als PDF in eine neue E-Mail angehängt wird. Außerdem werden noch Betreff und Text gefüllt. Die Empfänger Adresse wird je angekreuztem Feld gefüllt.

Es wird das ganze Dokument in ein PDF umgewandelt.
Besteht die Möglichkeit, dass nur die erste Seite in ein PDF umgewandelt wird?

VG
Mark

Code:

Option Explicit
Public Sub An_PS_2_senden()
  Dim objDoc As Document
  Dim objOL As Object
  Dim objMail As Object
  Dim colMailInfos As Collection
  Dim objMailInfo As clsMailInfo
  Dim strSignature As String
  Dim strPDFPath As String
  Dim blnOLNewInstance As Boolean
 
  Set objDoc = ActiveDocument
 
  If objDoc.Path = "" Then
      MsgBox "Dokument muss erst gespeichert werden!", vbExclamation
      Exit Sub
  End If

  ' Init Outlook
  On Error Resume Next
  Set objOL = GetObject(, "Outlook.Application")
  If Err.Number <> 0 Then
    Set objOL = CreateObject("Outlook.Application")
    blnOLNewInstance = True
  End If
  On Error GoTo 0
 
  ' Get MailInfos
  Set colMailInfos = GetMailInfos(objDoc)
 
  ' Get Signature
 '  strSignature = LoadSignatureFromFile()
 
'   If Len(strSignature) = 0 Then
'     MsgBox "Signaturdatei konnte nicht geladen werden!", vbInformation + vbOKOnly, "Hinweis"
'   End If
 
  ' Temporary caching of the document as a PDF file for use as an attachment
  strPDFPath = SaveToPDF(objDoc)
 
  ' Create and send all requested mails
  For Each objMailInfo In colMailInfos
    
    Set objMail = objOL.CreateItem(0)       ' olMailItem
    ComposeMail objMail, objMailInfo, strPDFPath, strSignature
    objMail.Display
  Next
 
  ' Remove attachment file
  On Error Resume Next
  Kill strPDFPath
  On Error GoTo 0
 
  ' Cleanup
  Set objMail = Nothing
  Set objMailInfo = Nothing
  Set colMailInfos = Nothing
  Set objOL = Nothing
  Set objDoc = Nothing
End Sub

' -----------------------------------------------------------------------------
' Private methods
' -----------------------------------------------------------------------------
Private Function GetMailInfos(ByVal pDoc As Document) As Collection
  Dim colMailInfos As Collection
  Dim objFF As FormField
  Dim objMailInfo As clsMailInfo
  Dim astrStatusText() As String
 
  Set colMailInfos = New Collection
    
  For Each objFF In pDoc.FormFields
    If objFF.Type = wdFieldFormCheckBox And objFF.Result = "1" Then
      
      On Error GoTo MailInfos_Err
      
      Set objMailInfo = New clsMailInfo
      objMailInfo.ControlName = objFF.Name
      
      astrStatusText = Split(objFF.StatusText, "~")
      objMailInfo.MailAddr = Trim(astrStatusText(0))
      objMailInfo.Salutation = Trim(astrStatusText(1))
      colMailInfos.Add Item:=objMailInfo, Key:=objFF.Name

MailInfos_Cont:
    End If
  Next

  Set GetMailInfos = colMailInfos
  Exit Function
 
MailInfos_Err:
'  MsgBox _
    "Error: Invalid Statustext" & vbCrLf _
    & "Checkbox " & objFF.Name, vbExclamation, "Fehlermeldung"
  Resume MailInfos_Cont
End Function


Private Function LoadSignatureFromFile() As String
  Dim objFSO As Object        ' FileSystemObject
  Dim objTsr As Object        ' TextStream
  Dim strFilename As String
 '  Dim strSignature As String

 '  On Error GoTo LoadSignatureFromFile_Err
 
'   strFilename = Environ$("APPDATA") & "\Microsoft\Signatures\kurz.htm"
 
'   Set objFSO = CreateObject("Scripting.FileSystemObject")
'   Set objTsr = objFSO.OpenTextFile(strFilename, 1)          ' ForReading
'   strSignature = objTsr.ReadAll
'   objTsr.Close
 '  LoadSignatureFromFile = strSignature

' LoadSignatureFromFile_Err:
  Set objTsr = Nothing
  Set objFSO = Nothing
End Function


Private Function SaveToPDF(ByVal pDoc As Document) As String
  Dim objFSO As Object                  ' FileSystemObject
  Dim strTempPath As String
  Dim strFilename As String
  Dim strPDFFilename As String
 
  On Error GoTo SaveToPDF_Err
 
  ' Ensure that all changes have been saved
  If Not pDoc.Saved Then pDoc.Save
 
  ' Save document as temporary PDF
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  strTempPath = objFSO.GetSpecialFolder(2).Path
  strFilename = objFSO.GetBaseName(pDoc.Name)
  strPDFFilename = objFSO.BuildPath(strTempPath, strFilename & ".pdf")
  pDoc.SaveAs2 strPDFFilename, wdFormatPDF
  SaveToPDF = strPDFFilename

SaveToPDF_Err:
  Err.Clear
  Set objFSO = Nothing
End Function

Private Sub ComposeMail( _
    ByVal pMailItem As Object, _
    ByVal pMailInfo As clsMailInfo, _
    ByVal AttachmentFilePath As String, _
  ByVal Signature As String)
    
    Const cMailText As String = _
          "<p style='font-family:Type Office " & _
          "sans-serif; font-size:11pt;'>" & _
          "{0}," & "<br></br>" & "<br></br>" & _
          "Text" & "</p>"
    
    With pMailItem
      .To = pMailInfo.MailAddr
      .Subject = "Betreff XXX"
      .BodyFormat = 2                       ' olFormatHTML
      .HTMLBody = Replace(cMailText, "{0}", pMailInfo.Salutation, 1, 1)
      .HTMLBody = .HTMLBody & Signature
      .Attachments.Add AttachmentFilePath, 1
    End With

    Debug.Print "("; pMailInfo.ControlName; ") MailTo: <"; pMailInfo.MailAddr; "> composed!"
End Sub
    

 

Hallo beBerlin,

ich hab jetzt nicht dein ganzes Opus nachvollzogen. Aber was das Speichern als PDF betrifft, würde ich statt mit der SaveAs2-Methode lieber mit der ExportAsFixedFormat-Methode arbeiten. Diese kennt den Parameter Range, wo du angeben kannst, ob du das ganze Dokument, die aktuelle Seite, oder einen (Seiten-)bereich exportieren willst.