Nur erste bzw. eine Seite von E-Mail ausdrucken
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. In 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.
Update: Dieser Beitrag scheint überholt zu sein, da ich das Problem nicht mehr reproduzieren kann. Auch in Outlook® 2007 wird im Druckdialog ein Seitenbereich angeboten, mit dem man auch einzelne HTML-Seiten ausdrucken kann. Getestet habe ich es unter Windows Vista®. Eventuell wurde das Problem durch ein Update bzw. Service-Pack behoben.
Als Workaround bieten sich an:
-
Copy & Paste-Aktionen in andere Textverarbeitungsprogramme (z. B. Microsoft® Word)
-
"Druck" der ganzen E-Mail in ein PDF-Dokument und von dort dann nur die 1. bzw. benötigte Seite
-
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
-
Die E-Mail weiterleiten und dann wie unter 3. verfahren
-
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:
-
E-Mail als temporäre Datei speichern
-
Word starten und temporäre Datei öffnen
-
Geöffnetes Dokument anpassen und gewünschte Seite(n) ausdrucken
-
Dokument und gegebenenfalls Word schließen
-
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
