Code from one exchangeaccount to another

[weixel]

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

[skatonni]

There is a more generic format.

Set objCalendar = objNS.Folders("name of account 2 as a string").Folders("Calendar").Folders("Geb")

[weixel]

Hi skatonni,
unfortunately it does not work. The birthday items are still generated at account1......

[skatonni]

I was a little to vague. Here is an example where the item is created in the default calendar then moved to the non-default calendar in a shared mailbox in your Outlook profile.

Public Sub SharedCalendar_Appt()
 
    Dim objCalendar As Folder
    Dim objNewApp As AppointmentItem
    
    On Error Resume Next
    Set objCalendar = Session.Folders("name of account 2 as a string").Folders("Calendar").Folders("Geb")
    ' Turn off error bypass when it has served its specific purpose
    On Error GoTo 0
    
    If Not objCalendar Is Nothing Then

        Set objNewApp = CreateItem(olAppointmentItem)
    
        With objNewApp
            .Subject = "Geb: new appt"
            .Start = Now
            .Save
        End With
     
        objNewApp.Move objCalendar
        
        Debug.Print "New appt should be in shared calendar."
        
    Else
    
        Debug.Print "Calendar not found."
        
    End If
 
ExitRoutine:
    Set objNewApp = Nothing
    Set objCalendar = Nothing
    
    Debug.Print "Done " & Now
 End Sub

[weixel]

I'm afraid, I can't integrate it in the other code.... sorry......

[skatonni]

Point to the other account like this.

Sub Accounts_All()

Dim oAccount As Account
Dim i As Long
For i = 1 To Session.Accounts.count
   Debug.Print " " & i & " - " & Session.Accounts(i)
Next

End Sub

Sub BirthdayCheck()

Dim fldRoot As Outlook.Folder
Dim strAccount2 As String

' On Error Resume Next
' Use this for a specific purpose then turn off with
' On Error GoTo 0
' Now you see errors so you can fix them

Set objNS = Application.GetNamespace("MAPI")
'Set fldRoot = objNS.GetDefaultFolder(olFolderInbox).Parent
'Set objCalendar = objNS.GetDefaultFolder(olFolderCalendar).Folders("Geb")

strAccount2 = "Name of account 2 as a string"
Set fldRoot = objNS.Folders(strAccount2)

' Assuming Geb is a subfolder of the default calendar in Account 2
Set objCalendar = fldRoot.Folders("Calendar").Folders("Geb")

 IngLevel = 0
 blnAbort = False
 Debug.Print fldRoot
 Debug.Print objCalendar

 ScanFolders fldRoot ' Aufruf makro ScanFolders

ExitRoutine:
 Set objCalendar = Nothing
 Set objNS = Nothing
 Set fldRoot = Nothing
 Beep
 MsgBox "Done..."

 End Sub