Outlook kalender importeren in access

[mvdkooij]

Hallo allemaal,

Ik ben op zoek naar een VBA code om een Outlook agenda te importeren in Access. Ik heb al een beetje zitten prusten maar ik krijg deze niet voor elkaar (zie hieronder). Volgens mij klopt de code alleen het rode gedeelte niet.

Wat ik wil is dat ik in een bestaande Access tabel de Outlook kalender importeer voor één datum (die in een textbox staat in Access), ik hoef alleen maar het onderwerp van het kalenderitem te hebben.

Private Sub btnImport_Click()
Dim myOLApp As Outlook.Application
Dim strSharedMailboxName As String

' Set up DAO objects (uses existing "Email" table)
   Dim rst As DAO.Recordset
   Set rst = CurrentDb.OpenRecordset("Calendar")

  Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder 'get name of other persons folder
Dim objRecip As Outlook.Recipient 'other persons name
Dim strName As String
Dim objAppt As Outlook.AppointmentItem
Dim objApp As Outlook.Application
Dim outobj As Outlook.Application
Set outobj = CreateObject("outlook.application")
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
strName = Me.email
strName = AddressToWrite

Set objRecip = objNS.CreateRecipient(strName)

    If objRecip Is Nothing Then
        MsgBox "You do not have a recipient"
        Exit Sub
    End If
    
    If Not objRecip.Resolve Then
        MsgBox "You have not given a proper email address"
        Exit Sub
        End If
        
Set objFolder = objNS.GetSharedDefaultFolder(objRecip, olFolderCalendar)


[COLOR="#FF0000"] For Each ofSub In of.Folders
    Set objItems = ofSub.Items
        iNumMessages = objItems.Count
        If iNumMessages <> 0 Then
              For i = 1 To iNumMessages
         If TypeName(objItems(i)) = "MailItem" Then

                'With rngStart
                rst.AddNew
                rst!Subject = ThisAppt.Subject
                rst.Update

                'End With
            End If
        Next i

    Else
        MsgBox "There are no appointments or meetings during" & _
               "the time you specified. Exiting now.", vbCritical
    End If
    Next[/COLOR]

    'Clear out your memory
Set objNS = Nothing
Set objFolder = Nothing
Set objRecip = Nothing
Set objApp = Nothing
Set outobj = Nothing
End Sub

 

[OctaFish]

Je declareert ofsub en of nergens.

 

[mvdkooij]

Ja klopt, want ik kom niet verder want volgens mij klopt dat rode gedeelte niet. Denk je dat het wel zou werken als ik dat zou definiëren?
Nu is het eigenlijk een code van 2 verschillende items die ik bij elkaar gezet heb.