weixel
12-04-2016, 05:29 AM
Hi folks,
I have an VBA-code generating an appointment (birthday) from every contact item.
My Problem: I changed my accounts to Exchange. The contact items are at account1 and the appointment items should be generated at account2(Subfolder "Geb"). And I have no idea, how to customize my code.
Can anybody help me?
Here is the code:
Option Explicit
Private objNS As Outlook.NameSpace
Private objCalendar As Outlook.Folder
Private blnAbort As Boolean
Private IngLevel As Long
Sub BirthdayCheck()
Dim fldRoot As Outlook.Folder
On Error Resume Next
Set objNS = Application.GetNamespace("MAPI")
Set fldRoot = objNS.GetDefaultFolder(olFolderInbox).Parent
Set objCalendar = objNS.GetDefaultFolder(olFolderCalendar).Folders("Geb")
IngLevel = 0
blnAbort = False
Debug.Print fldRoot
Debug.Print objCalendar
ScanFolders fldRoot ' Aufruf makro ScanFolders
Set objCalendar = Nothing
Set objNS = Nothing
Beep
MsgBox "Done..."
End Sub
Public Sub CheckContact(objContact As Outlook.ContactItem)
Dim strName As String
Dim strFilter As String
Dim btn As Integer
Dim Found As Boolean
'Outlook
Dim objAppsItem As Outlook.Items
Dim objFilterdItems As Outlook.Items
Dim objAppTmp As Outlook.AppointmentItem
Dim objNewApp As Outlook.AppointmentItem
Dim objRecPatt As Outlook.RecurrencePattern
On Error Resume Next
'Geburtstage vorhanden?
If Year(objContact.Birthday) = 4501 Or Year(objContact.Birthday) = 1899 Then Exit Sub
'Ok -> Termine filtern
With objContact '
strName = Trim$(.LastName & "," & .FirstName & "" & .Suffix)
If strName = "" Then strName = ".CompanyName"
End With
Debug.Print String$(IngLevel * 2, "") & "->" & strName
strFilter = "[Subject]='Geb:" & strName & ""
Debug.Print strFilter
strFilter = Replace(strFilter, "", Chr$(34))
Debug.Print strFilter
Set objAppsItem = objCalendar.Items.Restrict(strFilter)
Found = False
For Each objAppTmp In objAppsItem
If objAppTmp.Start = objContact.Birthday Then
Found = True
End If
Next
If Not Found Then ' anlegen
ElseIf btn = vbNo Then
Exit Sub
End If
'Serientermin anlegen
Set objNewApp = Application.CreateItem(olAppointmentItem)
With objNewApp
.subject = "Geb: " & strName
.Start = objContact.Birthday
.AllDayEvent = True
.ReminderSet = False
Set objRecPatt = .GetRecurrencePattern()
With objRecPatt
.RecurrenceType = olRecursYearly
.PatternStartDate = objContact.Birthday
End With
.Links.Add objContact
.Save
End With
End Sub
Private Sub ScanFolders(fldRoot As Outlook.Folder)
Dim objTmpFolder As Outlook.Folder
Dim objTmp As Object
Dim objAppItems As Outlook.Items
Dim objContItems As Outlook.Items
Dim objContact As Outlook.ContactItem
On Error Resume Next
IngLevel = IngLevel + 1
Debug.Print IngLevel
'Eventuelle Unterordner durchsuchen
For Each objTmpFolder In fldRoot.Folders
Debug.Print String$(IngLevel * 2, "") & objTmpFolder.Name
ScanFolders objTmpFolder
If blnAbort Then Exit For
Next objTmpFolder
If Not blnAbort And fldRoot.DefaultItemType = olContactItem Then
'Kontakte im Ordner prüfen
Set objContItems = fldRoot.Items
For Each objTmp In objContItems
If objTmp.Class = olContact Then
Set objContact = objTmp
CheckContact objContact
Debug.Print objContact
If blnAbort Then Exit For ' abgebrochen
End If
Next
End If
IngLevel = IngLevel - 1
End Sub
Thanks a lot in advance
weixel
I have an VBA-code generating an appointment (birthday) from every contact item.
My Problem: I changed my accounts to Exchange. The contact items are at account1 and the appointment items should be generated at account2(Subfolder "Geb"). And I have no idea, how to customize my code.
Can anybody help me?
Here is the code:
Option Explicit
Private objNS As Outlook.NameSpace
Private objCalendar As Outlook.Folder
Private blnAbort As Boolean
Private IngLevel As Long
Sub BirthdayCheck()
Dim fldRoot As Outlook.Folder
On Error Resume Next
Set objNS = Application.GetNamespace("MAPI")
Set fldRoot = objNS.GetDefaultFolder(olFolderInbox).Parent
Set objCalendar = objNS.GetDefaultFolder(olFolderCalendar).Folders("Geb")
IngLevel = 0
blnAbort = False
Debug.Print fldRoot
Debug.Print objCalendar
ScanFolders fldRoot ' Aufruf makro ScanFolders
Set objCalendar = Nothing
Set objNS = Nothing
Beep
MsgBox "Done..."
End Sub
Public Sub CheckContact(objContact As Outlook.ContactItem)
Dim strName As String
Dim strFilter As String
Dim btn As Integer
Dim Found As Boolean
'Outlook
Dim objAppsItem As Outlook.Items
Dim objFilterdItems As Outlook.Items
Dim objAppTmp As Outlook.AppointmentItem
Dim objNewApp As Outlook.AppointmentItem
Dim objRecPatt As Outlook.RecurrencePattern
On Error Resume Next
'Geburtstage vorhanden?
If Year(objContact.Birthday) = 4501 Or Year(objContact.Birthday) = 1899 Then Exit Sub
'Ok -> Termine filtern
With objContact '
strName = Trim$(.LastName & "," & .FirstName & "" & .Suffix)
If strName = "" Then strName = ".CompanyName"
End With
Debug.Print String$(IngLevel * 2, "") & "->" & strName
strFilter = "[Subject]='Geb:" & strName & ""
Debug.Print strFilter
strFilter = Replace(strFilter, "", Chr$(34))
Debug.Print strFilter
Set objAppsItem = objCalendar.Items.Restrict(strFilter)
Found = False
For Each objAppTmp In objAppsItem
If objAppTmp.Start = objContact.Birthday Then
Found = True
End If
Next
If Not Found Then ' anlegen
ElseIf btn = vbNo Then
Exit Sub
End If
'Serientermin anlegen
Set objNewApp = Application.CreateItem(olAppointmentItem)
With objNewApp
.subject = "Geb: " & strName
.Start = objContact.Birthday
.AllDayEvent = True
.ReminderSet = False
Set objRecPatt = .GetRecurrencePattern()
With objRecPatt
.RecurrenceType = olRecursYearly
.PatternStartDate = objContact.Birthday
End With
.Links.Add objContact
.Save
End With
End Sub
Private Sub ScanFolders(fldRoot As Outlook.Folder)
Dim objTmpFolder As Outlook.Folder
Dim objTmp As Object
Dim objAppItems As Outlook.Items
Dim objContItems As Outlook.Items
Dim objContact As Outlook.ContactItem
On Error Resume Next
IngLevel = IngLevel + 1
Debug.Print IngLevel
'Eventuelle Unterordner durchsuchen
For Each objTmpFolder In fldRoot.Folders
Debug.Print String$(IngLevel * 2, "") & objTmpFolder.Name
ScanFolders objTmpFolder
If blnAbort Then Exit For
Next objTmpFolder
If Not blnAbort And fldRoot.DefaultItemType = olContactItem Then
'Kontakte im Ordner prüfen
Set objContItems = fldRoot.Items
For Each objTmp In objContItems
If objTmp.Class = olContact Then
Set objContact = objTmp
CheckContact objContact
Debug.Print objContact
If blnAbort Then Exit For ' abgebrochen
End If
Next
End If
IngLevel = IngLevel - 1
End Sub
Thanks a lot in advance
weixel