# Outlook Kalender von allen Usern nach Excel-Datei exportieren



## ETO_VBA (24. November 2008)

Hallo an alle,

ich habe ein Script geschrieben, dass bei ausführen dieses Programms, von allen Usern die freigegebene Kalender öffnet die Kalendereinträge in eine Excel-Datei exportert und anschließend unter dem jeweiligen Usernamen abspeichert.

Diese Export Function wird so oft ausgeführt, soviele User dementsprechend existieren, denn es soll von jedem User der Kalendereintrag exportiert werden.
(Funktion läuft in einer Schleife ab)


*1.PROBLEM* ist, dass die Excel Prozesse sich vermehren und das Programm dann abschmiert. Es müsste mittels eines Befehls der Prozess beenden werden nach jedem exportieren.

*2.PROBLEM* ist, dass alle Kalender geöffnet werden und keines geschlossen wird. Das Programm bleibt hängen bei 30 geöffneten Kalendern.
Sinnvol wäre wenn Kalender geöffnet, die Kalendereinträge exportiert werden und der Kalender des Users wieder geschlossen und entfernt wird.

_BITTE SIEHT unten angehange GRAFIK, die Mitarbeiter/ User müssen aus dem Ordner "Andere Kalender" entfernt werden, ansonsten wird das Programm bei einer anzahl von 200 Usern mehrere User einfügen und überlasten._

KANN MIR JEMAND BITTE BEI DIESEN ZWEI PROBLEMEN HELFEN?

VIELEN DANK ERWIN.


----------



## ETO_VBA (24. November 2008)

Sub SaveCalendarToExcel()

    Dim nms As Outlook.NameSpace

    Set nms = Outlook.Application.GetNamespace("MAPI")


    '-----------------------ALLE ORDNER------------------
    Set myAddressList = nms.AddressLists("Globale Adressliste")
    Set myAddressEntries = myAddressList.AddressEntries

    Dim m_name As String
    Dim anz As Integer
    anz = myAddressEntries.count

    Dim name_array() As String

    ReDim Preserve name_array(anz)

    Dim i As Integer

    i = 0
    For lngCount = 1 To myAddressEntries.count
        With myAddressEntries.Item(lngCount)

        name_array(i) = .Name

        i = i + 1

        End With
    Next lngCount

    i = 0
    For lngCount = 1 To myAddressEntries.count

         '        If lngCount < 10 Then

            ExportCalendar (name_array(i))

            i = i + 1

      '        End If

    Next lngCount

    '----------------------------------------------------

End Sub
Public Function ExportCalendar(m_name As String)

On Error GoTo ErrorHandler

    Dim appWord As Word.Application
    Dim appExcel As Excel.Application
    Dim wkb As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim rng As Excel.Range
    Dim strSheet As String
    Dim strTemplatePath As String
    Dim i As Integer
    Dim j As Integer
    Dim lngCount As Long
    Dim nms As Outlook.NameSpace
    Dim fld As Outlook.MAPIFolder
    Dim SharedFolder As Outlook.MAPIFolder
    Dim myExplorer As Outlook.Explorer
    Dim myRecipient As Outlook.Recipient
    Dim Beginn As Variant
    Dim Ende As Variant
    Dim Start_dat As Variant
    Dim Taetigkeit As Variant
    Dim KUNNR As String
    Dim Kunde As Variant
    Dim pruefe As Variant
    Dim projekt As String
    Dim anzahl As Long
    Dim Day_start As String
    Dim Day_end As String
    Dim intZahl As Integer
    Dim Month As Integer
    Dim Month_new As Byte
    Dim Year_start As Integer
    Dim temp As Outlook.MAPIFolder


     'Must declare as Object because folders may contain different
     'types of items
    Dim itm As Object
    Dim strTitle As String
    Dim strPrompt As String

    Set appWord = GetObject(, "Word.Application")
    strTemplatePath = appWord.Options.DefaultFilePath(wdUserTemplatesPath) & "\"
    Debug.Print "Templates folder: " & strTemplatePath
    strSheet = "Calendar.xls"
    strSheet = strTemplatePath & strSheet
    Debug.Print "Excel workbook: " & strSheet

     '------------------Test for file in the Templates folder----------------------
    If TestFileExists(strSheet) = False Then

        strTitle = "Worksheet file not found"
        strPrompt = strSheet & _
        " not found; please copy " & m_name & ".xls to this folder and try again"
        MsgBox strPrompt, vbCritical + vbOKOnly, strTitle
        GoTo ErrorHandlerExit
    End If

    '-----------NEU - EXCEL Datei im Hintergrund exportieren--------

     Set appExcel = CreateObject("Excel.Application")
     Set wkb = appExcel.Workbooks.Add
     Set wks = wkb.Worksheets.Add

    '---------------------------------------------------------------


    Set nms = Outlook.Application.GetNamespace("MAPI")
    Set fld = nms.GetDefaultFolder(olFolderCalendar)

    Set myExplorer = Outlook.Application.ActiveExplorer
    Set myExplorer.CurrentFolder = fld

    Set myRecipient = nms.CreateRecipient(m_name)
    Set SharedFolder = nms.GetSharedDefaultFolder(myRecipient, olFolderCalendar)

    myExplorer.SelectFolder SharedFolder

    '-----------------------------------------------------

    If fld Is Nothing Then
        GoTo ErrorHandlerExit
    End If

     '------------------Test whether selected folder contains contact items------------------

    If SharedFolder.DefaultItemType <> olAppointmentItem Then
        MsgBox "Folder is not a calendar folder"
        GoTo ErrorHandlerExit
    End If

     lngCount = SharedFolder.Items.count

    If lngCount = 0 Then
        'MsgBox "No appointments to export"
        GoTo ErrorHandlerExit
    Else
        Debug.Print lngCount & " appointments to export"
    End If


     '--------------Adjust i (row number) to be 1 less than the number of the first body row---------------
    i = 1

     '-------------Iterate through contact items in Calendar folder, and export a few fields---------------
     '-------------from each item to a row in the Calendar worksheet----------------

     For Each itm In SharedFolder.Items
        If itm.Class = olAppointment Then

             pruefe = ""
             pruefe = Split(itm.subject, ":")
             projekt = pruefe(0)

             If (IsNumeric(projekt)) = True Then

             anzahl = 0
             anzahl = Len(projekt)

             If (anzahl = 6) Or (anzahl = 5) Then


             If itm.alldayEvent Then


             Day_start = ""
             Day_end = ""

                Day_start = Left(itm.Start, Len(itm.Start) - 8)
                Day_end = Left(itm.End, Len(itm.End) - 8)

                Month_s = Left(itm.Start, Len(itm.Start) - 5)
                Month_e = Left(itm.End, Len(itm.End) - 5)

                Month_start = Right(Month_s, Len(Month_s) - 3)
                Month_end = Right(Month_e, Len(Month_e) - 3)

                Year_start = Right(itm.Start, Len(itm.Start) - 6)
                Year_end = Right(itm.End, Len(itm.End) - 6)

                Month = Month_end - Month_start


            For a = 0 To Month

                Month_new = Month_start + a
                intZahl = Last_Day(Month_new, Year_start)

                If a = 0 Then

                    If (Month_end - Month_start) = 0 Then

                        Day_anz = Day_end - Day_start
                        Day_anz = Day_anz - 1

                    Else


                        Day_anz = intZahl - Day_start

                            If Day_anz = 0 Then

                                Day_anz = 0

                            Else
                                Day_anz = Day_anz
                            End If
                    End If



           '----------------------------------------------------------

             Value = ""
             Value_day = ""
             Value_month_1 = ""
             Value_month = ""
             Value_year = ""
             okay_status = ""


             Value = Left(DateTime.Now, Len(DateTime.Now) - 9)

             Value_day = Left(Value, Len(Value) - 8)

             Value_month_1 = Left(Value, Len(Value) - 5)
             Value_month = Right(Value_month_1, Len(Value_month_1) - 3)

             Value_year = Right(Value, Len(Value) - 6)

             If Value_year <= Year_start Then

                If Value_year = Year_start Then

                    If Value_month < Month_new Then

                        okay_status = "1"

                    ElseIf Value_month = Month_new Then

                            If Value_day <= Day_start Then

                                okay_status = "1"
                            End If
                    End If
                Else

                        okay_status = "1"
                End If
             End If

        If okay_status = "1" Then
             '-----------------------------------------------------------------



         For x = 0 To (Day_anz - 0)

                 'j is the column number
             j = 1


            Start_dat = ""
            Start_dat = Split(itm.Start, " ")

            Set rng = wks.Cells(i, j)
            If itm.Start <> "" Then rng.Value = Day_start + x & "." & Month_start & "." & Year_start
            j = j + 1

            Set rng = wks.Cells(i, j)
            If m_name <> "" Then rng.Value = m_name
            j = j + 1


            Kunde = ""
            Kunde = Split(itm.subject, ":")

            KUNNR = Kunde(0)
            If anzahl = 6 Then
                KUNNR = Left(KUNNR, Len(KUNNR) - 2)
            Else
                KUNNR = Left(KUNNR, Len(KUNNR) - 1)
            End If
            Set rng = wks.Cells(i, j)
            If itm.subject <> "" Then rng.Value = KUNNR
            j = j + 1


            Set rng = wks.Cells(i, j)
            If itm.subject <> "" Then rng.Value = Split(itm.subject, ":")
            j = j + 1


            Set rng = wks.Cells(i, j)
            If itm.subject <> "" Then rng.Value = "Projektbezeichnung"
            j = j + 1

            Set rng = wks.Cells(i, j)
            If itm.subject <> "" Then rng.Value = "MELDNR"
            j = j + 1


            Taetigkeit = ""
            Taetigkeit = Split(itm.subject, ":")
            Set rng = wks.Cells(i, j)
            If itm.subject <> "" Then rng.Value = Taetigkeit(1)
            j = j + 1

            Set rng = wks.Cells(i, j)
            If itm.location <> "" Then rng.Value = itm.location
            j = j + 1


            Set rng = wks.Cells(i, j)
            If itm.Start <> "" Then rng.Value = "08:00:00"
            j = j + 1


            Set rng = wks.Cells(i, j)
            If itm.End <> "" Then rng.Value = "16:00:00"
            j = j + 1


            Set rng = wks.Cells(i, j)
            If itm.CreationTime <> "" Then rng.Value = itm.CreationTime
            j = j + 1

            Set rng = wks.Cells(i, j)


             '-------------Process item only if it is an appointment item---------------
             i = i + 1

            On Error Resume Next
             'The next line illustrates the syntax for referencing

             '------------a custom Outlook field-------------
            If itm.UserProperties("CustomField") <> "" Then
                rng.Value = itm.UserProperties("CustomField")
            End If
            j = j + 1

            Next x

        End If 



                ElseIf a = Month Then

                     '----------------------------------------------------------

             Value = ""
             Value_day = ""
             Value_month_1 = ""
             Value_month = ""
             Value_year = ""
             okay_status = ""


             Value = Left(DateTime.Now, Len(DateTime.Now) - 9)

             Value_day = Left(Value, Len(Value) - 8)

             Value_month_1 = Left(Value, Len(Value) - 5)
             Value_month = Right(Value_month_1, Len(Value_month_1) - 3)

             Value_year = Right(Value, Len(Value) - 6)


             If Value_year <= Year_start Then

                If Value_year = Year_start Then

                    If Value_month < Month_new Then

                        okay_status = "1"

                    ElseIf Value_month = Month_new Then

                        If Value_day <= Day_start Then

                            okay_status = "1"
                        End If

                    End If
                Else

                        okay_status = "1"
                End If
             End If

        If okay_status = "1" Then
             '-----------------------------------------------------------------

           For m = 1 To (Day_end - 1)

            '------------j is the column number----------------
             j = 1


            Start_dat = ""
            Start_dat = Split(itm.Start, " ")

            Set rng = wks.Cells(i, j)
            If itm.Start <> "" Then rng.Value = m & "." & Month_end & "." & Year_end
            j = j + 1

            Set rng = wks.Cells(i, j)
            If m_name <> "" Then rng.Value = m_name
            j = j + 1


            Kunde = ""
            Kunde = Split(itm.subject, ":")

            KUNNR = Kunde(0)
            If anzahl = 6 Then
                KUNNR = Left(KUNNR, Len(KUNNR) - 2)
            Else
                KUNNR = Left(KUNNR, Len(KUNNR) - 1)
            End If
            Set rng = wks.Cells(i, j)
            If itm.subject <> "" Then rng.Value = KUNNR
            j = j + 1


            Set rng = wks.Cells(i, j)
            If itm.subject <> "" Then rng.Value = Split(itm.subject, ":")
            j = j + 1


            Set rng = wks.Cells(i, j)
            If itm.subject <> "" Then rng.Value = "Projektbezeichnung"
            j = j + 1

            Set rng = wks.Cells(i, j)
            If itm.subject <> "" Then rng.Value = "MELDNR"
            j = j + 1


            Taetigkeit = ""
            Taetigkeit = Split(itm.subject, ":")
            Set rng = wks.Cells(i, j)
            If itm.subject <> "" Then rng.Value = Taetigkeit(1)
            j = j + 1

            Set rng = wks.Cells(i, j)
            If itm.location <> "" Then rng.Value = itm.location
            j = j + 1

            Set rng = wks.Cells(i, j)
            If itm.Start <> "" Then rng.Value = "08:00:00"
            j = j + 1



            Set rng = wks.Cells(i, j)
            If itm.End <> "" Then rng.Value = "16:00:00"
            j = j + 1


            Set rng = wks.Cells(i, j)
            If itm.CreationTime <> "" Then rng.Value = itm.CreationTime
            j = j + 1

            Set rng = wks.Cells(i, j)


             '----------------Process item only if it is an appointment item------------------
             i = i + 1


            On Error Resume Next
             '---------------The next line illustrates the syntax for referencing--------------
             '---------------a custom Outlook field----------------

            If itm.UserProperties("CustomField") <> "" Then
                rng.Value = itm.UserProperties("CustomField")
            End If
            j = j + 1

            Next m

            End If 'Ende Für okay_status

            Else

            For K = 1 To intZahl

                 '--------------j is the column number--------------
             j = 1



            Start_dat = ""
            Start_dat = Split(itm.Start, " ")

            Set rng = wks.Cells(i, j)

            If itm.Start <> "" Then rng.Value = K & "." & Month_new & "." & Year_start
            j = j + 1

            Set rng = wks.Cells(i, j)
            If m_name <> "" Then rng.Value = m_name
            j = j + 1


            Kunde = ""
            Kunde = Split(itm.subject, ":")

            KUNNR = Kunde(0)
            If anzahl = 6 Then
                KUNNR = Left(KUNNR, Len(KUNNR) - 2)
            Else
                KUNNR = Left(KUNNR, Len(KUNNR) - 1)
            End If
            Set rng = wks.Cells(i, j)
            If itm.subject <> "" Then rng.Value = KUNNR
            j = j + 1


            Set rng = wks.Cells(i, j)
            If itm.subject <> "" Then rng.Value = Split(itm.subject, ":")
            j = j + 1


            Set rng = wks.Cells(i, j)
            If itm.subject <> "" Then rng.Value = "Projektbezeichnung"
            j = j + 1

            Set rng = wks.Cells(i, j)
            If itm.subject <> "" Then rng.Value = "MELDNR"
            j = j + 1


            Taetigkeit = ""
            Taetigkeit = Split(itm.subject, ":")
            Set rng = wks.Cells(i, j)
            If itm.subject <> "" Then rng.Value = Taetigkeit(1)
            'If itm.subject <> "" Then rng.Value = itm.subject
            j = j + 1

            Set rng = wks.Cells(i, j)
            If itm.location <> "" Then rng.Value = itm.location
            j = j + 1

            Set rng = wks.Cells(i, j)
            If itm.Start <> "" Then rng.Value = "08:00:00"
            j = j + 1

            Set rng = wks.Cells(i, j)
            If itm.End <> "" Then rng.Value = "16:00:00"
            j = j + 1


            Set rng = wks.Cells(i, j)
            If itm.CreationTime <> "" Then rng.Value = itm.CreationTime
            j = j + 1

            Set rng = wks.Cells(i, j)


             '-------------Process item only if it is an appointment item-------------
             i = i + 1

            On Error Resume Next
             '-------------The next line illustrates the syntax for referencing-------------
             '-------------a custom Outlook field--------------

            If itm.UserProperties("CustomField") <> "" Then
                rng.Value = itm.UserProperties("CustomField")
            End If
            j = j + 1

            Next K

            End If


            Next a


             End If    'Ende für Prüfung AllDayEvents


             If Not itm.alldayEvent Then

             j = 1

            Start_dat = ""
            Start_dat = Split(itm.Start, " ")
            Set rng = wks.Cells(i, j)
            If itm.Start <> "" Then rng.Value = Start_dat(0)
            j = j + 1

            Set rng = wks.Cells(i, j)
            If m_name <> "" Then rng.Value = m_name
            j = j + 1


            Kunde = ""
            Kunde = Split(itm.subject, ":")

            KUNNR = Kunde(0)
            If anzahl = 6 Then
                KUNNR = Left(KUNNR, Len(KUNNR) - 2)
            Else
                KUNNR = Left(KUNNR, Len(KUNNR) - 1)
            End If
            Set rng = wks.Cells(i, j)
            If itm.subject <> "" Then rng.Value = KUNNR
            j = j + 1


            Set rng = wks.Cells(i, j)
            If itm.subject <> "" Then rng.Value = Split(itm.subject, ":")
            j = j + 1


            Set rng = wks.Cells(i, j)
            If itm.subject <> "" Then rng.Value = "Projektbezeichnung"
            j = j + 1

            Set rng = wks.Cells(i, j)
            If itm.subject <> "" Then rng.Value = "MELDNR"
            j = j + 1


            Taetigkeit = ""
            Taetigkeit = Split(itm.subject, ":")
            Set rng = wks.Cells(i, j)
            If itm.subject <> "" Then rng.Value = Taetigkeit(1)
            j = j + 1

            Set rng = wks.Cells(i, j)
            If itm.location <> "" Then rng.Value = itm.location
            j = j + 1

            Beginn = ""
            Beginn = Split(itm.Start, " ")
            Set rng = wks.Cells(i, j)
            If itm.Start <> "" Then rng.Value = Beginn(1)
            j = j + 1


            Ende = ""
            Ende = Split(itm.End, " ")
            Set rng = wks.Cells(i, j)
            If itm.End <> "" Then rng.Value = Ende(1)
            j = j + 1


            Set rng = wks.Cells(i, j)
            If itm.CreationTime <> "" Then rng.Value = itm.CreationTime
            j = j + 1

            Set rng = wks.Cells(i, j)


             '-------------Process item only if it is an appointment item------------------
             i = i + 1

            On Error Resume Next
             '-------------The next line illustrates the syntax for referencing---------------
             '-------------a custom Outlook field--------------

            If itm.UserProperties("CustomField") <> "" Then
                rng.Value = itm.UserProperties("CustomField")
            End If
            j = j + 1

         End If 'Ende für NICHT Ganztag Event

         End If 'Ende für Prüfung- Länge des Nummeric

         End If 'Ende für Nummeric Prüfung


        End If

    Next itm

   '---------------Excel Datei im hintergrund speichern-----
    wkb.SaveAs ("C:\eto\Outlook\TEST\" & m_name & ".xls")

    wkb.Close (SaveChanges = False)
    'appExcel.Quit
    'appWord.Quit

    'myExplorer.DeselectFolder SharedFolder
   '-------------------------------------------------------


ErrorHandlerExit:
    Exit Function

ErrorHandler:
    If Err.Number = 429 Then
         'Application object is not set by GetObject; use CreateObject instead
        If appWord Is Nothing Then
            Set appWord = CreateObject("Word.Application")
            Resume Next
        ElseIf appExcel Is Nothing Then
            Set appExcel = CreateObject("Excel.Application")
            Resume Next
        End If
    Else
        'MsgBox "Error No: " & Err.Number & "; Description: "
        Resume ErrorHandlerExit
    End If

    If Err.Number = 9 Then
    Resume Next
    End If


End Function


Public Function TestFileExists(StrFile As String) As Boolean

    Dim fso As New Scripting.FileSystemObject
    Dim fil As Scripting.File

    On Error Resume Next

    Set fil = fso.GetFile(StrFile)
    If fil Is Nothing Then
        TestFileExists = False
    Else
        TestFileExists = True
    End If

End Function

Function Last_Day(Monat As Byte, Jahr As Integer) As Byte
  If Monat = 12 Then
    Monat = 1
    Jahr = Jahr + 1
  Else
    Monat = Monat + 1
  End If
Last_Day = DatePart("d", DateSerial(Jahr, Monat, 1 - 1))
End Function


----------

