AtTipps, Tricks & Tools
für Microsoft® Office Outlook®

Grüner PfeilJetzt Upgrade kaufen

English
Tipps Programmierung Nur erste bzw. eine Seite von E-Mail ausdrucken

Nur erste bzw. eine Seite von E-Mail ausdrucken

Zuletzt aktualisiert am 10. November 2009

Mit Outlook® 2002/2003 konnte man zumindest HTML-E-Mails noch Seitenweise ausdrucken. Nur-Text- und Rich-Text-E-Mails ließen sich auch damit nur komplett ausdrucken. Ab Outlook® 2007 kann man nicht einmal mehr HTML-E-Mails Seitenweise ausdrucken. Häufig benötigt der Anwender aber nur die 1. Seite oder bestimmte Seiten einer E-Mail.

Als Workaround bieten sich an:

  1. Copy & Paste-Aktionen in andere Textverarbeitungsprogramme (z. B. Microsoft® Word)
  2. "Druck" der ganzen E-Mail in ein PDF-Dokument und von dort dann nur die 1. bzw. benötigte Seite
  3. Die geöffnete Nachricht bearbeiten (Outlook® 2002/2003: Bearbeiten -> Nachricht bearbeiten, Outlook® 2007: Andere Aktionen -> Nachricht bearbeiten), nicht benötigten Text löschen, den Rest ausdrucken und dann die E-Mail ohne zu speichern schließen
  4. Die E-Mail weiterleiten und dann wie unter 3. verfahren
  5. In Outlook® 2007 kann man HTML-E-Mails im Browser anzeigen lassen (Andere Aktionen -> Ansicht im Browser) und dann die Druckfunktionen des Browsers nutzen

Den Workaround über Microsoft® Word nimmt Ihnen das folgende Codebeispiel ab. Damit können Sie per Mausklick von einer markierten oder geöffneten E-Mail sofort und ohne Umwege die 1. Seite bzw. die gewünschten Seiten ausdrucken (auch von geschlossenen E-Mails). Bei HTML-Mails werden im Text eingebettete Bilder leider nicht dargestellt.

Alternativ können Sie auch mit dem Tool OutlookPrinter Seitenweise ausdrucken.

Achtung: Wird in Outlook® 2002/2003 Word als E-Mail-Editor verwendet, muss folgender Code in der Normal.dot gespeichert werden:

Option Explicit
 
Public Sub PrintFirstPage()
     Dim objOutlook As Object
     Set objOutlook = GetObject(, "Outlook.Application")
     Call objOutlook.CallPrintFirstPage
     Set objOutlook = Nothing
End Sub
Public Sub PrintPages()
     Dim objOutlook As Object
     Set objOutlook = GetObject(, "Outlook.Application")
     Call objOutlook.CallPrintPages
     Set objOutlook = Nothing
End Sub

Der Programmablauf ist wie folgt:

  1. E-Mail als temporäre Datei speichern
  2. Word starten und temporäre Datei öffnen
  3. Geöffnetes Dokument anpassen und gewünschte Seite(n) ausdrucken
  4. Dokument und gegebenenfalls Word schließen
  5. Temporäre Datei löschen

Der Code besteht aus 2 Hauptteilen: Dem eigentlichen Code zum Ausdrucken der 1. Seite bzw. der gewünschten Seiten der E-Mail und einem Programmteil zum automatischen Erstellen entsprechender Schaltflächen in Outlook® bzw. in einer geöffneten E-Mail. Hinweis: Bei Outlook® 2007 finden Sie die Schaltflächen unter dem Register Add-Ins.

Anmerkungen zum Programmcode:

  • Es werden 2 Schaltflächen erstellt. Eine zum Drucken der 1. Seite ohne Druckerauswahl und eine zur Auswahl des Druckers bzw. der zu druckenden Seiten.
  • Nur bei Sofortdruck der 1. Seite: Die Konstante PRINTER kann mit einem bestimmten Drucker vorbelegt werden. Wie Sie diesen ermitteln ist in der Prozedur GetActivePrinter beschrieben. Wenn Sie die Konstante leer lassen, wird auf dem gerade aktiven Drucker ausgedruckt.
  • Die Seitenränder können Sie in der Prozedur SetMargins festlegen bzw. anpassen.
  • Ebenso lässt sich die integrierte Fusszeile in der Prozedur InsertPageFooter ändern. Möchten Sie keine Fusszeile haben, setzen Sie bitte ein Hochkomma vor die Zeile Call InsertPageFooter(objWord).
  • Beachten Sie bitte auch die Kommentare im Programmcode. Sie können z. B. mit den Konstanten verschiedene Optionen festlegen (Kopf bzw. Anlagen ausdrucken).

Zur Verwendung dieses Beispiels beachten Sie bitte die wichtigen Hinweise, sowie den Workshop VBA in Outlook® verwenden.

Für Outlook® 2002, Outlook® 2003, Outlook® 2007

Den Code bitte in ein neues Modul kopieren (Einfügen -> Modul im VBA-Editor):

Option Explicit
 
' API-Deklarationen
Private Declare Function BringWindowToTop Lib "user32" _
    (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias _
    "FindWindowA" (ByVal lpClassName As String, ByVal _
    lpWindowName As String) As Long
 
Public Sub PrintFirstPage()
    Call PrintEmail(True)
End Sub
 
Public Sub PrintPages()
    Call PrintEmail(False)
End Sub
 
Private Sub PrintEmail(ByVal blnFirstOnly As Boolean)
 
    '=====================================================================
    ' Druckt eine E-Mail in Word aus. Ist "blnFirstOnly" wahr, wird nur
    ' die 1. Seite auf dem Standarddrucker, bzw. dem in "PRINTER" gesetzten
    ' Drucker ausgerdruckt.
    ' (c) Peter Marchert - http://www.outlook-stuff.com
    ' 2008-10-22 Version 1.0.0
    ' 2008-10-27 Version 1.1.0
    ' 2008-10-28 Version 2.0.1
    ' 2008-11-18 Version 2.0.2
    ' 2008-11-20 Version 2.0.3
    ' 2008-11-21 Version 2.0.4
    ' 2009-01-21 Version 2.0.5
    ' 2009-06-14 Version 2.0.6
    '=====================================================================
 
    ' Drucker festlegen, auf dem gedruckt werden soll.
    ' Den Druckernamen können Sie mit der Funktion "GetActivePrinter" ermitteln
    ' "" = Druckerauswahl anzeigen
    Const PRINTER As String = ""
 
    ' Kopf ausdrucken? True = ausdrucken, False = nicht ausdrucken
    Const PRINTHEAD As Boolean = True
 
    ' Anlagen mit ausdrucken? True = ausdrucken, False = nicht ausdrucken
    Const PRINTATTACH As Boolean = True
 
    ' Konstante für Länge der Trennlinien
    Const HYPHENS As Long = 94
 
    '---------------------------------------------------------------------
 
    Dim objWord As Object               ' Word
    Dim objMail As Object               ' Aktuelle E-Mail
    Dim objAttachment As Object         ' Anlage
 
    Dim strActivePrinter As String      ' Aktueller Drucker in Word
 
    Dim strFolder As String             ' Temporärer Ordner
    Dim strFile As String               ' Temporäre Datei
 
    Dim strHead As String               ' Info-Kopf
    Dim strFormat As String             ' Nachrichtenformat
    Dim strAttachments As String        ' Anlagen
    Dim strSize As String               ' E-Mailgröße
 
    Dim lngHandle As Long               ' Fensterhandle
    Dim lngAnswer As Long               ' Antwort auf Druckerauswahl
 
    Dim blnIsOpen As Boolean            ' Merker, ob Word geöffnet war
 
    '---------------------------------------------------------------------
    ' Aktive E-Mail refernzieren (geöffnete hat Vorrang vor markierter)
    '---------------------------------------------------------------------
    Set objMail = GetActiveEmail
 
    '---------------------------------------------------------------------
    ' Keine E-Mail geöffnet bzw. markiert?
    '---------------------------------------------------------------------
    If objMail Is Nothing Then
        Call ShowMessage("Bitte markieren bzw. öffnen Sie eine E-Mail.")
        GoTo ExitProc
    End If
 
    '---------------------------------------------------------------------
    ' Ordner "Eigene Dateien" ermitteln
    '---------------------------------------------------------------------
    strFolder = GetMyDocumentsFolder
 
    '---------------------------------------------------------------------
    ' Kein Ordner -> Windows Script Host nicht installiert/defekt
    '---------------------------------------------------------------------
    If strFolder = "" Then
 
        '-----------------------------------------------------------------
        ' Ordner aus der Registrierung lesen
        '-----------------------------------------------------------------
        strFolder = GetSetting("ESM-Tools\VBA-Project", "PrintEmail", _
            "MyDocuments", "")
 
        '-----------------------------------------------------------------
        ' Wenn noch nicht vorhanden, dann zur Eingabe auffordern
        '-----------------------------------------------------------------
        Do While Dir(strFolder, vbDirectory) = ""
 
            strFolder = InputBox("Bitte Pfad zu ""Eigene Dateien"" eingeben:" _
                , "", strFolder)
 
            '-------------------------------------------------------------
            ' Eingabe abgebrochen?
            '-------------------------------------------------------------
            If strFolder = "" Then GoTo ExitProc
 
            '-------------------------------------------------------------
            ' Ungültiger Ordner?
            '-------------------------------------------------------------
            If Dir(strFolder, vbDirectory) = "" Then
                strFolder = ""
                Call ShowMessage("Der eingegebene Pfad ist ungültig." & _
                    vbCrLf & "Bitte geben Sie einen gültigen Pfad ein.")
            End If
 
        Loop
 
        '-----------------------------------------------------------------
        ' Ordner speichern
        '-----------------------------------------------------------------
        Call SaveSetting("ESM-Tools\VBA-Project", "PrintEmail", "MyDocuments", strFolder)
 
    End If
 
    '---------------------------------------------------------------------
    ' Bei HTML- und Rich-Text-E-Mails wird ein Ordner beim temporären
    ' Speichern angelegt. Damit dieser gelöscht werden kann, werden die
    ' Dateien in einem eigenen, temporären Ordner gespeichert, der an-
    ' schließend komplett gelöscht wird.
    '---------------------------------------------------------------------
    strFolder = strFolder & "\~temp"
    If Dir(strFolder, vbDirectory) = "" Then Call MkDir(strFolder)
 
    '---------------------------------------------------------------------
    ' E-Mail als Datei speichern
    '---------------------------------------------------------------------
    If objMail.BodyFormat = olFormatHTML Then
        strFile = strFolder & "\" & Format(Now, "yyyyddmm-hhmmss") & ".html"
        Call objMail.SaveAs(strFile, olHTML)
    ElseIf objMail.BodyFormat = olFormatRichText Then
        strFile = strFolder & "\" & Format(Now, "yyyyddmm-hhmmss") & ".rtf"
        Call objMail.SaveAs(strFile, olRTF)
    Else
        strFile = strFolder & "\" & Format(Now, "yyyyddmm-hhmmss") & ".txt"
        Call objMail.SaveAs(strFile, olTXT)
    End If
 
    '---------------------------------------------------------------------
    ' Kopf ausdrucken?
    '---------------------------------------------------------------------
    If PRINTHEAD Then
 
        '-----------------------------------------------------------------
        ' E-Mail-Format ermitteln
        '-----------------------------------------------------------------
        Select Case objMail.BodyFormat
            Case olFormatPlain: strFormat = "Nur-Text-Format"
            Case olFormatHTML: strFormat = "HTML-Format"
            Case olFormatRichText: strFormat = "Rich-Text-Format"
            Case Else: strFormat = "Unbekanntes Format"
        End Select
 
        '-----------------------------------------------------------------
        ' Anlagen mit ausdrucken?
        '-----------------------------------------------------------------
        If PRINTATTACH Then
            For Each objAttachment In objMail.Attachments
                strAttachments = strAttachments & objAttachment.DisplayName & "; "
            Next
            If Not strAttachments = "" Then strAttachments = "Anlagen:" & vbCrLf _
                & strAttachments
        End If
 
        '-----------------------------------------------------------------
        ' E-Mailgröße berechnen
        '-----------------------------------------------------------------
        If objMail.Size < 1024 Then
            strSize = objMail.Size & " Byte"
        ElseIf objMail.Size / 1024 < 1024 Then
            strSize = Round(objMail.Size / 1024, 0) & " KByte"
        Else
            strSize = Round(objMail.Size / 1024 / 1024, 2) & " MByte"
        End If
 
        '-----------------------------------------------------------------
        ' Ein paar Angaben zur E-Mail hinzufügen
        '-----------------------------------------------------------------
        With objMail
            strHead = String(HYPHENS, "-") & vbCrLf & _
                "Ordner:     " & .Parent.FolderPath & " (" & strFormat & _
                    ", " & strSize & ")" & vbCrLf
            If .Categories <> "" Then strHead = strHead & _
                "Kategorien: " & .Categories & vbCrLf
        End With
 
    End If
 
    '---------------------------------------------------------------------
    ' Word referenzieren
    '---------------------------------------------------------------------
    Set objWord = GetWordObject(blnIsOpen)
 
    '---------------------------------------------------------------------
    ' Kein Word installiert?
    '---------------------------------------------------------------------
    If objWord Is Nothing Then
        Call ShowMessage("Word wird zum Ausdrucken benötigt," & _
            "aber es konnte" & vbCrLf & "nicht gestartet werden.")
        GoTo ExitProc
    End If
 
    With objWord
 
        '-----------------------------------------------------------------
        ' Word anzeigen (nur für Testzwecke)
        '-----------------------------------------------------------------
        '.Visible = True
 
        '-----------------------------------------------------------------
        ' Gespeicherte Temp-Datei öffnen
        '-----------------------------------------------------------------
        Call .Documents.Open(strFile)
 
        '-----------------------------------------------------------------
        ' Ränder festlegen
        '-----------------------------------------------------------------
        Call SetMargins(objWord)
 
        '-----------------------------------------------------------------
        ' Fusszeile einfügen (Druckdatum und Seitenanzahl)
        '-----------------------------------------------------------------
        Call InsertPageFooter(objWord)
 
        '-----------------------------------------------------------------
        ' Kopf einfügen?
        '-----------------------------------------------------------------
        If PRINTHEAD Then
 
            '-------------------------------------------------------------
            ' Zum Anfang gehen (6=wdStory, 0=wdMove)
            '-------------------------------------------------------------
            Call .Selection.HomeKey(6, 0)
 
            '-------------------------------------------------------------
            ' Leerzeilen einfügen
            '-------------------------------------------------------------
            Call .Selection.TypeText(vbCrLf)
            Call .Selection.TypeText(vbCrLf)
 
            '-------------------------------------------------------------
            ' Wieder zum Anfang gehen (6=wdStory, 0=wdMove)
            '-------------------------------------------------------------
            Call .Selection.HomeKey(6, 0)
 
            '-------------------------------------------------------------
            ' Schriftart für den Kopf umstellen
            '-------------------------------------------------------------
            .Selection.Font.Name = "Courier"
            .Selection.Font.Size = "8"
            .Selection.Font.Bold = False
 
            '-------------------------------------------------------------
            ' Anzahl Seiten "einfügen" (2=wdStatisticPages)
            '-------------------------------------------------------------
            strHead = Replace(strHead, "%X%", .ActiveDocument.ComputeStatistics(2))
 
            '-------------------------------------------------------------
            ' Info-Kopf einfügen
            '-------------------------------------------------------------
            Call .Selection.TypeText(strHead)
            If Not strAttachments = "" Then
                Call .Selection.TypeText(String(HYPHENS, "-") & vbCrLf & _
                    strAttachments & vbCrLf)
            End If
            Call .Selection.TypeText(String(HYPHENS, "-") & vbCrLf)
 
        End If
 
        '-----------------------------------------------------------------
        ' Aktiven Drucker merken
        '-----------------------------------------------------------------
        strActivePrinter = .ActivePrinter
 
        '-----------------------------------------------------------------
        ' Nur die 1. Seite oder gewünschte Seiten ausdrucken?
        '-----------------------------------------------------------------
        If blnFirstOnly Then
 
            '-------------------------------------------------------------
            ' Bei Bedarf gewünschten Drucker einstellen
            '-------------------------------------------------------------
            If Not strActivePrinter = PRINTER And Not PRINTER = "" Then
                On Error Resume Next
                .ActivePrinter = PRINTER
                If Not Err.Number = 0 Then
                    Call ShowMessage("Der Drucker """ & PRINTER & _
                        """ konnte nicht aktiviert werden.")
                    GoTo ExitProc
                End If
            End If
 
            '-------------------------------------------------------------
            ' E-Mail ausdrucken (4=wdPrintRangeOfPages)
            '-------------------------------------------------------------
            Call .ActiveDocument.PrintOut(Range:=4, Background:=False, Pages:="1")
 
            '-------------------------------------------------------------
            ' Ursprünglichen Drucker wieder einstellen
            '-------------------------------------------------------------
            If Not strActivePrinter = PRINTER And Not PRINTER = "" Then
                .ActivePrinter = strActivePrinter
            End If
 
        Else
 
            '-------------------------------------------------------------
            ' Word nach vorne holen, damit Druckerdialog auch gesehen wird
            '-------------------------------------------------------------
            lngHandle = FindWindow(vbNullString, _
                .ActiveDocument.Name & " - " & objWord.Name)
            If lngHandle Then Call BringWindowToTop(lngHandle)
 
            '-------------------------------------------------------------
            ' Druckerauswahldialog von Word anzeigen
            '-------------------------------------------------------------
            lngAnswer = .Dialogs(88).Show '88=wdDialogFilePrint
 
            '-------------------------------------------------------------
            ' War Word nicht geöffnet, dann verstecken (wird durch die
            ' Show-Methode sichtbar)
            '-------------------------------------------------------------
            If Not blnIsOpen Or .Documents.Count = 0 Then .Visible = False
 
        End If
 
        '-----------------------------------------------------------------
        ' Dokument ohne zu speichern schließen
        '-----------------------------------------------------------------
        Call .ActiveDocument.Close(SaveChanges:=False)
 
        '-----------------------------------------------------------------
        ' War Word nicht geöffnet, dann Word schließen
        '-----------------------------------------------------------------
        If Not blnIsOpen Then Call .Quit(SaveChanges:=False)
 
    End With
 
ExitProc:
 
    '---------------------------------------------------------------------
    ' Temp-Ordner löschen
    '---------------------------------------------------------------------
    Call KillFolder(strFolder)
 
    '---------------------------------------------------------------------
    ' Clean Up
    '---------------------------------------------------------------------
    Set objAttachment = Nothing
    Set objMail = Nothing
    Set objWord = Nothing
 
End Sub
 
Private Sub SetMargins(ByVal objWord As Object)
 
    '=====================================================================
    ' Legt die Ränder in Word fest
    ' 2008-11-21 Version 1.0.0
    '=====================================================================
 
    On Error Resume Next
 
    With objWord.ActiveDocument.PageSetup
        .topMargin = objWord.CentimetersToPoints(2.5)       ' Oben
        .bottomMargin = objWord.CentimetersToPoints(2)      ' Unten
        .LeftMargin = objWord.CentimetersToPoints(2.5)      ' Links
        .rightMargin = objWord.CentimetersToPoints(2)       ' Rechts
        .HeaderDistance = objWord.CentimetersToPoints(1.25) ' Kopfzeile
        .FooterDistance = objWord.CentimetersToPoints(1.25) ' Fusszeile
    End With
 
    '---------------------------------------------------------------------
    ' Clean Up
    '---------------------------------------------------------------------
    Set objWord = Nothing
 
End Sub
 
Private Sub InsertPageFooter(ByVal objWord As Object)
 
    '=====================================================================
    ' Fügt eine Fusszeile in das Worddokument ein
    ' 2008-11-21 Version 1.0.0
    '=====================================================================
 
    On Error Resume Next
 
    With objWord
        .ActiveWindow.ActivePane.View.SeekView = 10 '10=wdSeekCurrentPageFooter
        .Selection.Font.Name = "Courier"
        .Selection.Font.Size = 8
        .Selection.TypeText Text:="Gedruckt: "
        .Selection.Fields.Add Range:=.Selection.Range, Type:=31 '31=wdFieldDate
        .Selection.TypeText Text:=" "
        .Selection.Fields.Add Range:=.Selection.Range, Type:=32 '32=wdFieldTime
        .Selection.TypeText Text:=vbTab & vbTab & "Seite "
        .Selection.Fields.Add Range:=.Selection.Range, Type:=33 '33=wdFieldPage
        .Selection.TypeText Text:=" von "
        .Selection.Fields.Add Range:=.Selection.Range, Type:=26 '26=wdFieldNumPages
        .ActiveWindow.ActivePane.View.SeekView = 0 '0=wdSeekMainDocument
    End With
 
    '---------------------------------------------------------------------
    ' Clean Up
    '---------------------------------------------------------------------
    Set objWord = Nothing
 
End Sub
 
Private Function GetActiveEmail() As Outlook.MailItem
 
    '=====================================================================
    ' Gibt die aktuelle E-Mail zurück (geöffnet oder markiert)
    ' 2008-11-21 Version 1.0.0
    '=====================================================================
 
    On Error Resume Next
 
    '---------------------------------------------------------------------
    ' Ist eine E-Mail geöffnet, wird diese verwendet
    '---------------------------------------------------------------------
    Set GetActiveEmail = Outlook.ActiveInspector.CurrentItem
 
    '---------------------------------------------------------------------
    ' Keine geöffnet, dann die markierte verwenden
    '---------------------------------------------------------------------
    If GetActiveEmail Is Nothing Or GetActiveEmail.To = "" Then
        Set GetActiveEmail = Outlook.ActiveExplorer.Selection(1)
    End If
 
End Function
 
Private Function GetMyDocumentsFolder() As String
 
    '=====================================================================
    ' Gibt den Ordner "Eigene Dateien" zurück ("Dokumente" unter Vista)
    ' 2008-11-21 Version 1.0.0
    '=====================================================================
 
    Dim objWSHShell As Object           ' Windows Script Host
 
    On Error Resume Next
 
    '---------------------------------------------------------------------
    ' Instanz des Windows Script Host starten
    '---------------------------------------------------------------------
    Set objWSHShell = CreateObject("WScript.Shell")
 
    '---------------------------------------------------------------------
    ' Ordner "Eigene Dateien" ermitteln
    '---------------------------------------------------------------------
    GetMyDocumentsFolder = objWSHShell.SpecialFolders("MyDocuments")
 
    '---------------------------------------------------------------------
    ' Clean Up
    '---------------------------------------------------------------------
    Set objWSHShell = Nothing
 
End Function
 
Private Function GetWordObject(Optional ByRef blnIsOpen As Boolean) As Object
 
    '=====================================================================
    ' Gibt eine laufende Wordinstanz zurück oder startet eine neue
    ' 2008-11-21 Version 1.0.0
    '=====================================================================
 
    On Error Resume Next
 
    '---------------------------------------------------------------------
    ' Versuchen Word zu referenzieren
    '---------------------------------------------------------------------
    Set GetWordObject = GetObject(, "Word.Application")
 
    '---------------------------------------------------------------------
    ' Wenn erfolglos, dann neue Instanz starten
    '---------------------------------------------------------------------
    If GetWordObject Is Nothing Then
 
        Set GetWordObject = CreateObject("Word.Application")
 
    Else
 
        '-----------------------------------------------------------------
        ' Merker setzen, dass Word schon geöffnet war
        '-----------------------------------------------------------------
        blnIsOpen = True
 
    End If
 
End Function
 
Private Sub ShowMessage(ByVal strMessage As String)
 
    '=====================================================================
    ' Zeigt eine Fehlermeldung an. Wird Word als E-Mail-Editor verwendet,
    ' muss die geöffnete E-Mail minimiert werden, damit die Meldung
    ' sichtbar wird
    ' 2008-11-21 Version 1.0.0
    '=====================================================================
 
    Dim blnIsWordMail As Boolean  ' Merker, ob Word E-Mail-Editor ist
 
    On Error Resume Next
 
    '---------------------------------------------------------------------
    ' Wird Word als Maileditor verwendet?
    '---------------------------------------------------------------------
    blnIsWordMail = Outlook.ActiveInspector.IsWordMail
 
    '---------------------------------------------------------------------
    ' Bei Word als E-Mail-Editor Fenster minimieren
    '---------------------------------------------------------------------
    If blnIsWordMail Then Outlook.ActiveInspector.WindowState = olMinimized
 
    '---------------------------------------------------------------------
    ' Meldung anzeigen
    '---------------------------------------------------------------------
    Call MsgBox(strMessage, vbCritical + vbOKOnly, "E-Mail drucken")
 
    '---------------------------------------------------------------------
    ' E-Mail wiederherstellen (Vollbild, da olNormalWindow nicht funktioniert)
    '---------------------------------------------------------------------
    If blnIsWordMail Then Outlook.ActiveInspector.WindowState = olMaximized
 
End Sub
 
Private Function GetActivePrinter()
 
    '=====================================================================
    ' Ermittelt den Namen des aktuellen Druckers in Word.
    ' 1. Starten Sie Word und stellen Sie den Drucker ein, auf den die E-Mails
    '    ausgedruckt werden sollen.
    ' 2. Drücken Sie STRG+G, um das Direktfenster zu öffnen
    ' 3. Setzen Sie den Cursor irgendwo innerhalb von "Function GetActivePrinter"
    '    und "End Function"
    ' 4. Drücken Sie "F5"
    ' 5. Kopieren Sie den ausgegebenen Namen und weisen Sie ihn der
    '    Konstanten "PRINTER" in der Prozedur "Sub PrintEmail" zu
    ' 2008-11-21 Version 1.0.0
    '=====================================================================
 
    Dim objWord As Object
 
    On Error Resume Next
 
    Set objWord = GetWordObject()
 
    Debug.Print objWord.ActivePrinter
 
    Set objWord = Nothing
 
End Function
 
Private Sub KillFolder(ByVal strFolder As String)
 
    '=====================================================================
    ' Löscht einen Ordner samt Inhalt
    ' 2009-01-21 Version 1.0.0
    '=====================================================================
 
    Dim objFSO As Object           ' File Scripting Objekt
 
    On Error Resume Next
 
    '---------------------------------------------------------------------
    ' Instanz des File Scripting Objekts starten
    '---------------------------------------------------------------------
    Set objFSO = CreateObject("Scripting.FileSystemObject")
 
    '---------------------------------------------------------------------
    ' Ordner löschen
    '---------------------------------------------------------------------
    Call objFSO.DeleteFolder(strFolder, True)
 
    '---------------------------------------------------------------------
    ' Clean Up
    '---------------------------------------------------------------------
    Set objFSO = Nothing
 
End Sub

Dieser Codeteil muss in das Modul DieseOutlookSitzung kopiert werden:

Option Explicit
 
Private WithEvents m_objInspectors As Outlook.Inspectors
Private WithEvents m_objInspector As Outlook.Inspector
 
Private Sub Application_Startup()
 
    '====================================================================
    ' Erstellt beim Programmstart 2 Schaltflächen und überwacht die Er-
    ' eignisse von Formularen.
    ' 2008-11-21 Version 1.0.0
    '====================================================================
 
    Dim objCmdBar As Office.CommandBar
 
    On Error Resume Next
 
    '---------------------------------------------------------------------
    ' Kein Explorer geöffnet (z. B. beim Verwenden der Senden An-Methode)
    '---------------------------------------------------------------------
    If Outlook.Explorers.Count = 0 Then Exit Sub
 
    '---------------------------------------------------------------------
    ' Ereignisse von Formularen überwachen
    '---------------------------------------------------------------------
    Set m_objInspectors = Outlook.Inspectors
 
    '---------------------------------------------------------------------
    ' Standard-Menüleiste refernzieren
    '---------------------------------------------------------------------
    Set objCmdBar = Outlook.ActiveExplorer.CommandBars("Standard")
 
    '---------------------------------------------------------------------
    ' Schaltfläche zum Drucken der 1. Seite hinzufügen
    '---------------------------------------------------------------------
    Call AddButton(objCmdBar, "cbbPrintFirstPage")
 
    '---------------------------------------------------------------------
    ' Schaltfläche zum Drucken beliebiger Seiten hinzufügen
    '---------------------------------------------------------------------
    Call AddButton(objCmdBar, "cbbPrintPages")
 
ExitProc:
 
    '---------------------------------------------------------------------
    ' Clean Up
    '---------------------------------------------------------------------
    Set objCmdBar = Nothing
 
End Sub
 
Private Sub Application_Quit()
    Set m_objInspectors = Nothing
End Sub
 
Private Function AddButton(ByVal objCmdBar As Office.CommandBar, ByVal strTag As String)
 
    '=====================================================================
    ' Fügt eine neue Schaltfläche einer Menüleiste hinzu (in Outlook bzw.
    ' in einer geöffneten E-Mail).
    ' 2008-11-21 Version 1.0.0
    '=====================================================================
 
    Dim objButton As Office.CommandBarButton
 
    On Error Resume Next
 
    '---------------------------------------------------------------------
    ' Schaltfläche schon vorhanden?
    '---------------------------------------------------------------------
    If ButtonExists(objCmdBar, strTag) Then GoTo ExitProc
 
    '---------------------------------------------------------------------
    ' Neue Schaltfläche hinzufügen
    '---------------------------------------------------------------------
    Set objButton = objCmdBar.Controls.Add(Type:=msoControlButton, _
        Before:=1, Temporary:=True)
 
    '---------------------------------------------------------------------
    ' Eigenschaften der Schaltfläche festlegen
    '---------------------------------------------------------------------
    With objButton
        .Style = msoButtonIcon
        If strTag = "cbbPrintFirstPage" Then
            .Caption = "1. Seite drucken"
            .OnAction = "PrintFirstPage"
            .FaceId = 71 ' 71=1, 4=Drucker, 24=E-Mail, 160=Dokument drucken
            .Tag = "cbbPrintFirstPage"
        Else
            .Caption = "E-Mail drucken"
            .OnAction = "PrintPages"
            .FaceId = 160 ' 71=1, 4=Drucker, 24=E-Mail, 160=Dokument drucken
            .Tag = "cbbPrintPages"
        End If
    End With
 
ExitProc:
 
    '---------------------------------------------------------------------
    ' Clean Up
    '---------------------------------------------------------------------
    Set objCmdBar = Nothing
    Set objButton = Nothing
 
End Function
 
Public Sub CallPrintFirstPage()
 
    '=====================================================================
    ' Hilfsroutine, um Makro aus Word aufrufen zu können, wenn Word als
    ' E-Mail-Editor verwendet wird. Der Aufruf funktioniert nur aus dem
    ' Modul "DieseOutlookSitzung".
    ' Wenn Sie Word als E-Mail-Editor verwenden, muss folgender Code in
    ' der Normal.dot gespeichert werden (auskommentieren nicht vergessen):
    '
    ' Option Explicit
    '
    ' Public Sub PrintFirstPage()
    '     Dim objOutlook As Object
    '     Set objOutlook = GetObject(, "Outlook.Application")
    '     Call objOutlook.CallPrintFirstPage
    '     Set objOutlook = Nothing
    ' End Sub
    ' Public Sub PrintPages()
    '     Dim objOutlook As Object
    '     Set objOutlook = GetObject(, "Outlook.Application")
    '     Call objOutlook.CallPrintPages
    '     Set objOutlook = Nothing
    ' End Sub
    '
    ' 2008-11-21 Version 1.0.0
    '=====================================================================
 
    Call PrintFirstPage
 
End Sub
 
Public Sub CallPrintPages()
 
    '=====================================================================
    ' Hilfsroutine, um Makro aus Word aufrufen zu können, wenn Word als
    ' E-Mail-Editor verwendet wird. Der Aufruf funktioniert nur aus dem
    ' Modul "DieseOutlookSitzung".
    ' 2008-11-21 Version 1.0.0
    '=====================================================================
 
    Call PrintPages
 
End Sub
 
Private Function ButtonExists(ByVal objCmdBar As Office.CommandBar, _
    ByVal strTag As String) As Boolean
 
    '=====================================================================
    ' Prüft, ob eine Schaltfläche auf einer Menüleiste existiert
    ' 2008-11-21 Version 1.0.0
    '=====================================================================
 
    Dim objControl  As Office.CommandBarControl
 
    On Error Resume Next
 
    '---------------------------------------------------------------------
    ' Schaltfläche auf der Menüleiste suchen
    '---------------------------------------------------------------------
    For Each objControl In objCmdBar.Controls
        If objControl.Tag = strTag Then
            ButtonExists = True
            Exit For
        End If
    Next
    '---------------------------------------------------------------------
    ' Clean Up
    '---------------------------------------------------------------------
    Set objControl = Nothing
    Set objCmdBar = Nothing
 
End Function
 
Private Sub m_objInspectors_NewInspector(ByVal Inspector As Inspector)
 
    '=====================================================================
    ' Beim Öffnen einer neuen E-Mail werden die Drucken-Schaltflächen hinzugefügt
    ' 2008-11-21 Version 1.0.0
    '=====================================================================
 
    Dim objCmdBar As Office.CommandBar
 
    '---------------------------------------------------------------------
    ' Handelt es sich um keine E-Mail wird beendet
    '---------------------------------------------------------------------
    If Not Inspector.CurrentItem.Class = olMail Then GoTo ExitProc
 
    '---------------------------------------------------------------------
    ' E-Mail referenzieren (um beim Schliessen darauf reagieren zu können)
    '---------------------------------------------------------------------
    Set m_objInspector = Inspector
 
    '---------------------------------------------------------------------
    ' Standard-Menüleiste refernzieren
    '---------------------------------------------------------------------
    Set objCmdBar = Inspector.CommandBars("Standard")
 
    '---------------------------------------------------------------------
    ' Schaltfläche zum Drucken der 1. Seite hinzufügen
    '---------------------------------------------------------------------
    Call AddButton(objCmdBar, "cbbPrintFirstPage")
 
    '---------------------------------------------------------------------
    ' Schaltfläche zum Drucken beliebiger Seiten hinzufügen
    '---------------------------------------------------------------------
    Call AddButton(objCmdBar, "cbbPrintPages")
 
ExitProc:
 
    '---------------------------------------------------------------------
    ' Clean Up
    '---------------------------------------------------------------------
    Set Inspector = Nothing
    Set objCmdBar = Nothing
 
End Sub
 
Private Sub m_objInspector_Close()
 
    '=====================================================================
    ' Beim Schließen eines E-Mail-Inspectors werden die Drucken-Schalt-
    ' flächen explizit wieder gelöscht, da sie sonst in Word übrig bleiben.
    ' 2008-11-21 Version 1.0.0
    '=====================================================================
 
    Dim objCmdBar As Office.CommandBar
 
    On Error Resume Next
 
    '---------------------------------------------------------------------
    ' Standard-Menüleiste refernzieren
    '---------------------------------------------------------------------
    Set objCmdBar = m_objInspector.CommandBars("Standard")
 
    '---------------------------------------------------------------------
    ' Schaltfläche zum Drucken der 1. Seite löschen
    '---------------------------------------------------------------------
    objCmdBar.FindControl(Tag:="cbbPrintFirstPage").Delete
 
    '---------------------------------------------------------------------
    ' Schaltfläche zum Drucken beliebiger Seiten löschen
    '---------------------------------------------------------------------
    objCmdBar.FindControl(Tag:="cbbPrintPages").Delete
 
    '---------------------------------------------------------------------
    ' Clean Up
    '---------------------------------------------------------------------
    Set m_objInspector = Nothing
    Set objCmdBar = Nothing
 
End Sub

Exklusive Sonderangebote und wertvolle Tipps!

Newsletter Melden Sie sich jetzt für den kostenlosen Newsletter Service von outlook-stuff.com an und profitieren Sie von exklusiven Sonderangeboten für ESM-Tools, sowie wertvollen Tipps für Ihren Umgang mit Outlook®!

Kurzmeldung

Neu: Kostenpflichtiger Support

Auf mehrfachen Wunsch wird seit heute u. a. kostenpflichtiger Support für Microsoft®-Programme, insbesondere von Outlook® angeboten.

 Weiterlesen...

Lebenslange Updates inkl.!

Ja, es ist wirklich wahr: Bei outlook-stuff.com zahlen Sie für Updates keinen Cent extra!
Lebenslage Updates inkl.!

1x bezahlen = immer benutzen!

zum Shop...

Produktpalette

Zu