Geburtstage per Makro eintragen

[hebru]

Hallo zusammen.....
Ich lasse gelegntlich per Makro (Code im Anschluß)die Geburtstage in meinen Kalender eintragen
das funct soweit auch sehr gut .Ich würde mir allerdings eine überprüfung wünschen ob der Eintrag schon vorhanden ist
ansonsten sind viele Einträge doppelt im Kalender.
hat jemand eine Idee wie ich das lösen kann?
vielen Dank im voraus

und hier der Code

If Folder.gmailcalendars = olContactItem Then
Dim i As Integer
Set Items = Folder.Items
For Each obj In Items
If TypeOf obj Is Outlook.ContactItem Then
Set Contact = obj
Gebtag= Contact.Birthday
If Year(Gebtag) > 0 And Year(Gebtag) < 4000 Then
Contact.Birthday = 0
MsgBox Contact.Birthday
Contact.Save
Contact.Birthday = Gebtag
Contact.Save
End If

[Gast]

Code: Alles auswählen

Sub Contact_Geburtstag()
Dim Cnt As ContactItem, Con As Folder

Set Con = GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)

For Each Cnt In Con.Items
    Debug.Print Cnt.LastName, Cnt.Birthday
Next Cnt

End Sub


Damit sollte auch editieren möglich sein.

[hebru]

erstmal Danke .....
komme grad von der Arbeit muß mich noch genauer damit auseinandersetzen
allerdings glaube ich das auch dein Code nicht prüft ob der Eintrag schon vorhanden ist
mede mich morgen noch mal

[hebru]

nochmal ich....
womit ersetze ich debug.print wenn der Name in meinen TestKalender geschrieben werden soll?

[Fennek]

Als Vorbereitung: (ungeprüft)

Code: Alles auswählen

dim xlApp as Object
set xlApp = CreateObject("Excel.Application")


Dann vor der Schleife das Workbook öffnen:

Code: Alles auswählen

Set WS = xlApp.Workbooks.Open("Pfad und Dateiname.xlsx").Sheets(1)


In der Schleife als Ersatz für Debug.Print: (Ohnen Kenntnis der Datei-Struktur kann ich das nicht vernünftig referenzieren)

Code: Alles auswählen

For Each Cnt In Con.Items
    i = i + 1
    WS.cells(i, 1) = Cnt.LastName
    WS.cells(i, 2) = Cnt.Birthday
Next Cnt


[hebru]

Hallo und Danke für Deinen Code...
aber ich wollte das nicht in einer Excel Tabelle sondern in meinem Unterkalender eintragen

der o.g. Code läuft gut ich kann auch auf meinen Kontakte ordner zugreifen
Set con = GetNamespace("MAPI").Application.ActiveExplorer.CurrentFolder

jetzt ist der Kontakte Unterordner ausgewählt

dann läuft der Code

allerdings sollte das nicht im direktfenster (debug.print) ausgegeben werden
sondern in meinem Unterkalender
Set olcal = olNS.GetDefaultFolder(olFolderCalendar).Folders.Add("test")

hättest Du da was für mich?

[F_en]

Wie kannst Du auf die "SharedCalender" der Kollegen zugreifen?

Geht so etwas?

Code: Alles auswählen

Sub SharedCalendar()
Dim NSp As NameSpace: Set NSp = GetNamespace("MAPI")
Dim iRes As Recipient, ShCal As Folder

Set iRes = NSp.CreateRecipient("meine-Email-Adresse@Firma.de")

iRes.Resolve
If iRes.Resolved Then

    Set ShCal = NSp.GetSharedDefaultFolder(iRes, olFolderCalendar)
    'ShCal.Display  'ok
    Debug.Print "Anzahl", ShCal.Folders.Count
End If

Set iRes = Nothing
Set NSp = Nothing

End Sub


Die ("meine-Email-Adresse@Firma.de") muss angepasst werden. Was steht dann im Debug-Fenster?

[F_en]

Nur als Ergänzung:

Beim Neustart von Outlook wurde VBA wegen "gefährliches Add-Inn" deaktiviert. Ich vermute, dass die Ursache im Befehl

Code: Alles auswählen

GetSharedDefaultFolder(iRes, olFolderCalendar)


lag. Jedenfalls ist die Meldung nach dem Auskommentieren des Codes weg.

[hebru]

Danke und sorry für meine anscheinend missverständichen Wünsche...

also o.g. Code läuft perfekt
allerdngs sollten die Geburtstage nicht in meinen Standardkalender sondern in
Set cal = myNameSpace.GetDefaultFolder(olFolderCalendar).Folders("testcal")
eingeragen werden
und die Kontakte kmmen auch nicht aus meinem Standard Kotakte Ordner sondern aus
Set Con = GetNamespace("MAPI").GetDefaultFolder(olFolderContacts).Folders("testcon")

der "Debug.Print Cnt.LastName, Cnt.Birthday" funct einwandfrei
aber wie bringe ich die Einträge in meinen testcal Kalender?

[F_en]

Versuche

Code: Alles auswählen

Con.Items.add


Die genaue Syntax konnte ich nicht testen, aber das sollte zu "googeln" (besser: DuckDuckGo-en) sein.

[hebru]

sorry ich kriegs nicht gebacken.....