Excel + Outlook

 

Home
Nach oben

Last Update 20.07.2004

Copyright  2003
Ramses (C)

 

Excel und Outlook

Zwei höchst ungleiche Programme,... und doch eignen sie sich hervorragend um die Möglichkeiten der Zusammenarbeit von VBA zu zeigen und zu testen.

Auch wenn auf den ersten Blick eine sinnvolle Zusammenarbeit nicht möglich ist, so ergeben sich doch sinnvolle Synergien.

 

  1. Termin aus Excel-Tabelle an Outlook senden

  2. Termin aus Outlook in EXCEL einlesen

  3. Excel Arbeitsmappe mit Outlook senden

  4. Excel Tabelle mit Outlook senden

  5. In Excel markierten/kopierten Arbeitsbereich mit Outlook senden

  6. Chart und Bereich aus EXCEL direkt senden

  7. Aufgabe mit Dateilink aus Excel Tabelle an Outlook senden

  8. Serienmail aus Excel mit Outlook senden

  9. Serienmail mit mehreren Anlagen aus Excel mit Outlook senden

  10. Bei überschreiten eines Wertes in einer Zelle eine Mail mit Outlook senden

  11. Mini-Mail: Arbeitsmappe mit Outlook Express senden

  12. Kontakte aus Outlook in Listbox einlesen

  13. Kontakte aus Outlook in die aktuelle Tabelle einlesen

  14. Chart aus EXCEL als HTML senden ( erst ab Excel XP )

  15. Importiere alle Mails aus dem Posteingang in die aktuelle Mappe

  16. Kalenderdaten aus Outlook einlesen

  17. Listbox in einer Userform füllen mit Outlook Kontakten


Einen Termin aus einer EXCEL Tabelle nach Outlook übertragen

Absteigend von A2 werden alle Zellen durchgegangen bis eine Zelle leer ist.
Zu diesen Daten werden 7 Tage addiert und in Outlook ein Erinnerungstermin mit Hinweis
auf die aktive Arbeitsmappe um 8:00 Uhr eingetragen.

Sub Excel_Control_Termin_nach_Outlook()
'E 2000
'Dim OutApp As Outlook.Application
Dim OutApp As Object, apptOutApp As Object
'Hier beginnen die Termine
Range("A2").Select
Do Until ActiveCell.Value = ""
    Set OutApp = CreateObject("Outlook.Application")
    Set apptOutApp = OutApp.CreateItem(1) 'olAppointmentItem)
    With apptOutApp
        'Datum und Uhrzeit
        'Hier werden zum aktuellen Tag 7 Tage addiert

        .Start = Format(Now()+7, "dd.mm.yyyy") & " 08:00"
        'Alternativ werden die Termine aus der Zelle genommen
        '.Start = Format(ActiveCell.Value, "dd.mm.yyyy") & " 08:00" 
     
        'Dauer. Angabe ist jeweils in ganzen Minuten zu setzen
        'Termininfo
        .Subject = "Rechnung: " & ActiveWorkbook.Name & " kontrollieren"
        'oder der Betreff steht in der Spalte rechts von den Terminen
        .Subject = ActiveCell.Offset(0,1)

        'Zusätzlicher Text
        .Body = ""
        'ort
        .Location = ""
        .Duration = "5"
        'Erinnerung
        .ReminderMinutesBeforeStart = 10
        'mit Sound :-)
        .ReminderPlaySound = True
        'Erinnerung wiederholen
        .ReminderSet = True
        'Termin speichern
        .Save
    End With
    'Nächste Zelle auswählen
    ActiveCell.Offset(1, 0).Select
    'Variablen leeren,... sonst "kotzt" Outlook irgendwann mal
    Set apptOutApp = Nothing
    Set OutApp = Nothing
Loop
MsgBox "Termine an Outlook übertragen!"
End Sub 

Zurück zum Start


Termin aus Outlook in EXCEL einlesen

 

Option Explicit

Sub Read_Control_Termin_to_Excel()
'by Ramses
'Datumsabfage über Inputbox
'Verweis auf Outlook 11 Library im VB-Editor muss gesetzt sein
'Early Binding ab Outlook 2003 nicht möglich
'weil die Rückgabewerte der ITEM-Indexes zufällig ist und von der
'Installation abhängt !!
Dim myR As Integer, i As Integer
Dim startDate As Date, endDate As Date, recDate As Date, extDate As Date
Dim myOlApp As Object, myOlSpace As Object, myOlFolder As Object
Dim myOlDateRange As Object, sAppoint As Object
Dim extRecurr As Object
Dim strRecurr As String
'Datum vorschlagen
Select Case Weekday(Now + 1, vbMonday)
    Case Is > 5
        recDate = Now + 3
    Case Else
        recDate = Now + 1
End Select
'Datum abfragen
startDate = Format(DateValue(InputBox("Welches Datum soll abgefragt werden ?" & Chr$(13) & _
    "Datum muss im Format ""01.01.2004"" eingeben werden", "Terminsuche", Format(recDate, "dd.mm.yyyy"))))
endDate = startDate
'Deklaration
Set myOlApp = CreateObject("Outlook.Application")
Set myOlSpace = myOlApp.GetNamespace("MAPI")
Set myOlFolder = myOlSpace.GetDefaultFolder(olFolderCalendar)
'Einträge ab Zeile 2
myR = 2
'Löscht alle zellen in der aktiven Tabelle
Cells.ClearContents
Cells.Interior.ColorIndex = xlNone
Cells(1, 1) = "Termin"
Cells(1, 2) = "Dauer"
Cells(1, 3) = "Ende"
Cells(1, 4) = "Ort"
Cells(1, 5) = "Betreff"
Cells(1, 6) = "Textinfo"
Set myOlDateRange = myOlFolder.Items.Restrict("[Start] >= '" & startDate & "' And [End] < & '" & endDate + 1 & "'")
For Each sAppoint In myOlDateRange
    With sAppoint
        'Termindaten eintragen
        Cells(myR, 1) = Format(.Start, "dd.mm.yyyy hh:mm")
        Cells(myR, 2) = Format((((1 / 24) / 60) * .Duration), "hh:mm")
        Set extRecurr = .GetRecurrencePattern
        'OlRecurrenceType sein:
        'olRecursDaily = 1
        'olRecursMonthly = 2
        'olRecursMonthNth = 3
        'olRecursWeekly = 4
        'olRecursYearly = 5
        'olRecursYearNth = 6
        Select Case extRecurr.RecurrenceType
            Case 1
                strRecurr = "Täglich für "
            Case 2
                strRecurr = "Monatlich für "
            Case 3
                strRecurr = "Monatlich jeden "
            Case 4
                strRecurr = "Wöchentlich für "
            Case 5
                strRecurr = "Jährlich für "
            Case 6
                strRecurr = "Jährlich jeden "
        End Select
        If Format(extRecurr.PatternEndDate, "dd.mm.yyyy") <> Format(DateValue("31.12.4500"), "dd.mm.yyyy") Then
            Cells(myR, 3) = Format(DateValue(extRecurr.PatternEndDate), "dd.mm.yyyy")
            Cells(myR, 3).Interior.ColorIndex = 3
            Cells(myR, 7) = strRecurr & DateValue(Format(extRecurr.PatternEndDate, "dd.mm.yyyy")) - startDate + 1 & " Tage"
        Else
            Cells(myR, 3) = Format(.Start + (((1 / 24) / 60) * .Duration), "hh:mm")
        End If
        Cells(myR, 4) = .Location
        Cells(myR, 5) = .Subject
        Cells(myR, 6) = .Body
        myR = myR + 1
    End With
Next
'Variablen leeren
Set myOlApp = Nothing
Set myOlSpace = Nothing
Set myOlFolder = Nothing
MsgBox "Alle Termine für den " & startDate & " eingelesen!"
End Sub
 

Der gleiche Code, nur dass hier das Start- und Enddatum in einer Zelle stehen


Sub Read_Control_Terminrange_to_Excel()
'by Ramses
'Zeitraumabfrage über Startdatum = A1 und Enddatum = B1
'Verweis auf Outlook 11 Library im VB-Editor muss gesetzt sein
'Early Binding ab Outlook 2003 nicht möglich
'weil die Rückgabewerte der ITEM-Indexes zufällig ist und von der
'Installation abhängt !!
Dim myR As Integer, i As Integer
Dim startDate As Date, endDate As Date, recDate As Date, extDate As Date
Dim myOlApp As Object, myOlSpace As Object, myOlFolder As Object
Dim myOlDateRange As Object, sAppoint As Object
Dim extRecurr As Object
Dim strRecurr As String
'Datum abfragen
startDate = Range("A1")
endDate = Range("B1")
'Deklaration
Set myOlApp = CreateObject("Outlook.Application")
Set myOlSpace = myOlApp.GetNamespace("MAPI")
Set myOlFolder = myOlSpace.GetDefaultFolder(olFolderCalendar)
'Einträge ab Zeile 3
myR = 3
'Löscht alle zellen in der aktiven Tabelle
Cells.ClearContents
Cells.Interior.ColorIndex = xlNone
'oder alle Zellen im Bereich bis Spalte G
'Range("A:G").ClearContents
'Range("A:G").Interior.ColorIndex = xlNone
Cells(1, 1) = startDate
Cells(1, 2) = endDate
Cells(myR - 1, 1) = "Termin"
Cells(myR - 1, 2) = "Dauer"
Cells(myR - 1, 3) = "Ende"
Cells(myR - 1, 4) = "Ort"
Cells(myR - 1, 5) = "Betreff"
Cells(myR - 1, 6) = "Textinfo"
'Datenbereich abfragen
Set myOlDateRange = myOlFolder.Items.Restrict("[Start] >= '" & startDate & "' And [End] < & '" & endDate + 1 & "'")
For Each sAppoint In myOlDateRange
    With sAppoint
        'Termindaten eintragen
        Cells(myR, 1) = Format(.Start, "dd.mm.yyyy hh:mm")
        Cells(myR, 2) = Format((((1 / 24) / 60) * .Duration), "hh:mm")
        Set extRecurr = .GetRecurrencePattern
        'OlRecurrenceType sein:
        'olRecursDaily = 1
        'olRecursMonthly = 2
        'olRecursMonthNth = 3
        'olRecursWeekly = 4
        'olRecursYearly = 5
        'olRecursYearNth = 6
        Select Case extRecurr.RecurrenceType
            Case 1
                strRecurr = "Täglich für "
            Case 2
                strRecurr = "Monatlich für "
            Case 3
                strRecurr = "Monatlich jeden "
            Case 4
                strRecurr = "Wöchentlich für "
            Case 5
                strRecurr = "Jährlich für "
            Case 6
                strRecurr = "Jährlich jeden "
        End Select
        If Format(extRecurr.PatternEndDate, "dd.mm.yyyy") <> Format(DateValue("31.12.4500"), "dd.mm.yyyy") Then
            Cells(myR, 3) = Format(DateValue(extRecurr.PatternEndDate), "dd.mm.yyyy")
            Cells(myR, 3).Interior.ColorIndex = 3
            Cells(myR, 7) = strRecurr & DateValue(Format(extRecurr.PatternEndDate, "dd.mm.yyyy")) - startDate + 1 & " Tage"
        Else
            Cells(myR, 3) = Format(.Start + (((1 / 24) / 60) * .Duration), "hh:mm")
        End If
        Cells(myR, 4) = .Location
        Cells(myR, 5) = .Subject
        Cells(myR, 6) = .Body
        myR = myR + 1
    End With
Next
'Variablen leeren
Set myOlApp = Nothing
Set myOlSpace = Nothing
Set myOlFolder = Nothing
MsgBox "Alle Termine  im Zeitraum vom " & startDate & " bis " & endDate & " eingelesen!"
End Sub


Zurück zum Start


 

Excel Arbeitsmappe mit Outlook versenden

Die aktive Arbeitsmappe wird direkt als Mail Attachment mit Outlook gesendet

Sub Excel_Workbook_via_Outlook_Senden()
Dim Nachricht As Object, OutApp As Object
Set OutApp = CreateObject("Outlook.Application")
Dim AWS As String
'Aktive Arbeitsmappe wird als Mail gesendet
AWS = ThisWorkbook.FullName
Set Nachricht = OutApp.CreateItem(0)
With Nachricht
        .To = "irgendwer@provider"
        .Subject = "Testmeldung von Excel2000 " & Date & Time
        .attachments.Add AWS
        .Body = "Das ist ein Test." & vbCrLf & "Bitte ignorieren."
        'Hier wird die Mail nochmals angezeigt
        .Display
        'Hier wird die Mail gleich in den Postausgang gelegt
        'Mail.Send
End With
'Outlook schliessen
OutApp.Quit
Set OutApp = Nothing
Set Nachricht = Nothing
End Sub


Bestimmten Bereich einer Arbeitsmappe mit Outlook senden

Mit diesem Code können Sie entweder einen vorher kopierten Bereich,
oder einen bestimmten Bereich in ihrer Arbeitsmappe, mit Outlook versenden
ohne die ganze Arbeitsmappe an den Empfänger zu senden.

Sub Excel_Range_via_Outlook_Senden()
    Dim OutApp As Object, Mail As Object, i
    Dim Nachricht
    'Verweis auf "Microsoft Forms 2.0 Object Library" aktivieren !!
    'sonst geht es nicht
    'Dataobject wird gebraucht wegen der Zwischenablage
    Dim ClpObj As DataObject
    For i = 1 To 10
        Set ClpObj = New DataObject
        Set OutApp = CreateObject("Outlook.Application")
        Set Nachricht = OutApp.CreateItem(0)
        'Excelbereich der versendet werden soll.
'Wenn kein Bereich versendet werden soll sondern
'der Bereich bereits kopiert wurde, können sie die
'nächsten beiden Zeilen auskommentieren

        Range("A1:A5").Select
        'Bereich wird in die Zwischenablage kopiert
        Selection.copy
        With Nachricht
            .Subject = "Betreffzeile Header"
            'Zwischenablage wird eingefügt
            ClpObj.GetFromClipboard
            .Body = ClpObj.GetText(1)
            .To = "irgendwer@irgendein-provider.de"
            'Hier wird die Mail angezeigt
            '.Display
            'Hier wird die Mail gleich in den Postausgang gelegt
            .Send
        End With
        Set OutApp = Nothing
        Set Nachricht = Nothing
        'Auf Outlook warten. Ist nicht schnell genug :-))
        Application.Wait (Now + TimeValue("0:00:05"))
    Next i
End Sub

 

Ab EXCEL XP


Sub Send_Chart_from_Excel()
'Es geht nur wenn ds Chart aktiviert und SELEKTIERT ist
'Ohne Select geht es nicht :-))

ActiveSheet.ChartObjects("Diagramm 2").Activate
ActiveChart.ChartArea.Select
'Das anzeigen der Envelope Commandbar ist unabdingbar

ActiveWorkbook.EnvelopeVisible = True
'Nun werden die Adressen vergeben

With 
ActiveSheet.MailEnvelope
      .Introduction = "Das ist der Einleitungstext." & vbCrLf & "mit einer zweiten Zeile"
      .Item.To = "irgendwer@irgendwo.de"
      .Item.Subject = "Das aktuelle Diagramm"
      .Item.Send
   End With
End Sub
 



Sub Send_OriginalRange_from_Excel()
'Getestet unter Office XP
'Ohne Select geht es nicht :-))
Range("A1:C9").Select
'Das anzeigen der Envelope Commandbar ist unabdingbar
ActiveWorkbook.EnvelopeVisible = True
'Nun werden die Adressen vergeben
With ActiveSheet.MailEnvelope
      .Introduction = "Das ist der Einleitungstext." & vbCrLf & "mit einer zweiten Zeile"
      .Item.To = "irgendwer@irgendwo.de"
      .Item.Subject = "Die aktuellen Daten"
      .Item.Send
   End With
End Sub

 

Zurück zum Start


Aufgabe mit Dateilink an Outlook senden

In diesem Beispiel erstellen Sie eine Aufgabe in Outlook und erstellen gleichzeitig
einen Hyperlink in der Aufgabe auf die aktuelle Arbeitsmappe.
Sie müssen dann, wenn Sie die Aufgabe öffnen, nur noch auf den Link klicken
um die zu kontrollierende Datei anzusehen.

Sub Excel_an_Outlook_Aufgabe()
On Error GoTo ErrorAufgabe
Dim MyError As Integer
Dim Faellig As Date
Dim Link As String
Dim myolApp As Object, myitem As Object
'Eigene Fehleroutine/Nummer eröffnen
MyError = 1
'Fälligkeit ist übermorgen
Faellig = Date + 1
MyError = 2
Set myolApp = CreateObject("Outlook.Application")
Set myitem = myolApp.CreateItem(3)
    myitem.Subject = "Datei ERFASSEN !" ' Text der Aufgabe
    myitem.DueDate = Faellig
    myitem.ReminderTime = Faellig
    'Ein Link kann nur erstellt werden, wenn die Pfadangabe eine
    'Angabe mit einem ShareName ist
    myitem.Body = "\\Computername\Freigabename\dateiname.xls"
    myitem.Save
Set myitem = Nothing
ErrorExit:
Exit Sub
 
ErrorAufgabe:
Select Case MyError
    Case 1
        MsgBox "Die Datei wurde noch nicht gespeichert"
    Case 2
        MsgBox "Outlook kann nicht gestartet werden" & Chr$(13) &_
 "Aufgabe wurde nicht erstellt !"
End Select
Resume ErrorExit
End Sub

Zurück zum Start


Serienmail mit E-Mail Adressen aus einer Tabelle mit Outlook senden

In diesem Beispiel stehen in der aktiven Tabelle in A1 bis A10 E-Mail-Adressen ( deshalb die Schleife von 1 bis 10 )

Sub Excel_Serienmail_via_Outlook_Senden()
    Dim OutApp As Object, Mail As Object
    Dim i As Integer
    Dim Nachricht
    For i = 1 To 10
    'Variablen müssen bei jeder Schleife neu initalisiert werden
        Set OutApp = CreateObject("Outlook.Application")
        Set Nachricht = OutApp.CreateItem(0)
        With Nachricht
            .To = Cells(i, 1)'Adresse
            .Subject = Cells(i, 2) 'Betreffzeile
            .Body = Cells(i, 3) 'Sendetext
            'Hier wird die Mail gleich in den Postausgang gelegt
            'und die Sicherheitsabfrage muss jedesmall bestätigt werden
            '.Send
            'Hier wird die Mail "angezeigt"
            'aber gleich versendet,... OHNE Sicherheitsabrage
            .Display
            SendKeys "%s",True
        End With
        'Variablen zurücksetzen sonst geht es nicht
        Set OutApp = Nothing 'CreateObject("Outlook.Application")
        Set Nachricht = Nothing 'OutApp.CreateItem(0)
        Application.Wait (Now + TimeValue("0:00:05"))
    Next i
End Sub

Zurück zum Start


Serienmail mit verschiedenen Attachments aus einer Tabelle mit Outlook senden

Ein ähnliches Beispiel wie oben mit dem Unterschied, dass die Empfänger in den Zellen stehen und
die jeweiligen Attachments ( in diesem Fall 10 ) stehen inclusive Pfad in den Zellen F2:F10
die jeweiligen Attachments mit den Pfadangaben in den Nachbarzellen.

In diesem Beispiel wird das FileSystemObject zu Hilfe genommen um die Ordner bzw. die Dateien auf Existenz zu testen.
Das ganze könnte auch etwas einfacher gelöst werden, aber so kann das FS-Object wunderbar gezeigt werden.

Sub Excel_Serienmail_mit_mehreren_Anlagen_via_Outlook_Senden()
    'Variablendefinition
    Dim fs As Object, F As Object
    Dim OutApp As Object, Mail As Object
    Dim i As Integer, y As Integer, Msg As Integer
    Dim Nachricht As Variant
    Dim AWS As String
    Dim AnzEmpfänger As Integer
    'Variablen füllen
    'Filesystemobjekt erstellen
    Set fs = CreateObject("Scripting.FileSystemObject")
    'Hier die Anzahl Empfänger definieren
    'Kann auch ein Range auf der Tabelle sein
    AnzEmpfänger = 10
    '1. Fehlerprüfung
    'Prüfen ob alle Inhalte vorhanden sind
    'Wenn nicht wird das Makro abgebrochen
    'In Spalte A steht der Name
    'In Spalte B steht der Betreff
    'In Spalte C steht der Text
    For i = 1 To AnzEmpfänger
        If Cells(i, 1) = "" Or Cells(i, 2) = "" Or Cells(i, 3) = "" Then
            Msg = MsgBox("Unvollständige Angaben beim Empfänger in Zeile "_
		 & i, vbCritical + vbOKOnly, "Abbruch")
            Exit Sub
        End If
    Next i
    '2. Fehlerprüfung
    'Mit dem FilesystemObjekt wird zuerst die Existenz
    'der Dateien geprüft. Wenn eine nicht existiert
    'wird das Makro abgebrochen
    'Die Links auf deine Anlagen liegen im
    'Bereich F2 : F10
    For y = 2 To 10
        'Wenn eine Zelle leer ist, wird aus der Schleife ausgestiegen
        'ohne weitere Fehlerprüfung
        If Cells(y, 6) = "" Then Exit For
        If fs.fileexists(Cells(y, 6)) = False Then
            Msg = MsgBox("Die Datei: " & Cells(y, 6) & " in F" & y & " exitstiert nicht !"_
		 & vbCrLf & "Der Sendevorgang an; " & Cells(i, 1) & " wird abgebrochen!",_
		  vbCritical + vbOKOnly, "Dateifehler")
            Exit Sub
        End If
    Next y
    'Sendevorgang einleiten
    For i = 1 To AnzEmpfänger
        Set OutApp = CreateObject("Outlook.Application")
        Set Nachricht = OutApp.CreateItem(0)
        With Nachricht
            .To = Cells(i, 1) 'irgendwer@irgendein-provider.de
            .Subject = Cells(i, 2) 'Betreffzeile
            .Body = Cells(i, 3) 'Sendetext"
            For y = 2 To 10
                AWS = Cells(y, 6)
                'Wenn die Zelle / Variable leer ist
                'wird diese Schleife für die Attachments abgebrochen
                If AWS = "" Then Exit For
                .attachments.Add AWS
            Next y
            'Hier wird die Mail zuerst angezeigt
            .Display
            'Hier wird die Mail gleich in den Postausgang gelegt
            '.Send
        End With
        'Variablen zurücksetzen
        Set OutApp = Nothing
        Set Nachricht = Nothing
        'Warten auf Outlook :-))
        Application.Wait (Now + TimeValue("0:00:05"))
    Next i
End Sub
 

Zurück zum Start


 

Bei überschreiten eines Wertes eine Mail mit Outlook senden

Diese Funktion ist in EXCEL und von MS natürlich nicht vorgesehen.
Es geht trotzdem,... wenn auch über einen kleinen Umweg :-).

Aus einer Formel können sie kein Makro direkt starten oder aufrufen,... aber das Ergebnis einer Funktion kann ein Makro ausführen. Eine benutzerdefinierte Funktion können Sie jedoch selbst erstellen,.... et voilà:

Aufgabe:
Sie haben eine Tabelle die in regelmässigen Abständen von aussen ( Internet oder andere Tabellen ) mit neuen Werten versorgt wird. Nun möchten Sie, z.B. am Wochenende oder wenn sich nicht im Büro sind, über E-Mail beim überschreiten eines Wertes darüber informiert werden.
In A1 steht der externe Wert, oder die Formel welche den Wert liefert.

Nur bis Office 2000 ohne Sicherheitsupdate ServicePack2

Fügen Sie in B1 diese Formel ein...
 

=WENN(A1>150;Active_Mail();"")

...und diese beiden Makros in ein Modul Ihrer Arbeitsmappe

Function Active_Mail()
'Über eine Function ein Mail auslösen
Call Active_Mail_Senden
End Function
 
Sub Active_Mail_Senden()
ActiveWorkbook.SendMail "dein.name@dein.provider", "Wert überschritten"
End Sub

Wenn der Wert in A1 150 übersteigt wird das Makro über die Funktion aufgerufen, und die Mail versandt.
Coole Variante,.... oder ?

 

Ab Office 2000 für alle Outlook-Versionen

Verschiedene EXCEL Interne Funktionen werden ab dem Sicherheitsupdate nicht mehr unterstützt, daher ist man nun gezwungen einen Umweg zu machen.

Anstelle der Formel verwende ich hier das CHANGE Ereignis bzw. das CALCULATE Ereignis der Mappe/Tabelle.
Das CHANGE Ereignis funktioniert bei direkter Eingabe, aber nicht bei DDE-Daten Update (z.B. verknüpfte Zellen)
Das CALCULATE Ereignis funktioniert NUR, wenn auch tatsächlich das Sheet neu berechnet wird.
Bei direkter Eingabe in einer Zelle OHNE Formeln in der Tabelle wird dieses nicht aktualisiert.

Sie müssen daher entscheiden, ob Sie bei Bedarf 2 Mails erhalten wollen, oder ob eine der beiden Varianten für Sie ausreichend ist

Dies gehört in das Klassenmodul der Tabelle, in der Sie einen Wert überwachen wollen

 

Option Explicit

Private Sub Worksheet_Calculate()
If Range("A1") > 25 Then Send_Excel_Message
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Range("A1") > 25 Then Send_Excel_Message
End Sub
Und dieses Makro gehört in ein Modul ihrer Mappe


Sub Send_Excel_Message()
Dim MyMessage As Object, MyOutApp As Object
'InitializeOutlook = True
Set MyOutApp = CreateObject("Outlook.Application")
'Nachrichtenobject erstellen
Set MyMessage = MyOutApp.CreateItem(0)
With MyMessage
     .To = "irgendwer@Irgenwo.de"
     .Subject = "Testmeldung von Excel2000 " & Date & Time
     'Hier wird eine normale Text Mail erstellt
     '.body = "Das ist ein Test" & vbCrLf & "Bitte ignorieren"
     'Hier wird die HTML Mail erstellt
     .HTMLBody = "Das ist ein Test." & vbCrLf & "Bitte ignorieren."
     'Hier wird die Mail nochmals angezeigt
     .Display
     'Nicht ganz offiziell :-)
     .Save
     SendKeys "%S"
End With
MyOutApp.Quit
Set MyOutApp = Nothing
Set MyMessage = Nothing
End Sub

Mit ".Display" wird die Mail angezeigt, mit ".Save" gespeichert (da wir Sie geändert haben), ... und mit " SendKeys "%S" " OHNE Sicherheitsabfrage mit Outlook versandt :-)

Die SendKeys Variante ist zwar nicht die eleganteste, lässt sich dafür aber ohne Installation von Zusatztools verwenden, um die Sicherheitsabfrage zu umgehen.

Zurück zum Start



Wenn es ohne Outlook gehen soll

Nicht immer hat man das mächtige Outlook installiert, ... Mail senden kann man aber auch:

Sub Mini_Mail()
Shell "C:\Programme\Outlook Express\msimn.exe"
ActiveWorkbook.SendMail Recipients:="irgendwer@irgendwo.com", Subject:="Test"
End Sub

Allerdings werden die Funktionen und Möglichkeiten von Outlook natürlich nicht unterstützt.

Zurück zum Start



Einlesen von Outlook Kontakten in eine Listbox

Option Explicit

Sub ListBox_Fill_With_Outlook_Contacts()
'modified by Ramses
'Voraussetzung:
'1 Userform mit einer Listbox die den Namen "Listbox1" hat
'ansonsten bitte entsprechend anpassen
'--------------------
'Variablen Deklaration
Dim myOutlook  As Object
Dim conId     As Integer
Dim conFolder  As Object
Dim conItem    As Object
Dim Qe As Integer
Dim ErrMsg As String
'Bildschirmaktualisierung ausschalten
'Application.DisplayAlerts = False
'... und Statusbar-Info ausgeben
Application.StatusBar = " . . .  die Adressen werden aus Outlook eingelesen"
'Object Deklaration
Set myOutlook = CreateObject("Outlook.Application")
Set conFolder = myOutlook.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
'Zuweisen der Anzahl Spalten in der Listbox
Me.ListBox1.ColumnCount = 7
'Zuweisen der Spaltenbreite in Pt
'1 cm ~ 28,3 Pt
Me.ListBox1.ColumnWidths = "70; 70; 28; 70; 28; 70; 70"
'Einlesen der Daten
For conId = 1 To conFolder.Items.Count
    'Zuweisen des Object für jeden Contact
    Set conItem = conFolder.Items(conId)
    'Einlesen des Contacts beginnen
    With conItem
        'Neuen Eintrag in Listbox einfügen
        Me.ListBox1.AddItem " "
        'iIndx - 1 um auf das vorher erzeugte Item zuzugreifen
        On Error GoTo conError
        Me.ListBox1.List(conId - 1, 0) = .FirstName & " " & .LastName
        'Statusbar Info
        Application.StatusBar = "Datensatz " & conId & " von " & conFolder.Items.Count & " wird gelesen: " & .FirstName
        If .BusinessAddressPostOfficeBox = "" Then
            UserForm1.ListBox1.List(conId - 1, 1) = .BusinessAddressStreet
        Else
            UserForm1.ListBox1.List(conId - 1, 1) = .BusinessAddressPostOfficeBox
        End If
        Me.ListBox1.List(conId - 1, 2) = .BusinessAddressPostalCode
        Me.ListBox1.List(conId - 1, 3) = .BusinessAddressCity
        Me.ListBox1.List(conId - 1, 4) = .CustomerID
        Me.ListBox1.List(conId - 1, 5) = .AssistantName
        Me.ListBox1.List(conId - 1, 6) = .MiddleName
errorStepin:
    End With
Next conId

ErrorExit:
'Object Variablen leeren
Set conItem = Nothing
Set conFolder = Nothing
Set myOutlook = Nothing
'Bildschirm einschalten
Application.DisplayAlerts = True
'Statusbar zurücksetzen
Application.StatusBar = False
Exit Sub

conError:
Select Case Err
    Case 438
        Set conItem = conFolder.Items(conId)
        ErrMsg = "Datensatz " & conId & " ist korrupt, oder untestützt die Abfrage nicht."
        ErrMsg = ErrMsg & vbCrLf & "Datensatzkennung:"
        ErrMsg = ErrMsg & vbCrLf & "Erstelldatum: " & conItem.CreationTime
        ErrMsg = ErrMsg & vbCrLf & "ObjectID" & conItem.EntryID
        ErrMsg = ErrMsg & vbCrLf
        ErrMsg = ErrMsg & vbCrLf & "Löschen ? "
        Qe = MsgBox(ErrMsg, vbYesNo + vbCritical + vbDefaultButton2, "Datenfehler")
        If Qe = vbYes Then
            conItem.Delete
            MsgBox ("Datensatz " & conId & " wurde gelöscht")
            Resume errorStepin
        Else
            MsgBox "Datenimport wegen Datenfehler bei Datensatz " & conId & " abgebrochen"
            Resume ErrorExit
        End If
    Case Else
        MsgBox Err & ": " & Err.Description
        Resume ErrorExit
End Select
End Sub

 

Zurück zum Start



 

Einlesen von Kontakten in das aktuelle Tabellenblatt

Sub Read_Contact_from_Outlook()
'by Ramses
'Liest alle Kontakte aus Outlook in das aktuelle Tabellenblatt
Dim myOlk As Object
Dim myOlkContact As Object
Set myOlk = CreateObject("outlook.application")
Set myOlkContact = myOlk.CreateItem(olContactItem)
Range("A2").Select
For Each myOlkContact In myOlk.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts).Items
    With myOlkContact
        ActiveCell.Value = .LastName
        ActiveCell.Offset(0, 1).Value = .FirstName
        ActiveCell.Offset(0, 2).Value = .BusinessAddressStreet
        ActiveCell.Offset(0, 4).Value = .BusinessAddressCity
        ActiveCell.Offset(0, 3).Value = .BusinessAddressPostalCode
        ActiveCell.Offset(0, 5).Value = .BusinessAddressCountry
        ActiveCell.Offset(0, 6).Value = .BusinessAddressState
        ActiveCell.Offset(0, 7).Value = .Email1Address
        'Alle verfügbaren Eigenschaften eines Kontaktes
        '---Outlook 2003
        '.AutoResolvedWinner
        '.HasPicture
        '.AddPicture
        '.RemovePicture
        '---Outlook 2000 / 2002
        '.Actions
        '.Anniversary
        '.AssistantName
        '.AssistantTelephoneNumber
        '.Birthday
        '.Business2TelephoneNumber
        '.BusinessAddress
        '.BusinessAddressCity
        '.BusinessAddressCountry
        '.BusinessAddressPostalCode
        '.BusinessAddressPostOfficeBox
        '.BusinessAddressState
        '.BusinessAddressStreet
        '.BusinessFaxNumber
        '.BusinessHomePage
        '.BusinessTelephoneNumber
        '.CallbackTelephoneNumber
        '.CarTelephoneNumber
        '.Categories
        '.Children
        '.Companies
        '.CompanyAndFullName
        '.CompanyMainTelephoneNumber
        '.CompanyName
        '.CreationTime
        '.CustomerID
        '.Department
        '.DownloadState
        '.Email1Address
        '.Email1AddressType
        '.Email1DisplayName
        '.Email1EntryID
        '.Email2Address
        '.Email2AddressType
        '.Email2DisplayName
        '.Email2EntryID
        '.Email3Address
        '.Email3AddressType
        '.Email3DisplayName
        '.Email3EntryID
        '.EntryID
        '.FirstName
        '.FTPSite
        '.FullName
        '.FullNameAndCompany
        '.Gender    'Geschlecht
        '.GovernmentIDNumber    'Passnummer
        '.Hobby
        '.Home2TelephoneNumber
        '.HomeAddress
        '.HomeAddressCity
        '.HomeAddressCountry
        '.HomeAddressPostalCode
        '.HomeAddressPostOfficeBox
        '.HomeAddressState
        '.HomeAddressStreet
        '.HomeFaxNumber
        '.HomeTelephoneNumber
        '.IMAddress    'Microsoft Instant Messenger Adresse
        '.Importance    'Wichtigkeitsstufe des Kontakt
        '.Initials
        '.InternetFreeBusyAddress    'Frei/Gebucht-Informationen
        '.ISDNNumber
        '.JobTitle
        '.Language
        '-----Wird automatisch generiert
        '.LastFirstAndSuffix    'Vor und Zuname und Suffix zusammen
        '.LastFirstNoSpace    'Vor und Zuname ohne Leerzeichen
        '.LastFirstNoSpaceAndSuffix
        '.LastFirstNoSpaceCompany
        '.LastFirstSpaceOnly
        '.LastFirstSpaceOnlyCompany
        '.LastNameAndFirstName
        '.LastModificationTime
        '---
        '.LastName
        '.MailingAddress
        '.MailingAddressCity
        '.MailingAddressCountry
        '.MailingAddressPostalCode
        '.MailingAddressPostOfficeBox
        '.MailingAddressState
        '.MailingAddressStreet
        '.ManagerName
        '.MiddleName
        '.MobileTelephoneNumber
        '.NetMeetingAlias
        '.NetMeetingServer
        '.NickName
        '.NoAging
        '.OfficeLocation
        '.OrganizationalIDNumber
        '.OtherAddress
        '.OtherAddressCity
        '.OtherAddressCountry
        '.OtherAddressPostalCode
        '.OtherAddressPostOfficeBox
        '.OtherAddressState
        '.OtherAddressStreet
        '.OtherFaxNumber
        '.OtherTelephoneNumber
        '.PagerNumber
        '.PersonalHomePage
        '.PrimaryTelephoneNumber
        '.Profession
        '.RadioTelephoneNumber
        '.ReferredBy    'Kontakt empfohlen von
        '.Saved
        '.SelectedMailingAddress
        '.Sensitivity    'Vertraulichkeitsstatus des Elements
        '.Size    'Grösse in Byte der Kontaktdaten
        '.Spouse    'Partnername des Kontakt
        '.Suffix
        '.TelexNumber
        '.Title
        '.Delete
        '.Display
        '.ForwardAsVcard
        '.Move
        '.PrintOut
        '.Save
        '.SaveAs
        '.ShowCategoriesDialog
        '.AttachmentAdd
    End With
    ActiveCell.Offset(1, 0).Select
Next
Set myOlkContact = Nothing
Set myOlk = Nothing
End Sub

Zurück zum Start



EXCEL Chart mit Outlook als HTML senden

Sub Send_Chart_from_Excel()
'by Ramses
'Erst ab EXCEL XP
'Es geht nur wenn ds Chart aktiviert und SELEKTIERT ist
'Ohne Select geht es nicht :-))
ActiveSheet.ChartObjects("Diagramm 2").Activate
ActiveChart.ChartArea.Select
'Das anzeigen der Envelope Commandbar ist unabdingbar
ActiveWorkbook.EnvelopeVisible = True
'Nun werden die Adressen vergeben
With ActiveSheet.MailEnvelope
      .Introduction = "Das ist der Einleitungstext." & vbCrLf & "mit einer zweiten Zeile"
      .Item.To = "irgendwer@irgendwo.de"
      .Item.Subject = "Das aktuelle Diagramm"
      .Item.Send
   End With
End Sub



Zurück zum Start



Importiert alle Mails aus dem Posteingang in die aktuelle Tabelle als Text in Zeilen

  Sub Get_EMAIL_from_Outlook_in_workbook_from_Inbox_Folder_E2000()
'(C) Ramses
'Erstellt für jede Mail im Posteingang eine Tabelle und schreibt dort
'den Text der Mail hinein
Dim objOutlook As Object
Dim objnSpace As Object
Dim objFolder As Object
Dim objMsg As Object
Dim intCounter As Integer, intCount As Integer, iRow As Integer
Dim sTxt As String
Application.ScreenUpdating = False
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
Set objFolder = objnSpace.folders("Persönlicher Ordner").folders("Posteingang")
intCount = objFolder.Items.count
If intCount > 0 Then
For intCounter = 1 To intCount
    Set objMsg = objFolder.Items(intCounter)
    Worksheets.Add after:=Worksheets(Worksheets.count)
    objMsg.SaveAs ThisWorkbook.path & "\temp.txt"
    Close
    iRow = 0
    Open ThisWorkbook.path & "\temp.txt" For Input As #1
    Do Until EOF(1)
        iRow = iRow + 1
        Line Input #1, sTxt
        Cells(iRow, 1).Value = "'" & sTxt
    Loop
    Close
Next intCounter
Kill ThisWorkbook.path & "\temp.txt"
End If
Set objnSpace = Nothing
Set objFolder = Nothing
Set objMsg = Nothing
Set objOutlook = Nothing
End Sub
 


Sub Get_EMAIL_from_Outlook_in_workbook_from_Inbox_Folder_EXCEL_XP()
'(C) Ramses
'Erstellt für jede Mail im Posteingang eine Tabelle und schreibt dort
'den Text der Mail hinein
Dim objOutlook As Object
Dim objnSpace As Object
Dim objFolder As Object
Dim objMsg As Object
Dim intCounter As Integer, intCount As Integer, iRow As Integer
Dim sTxt As String
Application.ScreenUpdating = False
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
Set objFolder = objnSpace.folders(1).folders(2)
intCount = objFolder.Items.count
If intCount > 0 Then
    For intCounter = 1 To intCount
        Set objMsg = objFolder.Items(intCounter)
        Worksheets.Add after:=Worksheets(Worksheets.count)
        'Temporäre Datei anlegen zum einlesen
        objMsg.SaveAs ThisWorkbook.path & "\temp.txt"
        Close
        iRow = 0
        Open ThisWorkbook.path & "\temp.txt" For Input As #1
        'Mail einlesen
        Do Until EOF(1)
            iRow = iRow + 1
            Line Input #1, sTxt
            Cells(iRow, 1).Value = "'" & sTxt
        Loop
        Close
    Next intCounter
    Kill ThisWorkbook.path & "\temp.txt"
End If
Set objnSpace = Nothing
Set objFolder = Nothing
Set objMsg = Nothing
Set objOutlook = Nothing
End Sub

 



Zurück zum Start



 

Alle Kalenderdaten aus Outlook in die aktuelle Mappe einlesen

Beide Codeteile gehören zusammen

Option Explicit

Sub Kalenderdaten_auf_Terminbereich_einlesen()
'(C) Ramses
'Zunächst Verweis auf OL-Bibliothek erstellen
'Early Binding ab Outlook 2003 nicht möglich
'weil die Rückgabewerte der ITEM-Indexes zufällig ist und von der
'Installation abhängt !!
'-------------
'Version Office 2000 (nicht getestet sollte aber tun)
'Dim olApp As Outlook.Application
'Dim Termin As Outlook.AppointmentItem
'Dim myTerminPatt As Outlook.RecurrencePattern
'-------------
'Set olApp = New outlook.Application
'Set Termin = olApp.CreateItem(olAppointmentItem)
'-------------
'Version XP
Dim olApp As Object
Dim Termin As Object
Set olApp = CreateObject("Outlook.Application")
'Allgemein gültig
Dim As Long, j As Long, myErr As Integer
Dim startInput As String, startDate As Date
Dim endInput As String, endDate As Date
Dim myTerminPatt As Object
On Error GoTo myErrorhandler
'Erst mal alles löschen
Cells.ClearContents
Cells.Interior.ColorIndex = xlNone
'Startdatum abfragen
startInput = InputBox("Bitte Datum eingeben im Format ""01.01.2004""", "Datum für Terminsuche", Format(Now, "dd.mm.yyyy"))
myErr = 1
If startInput = "" Then
    MsgBox "Abbruch des Makros durch Benutzer"
    Exit Sub
ElseIf Not IsDate(DateValue(startInput)) Then
    MsgBox "Falsches Datum eingegeben"
    Exit Sub
End If
myErr = 2
endInput = InputBox("Bitte Datum eingeben im Format ""01.01.2004""", "Datum für Terminsuche", Format(DateValue(startInput) + 7, "dd.mm.yyyy"))
If endInput = "" Then
    MsgBox "Abbruch des Makros durch Benutzer"
    Exit Sub
ElseIf Not IsDate(DateValue(endInput)) Then
    MsgBox "Falsches Datum eingegeben"
    Exit Sub
End If
myErr = 0
'Variable definitiv zuweisen
startDate = DateValue(startInput)
endDate = DateValue(endInput)
'Variable fü¨r Termin neu setzen
'Set Termin = olApp.CreateItem(Appointment)
Cells(1, 1) = "Termine vom " & Format(startDate, "dd.mm.yyyy") & " bis " & Format(endDate, "dd.mm.yyyy")
i = 3
Application.ScreenUpdating = False
Cells(i, 1) = "Termin Betreff"
Cells(i, 2) = "Inhalt/Body"
Cells(i, 3) = "Start"
Cells(i, 4) = "Ende"
Cells(i, 5) = "Erinnerung Minuten"
Cells(i, 6) = "Anzeigen als"
Cells(i, 7) = "Kategorien"
Cells(i, 8) = "Erstellt am"
Range(Cells(i, 1), Cells(i, 8)).Select
Selection.Interior.ColorIndex = 15

'Durchlaufe alle Termine des aktuellen Standardkalenders
i = i + 1
For Each Termin In olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar).Items
    Set myTerminPatt = Termin.GetRecurrencePattern
    If Format(Termin.Start, "dd.mm.yyyy") >= startDate And Format(Termin.End, "dd.mm.yyyy") <= endDate Then
        If Not Termin.AllDayEvent Then Trag_ein Termin, i, False
    End If
    If myTerminPatt.RecurrenceType = olRecursDaily Then
        If Format(myTerminPatt.PatternEndDate, "dd.mm.yyyy") >= startDate Then
                Trag_ein_Recurr Termin, i, False, startDate, endDate
        End If
    End If
Next
Range("C1").Select
Range("A1:H" & Range("A1").CurrentRegion.Rows.Count).Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlGuess

'Jetzt die Ereignisse
i = i + 1
j = i
Cells(i, 1) = "Ganzer Tag Betreff"
Cells(i, 2) = "Ereignis am"
Cells(i, 3) = "Erinnerung Minuten"
Cells(i, 4) = "Anzeigen als"
Cells(i, 5) = "Kategorien"
Cells(i, 6) = "Erstellt am"
Range(Cells(i, 1), Cells(i, 6)).Select
Selection.Interior.ColorIndex = 15
i = i + 1
For Each Termin In olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar).Items
    Debug.Print Termin.Start
    If DateSerial(Year(startDate), Month(Termin.Start), Day(Termin.Start)) >= startDate And DateSerial(Year(startDate), Month(Termin.Start), Day(Termin.Start)) <= endDate Then
        If Termin.AllDayEvent And Not Termin.IsRecurring Then Trag_ein Termin, i, True
    End If
Next
Range("C" & j).Select
Range("A1:F" & Range("A" & j).CurrentRegion.Rows.Count).Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlGuess
'und noch die jährlichen Ereignisse
i = i + 2
j = i
Cells(i, 1) = "Betreff ""Jährliches Ereignis"""
Cells(i, 2) = "jährliches Ereignis am"
Cells(i, 3) = "Erinnerung Minuten"
Cells(i, 4) = "Anzeigen als"
Cells(i, 5) = "Kategorien"
Cells(i, 6) = "Erstellt am"
Range(Cells(i, 1), Cells(i, 6)).Select
Selection.Interior.ColorIndex = 15
i = i + 1
For Each Termin In olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar).Items
    If DateSerial(Year(startDate), Month(Termin.Start), Day(Termin.Start)) >= startDate And DateSerial(Year(startDate), Month(Termin.Start), Day(Termin.Start)) <= endDate Then
        If Termin.AllDayEvent And Termin.IsRecurring Then Trag_ein Termin, i, True
    End If
Next
Range("C" & j).Select
Range("A1:F" & Range("A" & j).CurrentRegion.Rows.Count).Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlGuess
'Variablen leeren
Set Termin = Nothing
Set olApp = Nothing
Columns("A:H").Select
Columns("A:H").EntireColumn.AutoFit
Range("A1").Select
Cells.RowHeight = "12.75"

'Ausstieg
ErrorExit:
Application.ScreenUpdating = True
If myErr = 0 And Err.Number = 0 Then
    MsgBox "Kalenderdaten eingelesen"
End If
Exit Sub

myErrorhandler:
    Select Case myErr
        Case 1
            MsgBox "Ungültiges Startdatum"
            Resume ErrorExit
        Case 2
            MsgBox "Ungültiges Enddatum"
            Resume ErrorExit
    End Select
    MsgBox Err.Number & " " & Err.Description
    Resume ErrorExit
End Sub


Sub Trag_ein(Termin, i As Long, Ereignis As Boolean)
Dim Anzeigen_als As String
Dim Erinnerung As String
Select Case Termin.BusyStatus
    Case olFree
        Anzeigen_als = "Frei"
    Case olTentative
        Anzeigen_als = "Unter Vorbehalt"
    Case olBusy
        Anzeigen_als = "Gebucht"
    Case olOutOfOffice
        Anzeigen_als = "Abwesend"
End Select
Cells(i, 1) = Termin.Subject
If Not Ereignis Then
    Cells(i, 2) = Termin.Body
    Cells(i, 3) = Termin.Start
    Cells(i, 3).NumberFormat = "dd/mm/yyyy hh:mm"
    Cells(i, 4) = Termin.End
    Cells(i, 4).NumberFormat = "dd/mm/yyyy hh:mm"
    Cells(i, 5) = Termin.ReminderMinutesBeforeStart
    Cells(i, 6) = Anzeigen_als
    Cells(i, 7) = Termin.Categories
    Cells(i, 8) = Termin.CreationTime
Else
    Cells(i, 2) = Termin.Start
    Cells(i, 2).NumberFormat = "dd/mm/yyyy hh:mm"
    If Termin.ReminderMinutesBeforeStart <= 60 Then
        Erinnerung = Termin.ReminderMinutesBeforeStart & " Minuten"
    ElseIf Termin.ReminderMinutesBeforeStart / 60 < 24 Then
        Erinnerung = Termin.ReminderMinutesBeforeStart / 60 & " Stunden"
    Else
        Erinnerung = Termin.ReminderMinutesBeforeStart / 60 / 24 & " Tage"
    End If
    Cells(i, 3) = Erinnerung
    Cells(i, 3).NumberFormat = "General"
    Cells(i, 4) = Anzeigen_als
    Cells(i, 5) = Termin.Categories
    Cells(i, 6) = Termin.CreationTime
End If
i = i + 1
End Sub

Sub Trag_ein_Recurr(Termin, i As Long, Ereignis As Boolean, startDate As Date, endDate As Date)
Dim Anzeigen_als As String
Dim Erinnerung As String
Dim As Integer
Dim myReccTermin As Object
Select Case Termin.BusyStatus
    Case olFree
        Anzeigen_als = "Frei"
    Case olTentative
        Anzeigen_als = "Unter Vorbehalt"
    Case olBusy
        Anzeigen_als = "Gebucht"
    Case olOutOfOffice
        Anzeigen_als = "Abwesend"
End Select
Set myReccTermin = Termin.GetRecurrencePattern
If startDate = endDate Then
    Cells(i, 1) = Termin.Subject
    Cells(i, 3) = startDate + (i - 1)
    Cells(i, 3).NumberFormat = "dd/mm/yyyy hh:mm"
    Cells(i, 4) = startDate + (i - 1)
    Cells(i, 4).Interior.ColorIndex = 3
    Cells(i, 4).NumberFormat = "dd/mm/yyyy hh:mm"
    Cells(i, 5) = Termin.ReminderMinutesBeforeStart
    Cells(i, 6) = Anzeigen_als
    Cells(i, 7) = Termin.Categories
    Cells(i, 8) = Termin.CreationTime
    i = i + 1
    Set myReccTermin = Nothing
    Exit Sub
End If
If myReccTermin.PatternEndDate < endDate Then
    Debug.Print myReccTermin.PatternEndDate
    If myReccTermin.PatternStartDate > startDate Then
        For n = 1 To endDate - myReccTermin.PatternEndDate '(myReccTermin.PatternStartDate - startDate)
            Cells(i, 1) = Termin.Subject
            Cells(i, 3) = myReccTermin.PatternStartDate + n
            Cells(i, 3).Interior.ColorIndex = 3
            Cells(i, 3).NumberFormat = "dd/mm/yyyy hh:mm"
            Cells(i, 4) = myReccTermin.PatternStartDate + n
            Cells(i, 4).Interior.ColorIndex = 3
            Cells(i, 4).NumberFormat = "dd/mm/yyyy hh:mm"
            Cells(i, 5) = Termin.ReminderMinutesBeforeStart
            Cells(i, 6) = Anzeigen_als
            Select Case myReccTermin.RecurrenceType
                Case 1
                    Cells(i, 7) = "Täglich"
                Case 2, 3
                    Cells(i, 7) = "Monatlich"
                Case 4
                    Cells(i, 7) = "Wöchentlich"
                Case 5, 6
                    Cells(i, 7) = "Jährlich"
                Case Else
                    Cells(i, 7) = "Serie"
            End Select
            Cells(i, 8) = Termin.CreationTime
            i = i + 1
        Next n
    Else
        For n = 1 To myReccTermin.PatternEndDate - startDate
            Cells(i, 1) = Termin.Subject
            Cells(i, 3) = startDate + n
            Cells(i, 3).NumberFormat = "dd/mm/yyyy hh:mm"
            Cells(i, 4) = startDate + n
            Cells(i, 4).Interior.ColorIndex = 3
            Cells(i, 4).NumberFormat = "dd/mm/yyyy hh:mm"
            Cells(i, 5) = Termin.ReminderMinutesBeforeStart
            Cells(i, 6) = Anzeigen_als
            Select Case myReccTermin.RecurrenceType
                Case 1
                    Cells(i, 7) = "Täglich"
                Case 2, 3
                    Cells(i, 7) = "Monatlich"
                Case 4
                    Cells(i, 7) = "Wöchentlich"
                Case 5, 6
                    Cells(i, 7) = "Jährlich"
                Case Else
                    Cells(i, 7) = "Serie"
            End Select
            Cells(i, 8) = Termin.CreationTime
            i = i + 1
        Next n
    End If
End If

If myReccTermin.PatternEndDate > endDate Then
    If myReccTermin.PatternStartDate > startDate Then
        For n = 1 To endDate - myReccTermin.PatternStartDate
            Cells(i, 1) = Termin.Subject
            Cells(i, 3) = myReccTermin.PatternStartDate + n
            Cells(i, 3).Interior.ColorIndex = 3
            Cells(i, 3).NumberFormat = "dd/mm/yyyy hh:mm"
            Cells(i, 4) = myReccTermin.PatternStartDate + n
            Cells(i, 4).Interior.ColorIndex = 3
            Cells(i, 4).NumberFormat = "dd/mm/yyyy hh:mm"
            Cells(i, 5) = Termin.ReminderMinutesBeforeStart
            Cells(i, 6) = Anzeigen_als
            Select Case myReccTermin.RecurrenceType
                Case 1
                    Cells(i, 7) = "Täglich"
                Case 2, 3
                    Cells(i, 7) = "Monatlich"
                Case 4
                    Cells(i, 7) = "Wöchentlich"
                Case 5, 6
                    Cells(i, 7) = "Jährlich"
                Case Else
                    Cells(i, 7) = "Serie"
            End Select
            Cells(i, 8) = Termin.CreationTime
            i = i + 1
        Next n
    Else
        For n = 1 To myReccTermin.PatternEndDate - startDate
            Cells(i, 1) = Termin.Subject
            Cells(i, 3) = startDate + n
            Cells(i, 3).Interior.ColorIndex = 3
            Cells(i, 3).NumberFormat = "dd/mm/yyyy hh:mm"
            Cells(i, 4) = startDate + n
            Cells(i, 4).Interior.ColorIndex = 3
            Cells(i, 4).NumberFormat = "dd/mm/yyyy hh:mm"
            Cells(i, 5) = Termin.ReminderMinutesBeforeStart
            Cells(i, 6) = Anzeigen_als
            Select Case myReccTermin.RecurrenceType
                Case 1
                    Cells(i, 7) = "Täglich"
                Case 2, 3
                    Cells(i, 7) = "Monatlich"
                Case 4
                    Cells(i, 7) = "Wöchentlich"
                Case 5, 6
                    Cells(i, 7) = "Jährlich"
                Case Else
                    Cells(i, 7) = "Serie"
            End Select
            Cells(i, 8) = Termin.CreationTime
            i = i + 1
        Next n
    End If
End If
Set myReccTermin = Nothing
End Sub

 

Hier die Tabelle zum Download: outkaldaten.xls



Zurück zum Start



Füllt eine Listbox in einer Userform mit Outlook Kontakten

Der Code füllt eine Listbox in einer Userform. Der Benefit dabei, es werden korrupte Datensätze gefunden, die bei einer Synchronisation mit einem PDA z.B. nicht synchronisiert werden können, und zum Löschen angeboten.

Sub ListBox_Fill_With_Outlook_Contacts()
'(C) by Ramses
'Variablen Deklaration
Dim outId     As Integer
Dim outFolder  As Object
Dim myOutlook  As Object
Dim outItem    As Object
Dim Qe As Integer
Dim ErrMsg As String
'Bildschirmaktualisierung ausschalten
'Application.DisplayAlerts = False
'... und Statusbar-Info ausgeben
Application.StatusBar = "   die Adressen werden aus Outlook geholt " _
    & " - das kann einen Moment dauern."
'Object Deklaration
Set myOutlook = CreateObject("Outlook.Application")
Set outFolder = myOutlook.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
'Zuweisen der Anzahl Spalten in der Listbox
UserForm1.ListBox1.ColumnCount = 7
'Zuweisen der Spaltenbreite in Pt
'1 cm ~ 28,3 Pt
UserForm1.ListBox1.ColumnWidths = "70; 70; 28; 70; 28; 70; 70"
'Einlesen der Daten
For outId = 1 To outFolder.Items.count
    'Zuweisen des Object für jeden Contact
    Set outItem = outFolder.Items(outId)
    'Einlesen des Contacts beginnen
    With outItem
        'Neuen Eintrag in Listbox einfügen
        UserForm1.ListBox1.AddItem " "
        'iIndx - 1 um auf das vorher erzeugte Item zuzugreifen
        On Error GoTo outError
        UserForm1.ListBox1.List(outId - 1, 0) = .FirstName & " " & .LastName
        'Statusbar Infor
        Application.StatusBar = "Datensatz " & outId & " von " & outFolder.Items.count & " wird gelesen: " & .FirstName
        If .BusinessAddressPostOfficeBox = "" Then
            UserForm1.ListBox1.List(outId - 1, 1) = .BusinessAddressStreet
        Else
            UserForm1.ListBox1.List(outId - 1, 1) = .BusinessAddressPostOfficeBox
        End If
        UserForm1.ListBox1.List(outId - 1, 2) = .BusinessAddressPostalCode
        UserForm1.ListBox1.List(outId - 1, 3) = .BusinessAddressCity
        UserForm1.ListBox1.List(outId - 1, 4) = .CustomerID
        UserForm1.ListBox1.List(outId - 1, 5) = .AssistantName
        UserForm1.ListBox1.List(outId - 1, 6) = .MiddleName
errorStepin:
    End With
Next outId

ErrorExit:
'Object Variablen leeren
Set outItem = Nothing
Set outFolder = Nothing
Set myOutlook = Nothing
'Bildschirm einschalten
Application.DisplayAlerts = True
'Statusbar zurücksetzen
Application.StatusBar = False
Exit Sub

outError:
Select Case Err
    Case 438
        Set conItem = outFolder.Items(outId)
        ErrMsg = "Datensatz " & outId & " ist korrupt, oder untestützt die Abfrage nicht."
        ErrMsg = ErrMsg & vbCrLf & "Datensatzkennung:"
        ErrMsg = ErrMsg & vbCrLf & "Erstelldatum: " & conItem.CreationTime
        ErrMsg = ErrMsg & vbCrLf & "ObjectID" & conItem.EntryID
        ErrMsg = ErrMsg & vbCrLf
        ErrMsg = ErrMsg & vbCrLf & "Löschen ? "
        Qe = MsgBox(ErrMsg, vbYesNo + vbCritical + vbDefaultButton2, "Datenfehler")
        If Qe = vbYes Then
            outItem.Delete
            MsgBox ("Datensatz " & outId & " wurde gelöscht")
            Resume errorStepin
        Else
            MsgBox "Datenimport wegen Datenfehler bei Datensatz " & outId & " abgebrochen"
            Resume ErrorExit
        End If
    Case Else
        MsgBox Err & ": " & Err.Description
        Resume ErrorExit
End Select
End Sub

Zurück zum Start



EXCEL Tabelle mit Outlook senden

Es ist grundsätzlich nicht möglich, eine einzelne Tabelle aus einer Mappe als Anlage zu senden, weil die Tabelle ein integrierter Bestandteil einer Mappe ist.
Eine Variante ist daher, die Tabelle in eine Arbeitsmappe zu exportieren, und diese Mappe, nur mit der Tabelle als Inhalt, als Attachment zu versenden.

  Sub Excel_Sheet_via_Outlook_Senden()
    Dim Nachricht As Object, OutApp As Object
    Dim SavePath As String
    Dim AWS As String
    SavePath = "E:\Eigene Dateien"
    Set OutApp = CreateObject("Outlook.Application")
    'Kopiert aktuelles Sheet in eine neue Mappe
    'welche nur diese Tabelle enthält
    ActiveSheet.Copy
    'Speichert die Datei unter dem Tabellennamen und dem Namen in A1
    ActiveWorkbook.SaveAs SavePath & "\" & ActiveSheet.Name & " " & ActiveSheet.Range("A1")
    'Aktive Arbeitsmappe wird als mail gesendet
    AWS = ActiveWorkbook.FullName
    'InitializeOutlook = True
    Set Nachricht = OutApp.CreateItem(0)
    With Nachricht
        .To = "irgendwer@Irgenwo.de"
        .Subject = "Testmeldung von Excel2000 " & Date & Time
        .Attachments.Add AWS
        'Hier wird eine normale Text Mail erstellt
        '.body = "Das ist ein Test" & vbCrLf & "Bitte ignorieren"
        'Hier wird die HTML Mail erstellt
        .HTMLBody = "Das ist ein Test." & vbCrLf & "Bitte ignorieren."
        'Hier wird die Mail nochmals angezeigt
        .Display
        'Hier wird die Mail gleich in den Postausgang gelegt
        '.Send
        'Hier könnte die Datei wieder gelöscht werden
        'Kill AWS
    End With
    OutApp.Quit
    Set OutApp = Nothing
    Set Nachricht = Nothing
End Sub

 

Zurück zum Start