Outlook agenda naar excel

Krist · 9 dec 2020

Dag,

Ik wou een gedeelde agenda naar excel brengen. Via google ben ik tot hier geraakt. Maar ik sukkel met de naam van de gedeelde folder. VBA is mijn sterkste niet

Ik krijg een foutmelding bij de naam 'objOwner'...
Met: Set olFolder = olNS.GetDefaultFolder(9) 'olFolderCalendar
lukt het voor mijn eigen agenda.

Alvast dank voor de hulp
Krist

Code:

Option Explicit

Sub ListAppointments()
    Dim olApp As Object
    Dim olNS As Object
    Dim olFolder As Object
    Dim olApt As Object
    Dim NextRow As Long
    Dim FromDate As Date
    Dim ToDate As Date

    FromDate = CDate("01/01/2020")
    ToDate = CDate("31/12/2020")

    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number > 0 Then Set olApp = CreateObject("Outlook.Application")
    On Error GoTo 0

    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = oNs.GetSharedDefaultFolder(objOwner, olFolderCalendar).Parent.Folders("Ligand OC") 'olFolderCalendar
    NextRow = 2

    With Sheets("Agenda2020") 'Change the name of the sheet here
        .Range("A1:D1").Value = Array("Project", "Date", "Time spent", "Location")
        For Each olApt In olFolder.Items
            If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
                .Cells(NextRow, "A").Value = olApt.Subject
                .Cells(NextRow, "B").Value = CDate(olApt.Start)
                .Cells(NextRow, "C").Value = olApt.End - olApt.Start
                .Cells(NextRow, "C").NumberFormat = "HH:MM:SS"
                .Cells(NextRow, "D").Value = olApt.Location
                .Cells(NextRow, "E").Value = olApt.Categories
                NextRow = NextRow + 1
            Else
            End If
        Next olApt
        .Columns.AutoFit
    End With

    Set olApt = Nothing
    Set olFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Sub

edmoor · 9 dec 2020

Als je zegt een foutmelding te krijgen, zeg er dan ook bij welke dat is.
Daarnaast moet objOwner een object zijn en geresolved.

Het staat hier volledig uitgelegd:
https://docs.microsoft.com/en-us/office/vba/api/outlook.namespace.getshareddefaultfolder

Krist · 9 dec 2020

Dank voor de reactie...
Heb nu aangepast voor zover ik de uitleg via de link goed begrijp.
Nu krijg ik de fout: objectvariabele of blokvariabele With is niet ingesteld

Mijn kennis gaat niet zo hoog, hiervoor

Code:

Option Explicit

Sub ListAppointments()
    Dim olApp As Object
    Dim olNS As Object
    Dim olFolder As Object
    Dim olApt As Object
    Dim NextRow As Long
    Dim FromDate As Date
    Dim ToDate As Date
    Dim objOwner As Object
    Dim olFolderCalendar As Object
    Dim oNs As Object
    
    FromDate = CDate("01/01/2020")
    ToDate = CDate("31/12/2020")

    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number > 0 Then Set olApp = CreateObject("Outlook.Application")
    On Error GoTo 0

    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = oNs.GetSharedDefaultFolder(objOwner, olFolderCalendar).Parent.Folders("Ligand OC") 'olFolderCalendar
    NextRow = 2

    With Sheets("Agenda2020") 'Change the name of the sheet here
        .Range("A1:D1").Value = Array("Project", "Date", "Time spent", "Location")
        For Each olApt In olFolder.Items
            If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
                .Cells(NextRow, "A").Value = olApt.Subject
                .Cells(NextRow, "B").Value = CDate(olApt.Start)
                .Cells(NextRow, "C").Value = olApt.End - olApt.Start
                .Cells(NextRow, "C").NumberFormat = "HH:MM:SS"
                .Cells(NextRow, "D").Value = olApt.Location
                .Cells(NextRow, "E").Value = olApt.Categories
                NextRow = NextRow + 1
            Else
            End If
        Next olApt
        .Columns.AutoFit
    End With

    Set olApt = Nothing
    Set olFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Sub

edmoor · 9 dec 2020

Je hebt alleen Dim objOwner As Object er bij gezet.
Daarmee heb je alleen de variabele en niet het object.
Daarnaast moet deze niet als object maar als Outlook.Recipient worden gedimmed: Dim objOwner As Outlook.Recipient
Je mist nog een Set objOwner opdracht en het resolven van het object.

Het staat toch echt duidelijk uitgelegd op de pagina waar ik naar verwees.

OctaFish · 9 dec 2020

Probeer het eens met Pickfolder:

Code:

    Set olFolder = olNS.PickFolder

Krist · 9 dec 2020

@edmoor
Ik begrijp niet wat ik moet invullen bij Set myRecipient = myNamespace.CreateRecipient("Dan Wilson"), mijn naam en mailadres lukt niet, ook niet de gedeelde agenda

@Octafish
Ik vind dan mijn gedeelde agenda's niet terug, wel mijn andere agenda's

Alvast dank

snb · 9 dec 2020

Een combinatie van

https://www.snb-vba.eu/VBA_Outlook_external.html#L_1.4.2
en
https://www.snb-vba.eu/VBA_Outlook_external.html#L_10.3.1

Je zult de helpers hier iets moeten zeggen over je outlook mappenstruktuur voordat je verder gehopen kunt worden.
Vermijd al die overbodige objectvariabelen; gebruik gewoon With ... End With.

Krist · 11 dec 2020

Hallo,

Ik wou even opnieuw beginnen. Bovenstaande werkt toch niet met mijn eigen agenda.
Ik wil dus een gedeelde agenda (Agenda2020' naar excel brengen. Deze is gedeeld in een domein via Off365. We gebruiken die om zaaltjes te boeken voor specifieke doelen. Nu is er iemand die deze knipt en plakt in excel om er daarna berekeningen mee te doen.

Ik heb dit geprobeerd van 'snb', maar dit heeft niet alle agenda's, ik krijg 9 agenda's, naast mijn agenda, maar er ontbreken er zeker 10.
Ik heb drie rubrieken: mijn agenda's, andere agenda's (daar staan geen onder) en gedeelde agenda's.

Zo'n code kan ik niet schrijven,
Graag jullie hulp,
Alvast dank,

Krist

Code:

Sub mappen_Outlookmappenstruktuur()
For Each fld In CreateObject("Outlook.Application").GetNamespace("MAPI").Folders
c01 = c01 & vbCr & vbCr & fld.Name & "|" & fld.Folders.Count & "|" & fld.Items.Count

For Each fld1 In fld.Folders
c01 = c01 & vbCr & "|" & fld1.Name & "|" & fld1.Folders.Count & "|" & fld1.Items.Count

For Each fld2 In fld1.Folders
c01 = c01 & vbCr & "||" & fld2.Name & "|" & fld2.Folders.Count & "|" & fld2.Items.Count

For Each fld3 In fld2.Folders
c01 = c01 & vbCr & "|||" & fld3.Name & "|" & fld3.Folders.Count & "|" & fld3.Items.Count
Next
Next
Next
Next

Sheets("Blad1").Cells(1).Resize(UBound(Split(c01, vbCr)) - 1) = Application.Transpose(Split(Mid(c01, 3), vbCr))
Sheets("Blad1").Columns(1).TextToColumns , 1, -4142, , False, False, False, False, True, "|"
End Sub

Krist · 18 dec 2020

Beste,

Ik heb verder gezocht en onderstaande gevonden... Is een code om in outlook in te brengen. Dan open je de agenda die je wilt exporteren en voer je de code uit.
Je krijgt dan netjes alle gegevens uit de agenda in een excel. Dit werkt voor mij.

Ik wou dit even meegeven (ik zou zoiets nooit kunnen schrijven)

groeten,
Krist

HTML:

Sub ExportAppointmentsToExcel()
    Const SCRIPT_NAME = "Export Appointments to Excel (Rev 1)"
    Const xlAscending = 1
    Const xlYes = 1
    Dim olkFld As Object, _
        olkLst As Object, _
        olkRes As Object, _
        olkApt As Object, _
        olkRec As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        lngRow As Long, _
        lngCnt As Long, _
        strFil As String, _
        strLst As String, _
        strDat As String, _
        datBeg As Date, _
        datEnd As Date, _
        arrTmp As Variant
    Set olkFld = Application.ActiveExplorer.CurrentFolder
    If olkFld.DefaultItemType = olAppointmentItem Then
        strDat = InputBox("Enter the date range of the appointments to export in the form ""mm/dd/yyyy to mm/dd/yyyy""", SCRIPT_NAME, Date & " to " & Date)
        arrTmp = Split(strDat, "to")
        datBeg = IIf(IsDate(arrTmp(0)), arrTmp(0), Date) & " 12:00am"
        datEnd = IIf(IsDate(arrTmp(1)), arrTmp(1), Date) & " 11:59pm"
        strFil = InputBox("Enter a filename (including path) to save the exported appointments to.", SCRIPT_NAME)
        If strFil <> "" Then
            Set excApp = CreateObject("Excel.Application")
            Set excWkb = excApp.Workbooks.Add()
            Set excWks = excWkb.Worksheets(1)
            'Write Excel Column Headers
            With excWks
                .Cells(1, 1) = "Category"
                .Cells(1, 2) = "Subject"
                .Cells(1, 3) = "Starting Date"
                .Cells(1, 4) = "Ending Date"
                .Cells(1, 5) = "Start Time"
                .Cells(1, 6) = "End Time"
                .Cells(1, 7) = "Hours"
                .Cells(1, 8) = "Attendees"
            End With
            lngRow = 2
            Set olkLst = olkFld.Items
            olkLst.Sort "[Start]"
            olkLst.IncludeRecurrences = True
            Set olkRes = olkLst.Restrict("[Start] >= '" & Format(datBeg, "ddddd h:nn AMPM") & "' AND [Start] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
            'Write appointments to spreadsheet
            For Each olkApt In olkRes
                'Only export appointments
                If olkApt.Class = olAppointment Then
                    strLst = ""
                    For Each olkRec In olkApt.Recipients
                        strLst = strLst & olkRec.Name & ", "
                    Next
                    If strLst <> "" Then strLst = Left(strLst, Len(strLst) - 2)
                    'Add a row for each field in the message you want to export
                    excWks.Cells(lngRow, 1) = olkApt.Categories
                    excWks.Cells(lngRow, 2) = olkApt.Subject
                    excWks.Cells(lngRow, 3) = Format(olkApt.Start, "mm/dd/yyyy")
                    excWks.Cells(lngRow, 4) = Format(olkApt.End, "mm/dd/yyyy")
                    excWks.Cells(lngRow, 5) = Format(olkApt.Start, "hh:nn ampm")
                    excWks.Cells(lngRow, 6) = Format(olkApt.End, "hh:nn ampm")
                    excWks.Cells(lngRow, 7) = DateDiff("n", olkApt.Start, olkApt.End) / 60
                    excWks.Cells(lngRow, 7).NumberFormat = "0.00"
                    excWks.Cells(lngRow, 8) = strLst
                    lngRow = lngRow + 1
                    lngCnt = lngCnt + 1
                End If
            Next
            excWks.Columns("A:H").AutoFit
            excWks.Range("A1:H" & lngRow - 1).Sort Key1:="Category", Order1:=xlAscending, Header:=xlYes
            excWks.Cells(lngRow, 7) = "=sum(G2:G" & lngRow - 1 & ")"
            excWkb.SaveAs strFil
            excWkb.Close
            MsgBox "Process complete.  A total of " & lngCnt & " appointments were exported.", vbInformation + vbOKOnly, SCRIPT_NAME
        End If
    Else
        MsgBox "Operation cancelled.  The selected folder is not a calendar.  You must select a calendar for this macro to work.", vbCritical + vbOKOnly, SCRIPT_NAME
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    Set olkApt = Nothing
    Set olkLst = Nothing
    Set olkFld = Nothing
End Sub

Outlook agenda naar excel

Krist

Gebruiker

edmoor

Inventaris

Krist

Gebruiker

edmoor

Inventaris

OctaFish

Verenigingslid

Krist

Gebruiker

snb

Verenigingslid

Krist

Gebruiker

Krist

Gebruiker

Nieuwste berichten

Wij waarderen jouw privacy