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
