|
Last Update
20.07.2004
Copyright 2003
Ramses (C)
| |
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.
-
Termin aus Excel-Tabelle an Outlook senden
-
Termin aus Outlook in EXCEL einlesen
-
Excel Arbeitsmappe mit Outlook senden
-
Excel Tabelle mit Outlook senden
-
In Excel markierten/kopierten Arbeitsbereich mit Outlook
senden
-
Chart
und Bereich aus EXCEL direkt senden
-
Aufgabe mit Dateilink aus Excel Tabelle an Outlook senden
-
Serienmail aus Excel mit Outlook senden
-
Serienmail mit mehreren Anlagen aus Excel mit
Outlook senden
-
Bei überschreiten eines Wertes in einer Zelle eine
Mail mit Outlook senden
-
Mini-Mail: Arbeitsmappe mit Outlook Express senden
-
Kontakte aus Outlook in Listbox einlesen
-
Kontakte aus
Outlook in die aktuelle Tabelle einlesen
-
Chart aus EXCEL
als HTML senden ( erst ab Excel XP )
-
Importiere alle Mails aus dem Posteingang in die aktuelle Mappe
-
Kalenderdaten aus Outlook einlesen
-
Listbox in einer Userform füllen mit Outlook
Kontakten
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
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
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
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
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
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
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
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
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
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
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 i 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 n 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
|
