Sub SaveCalendarToExcel()
On Error GoTo ErrorHandler
Const kolDato As Integer = 1
Const kolStart As Integer = 2
Const kol**** As Integer = 3
Const kolTid As Integer = 4
Const kolSats As Integer = 5
Const kolKunde As Integer = 6
Const kolSted As Integer = 7
Const kolFaktureres As Integer = 8
Const kolkat As Integer = 9
Const kolAf As Integer = 10
Const kolKm As Integer = 11
Const kolBeskrivelse As Integer = 12
Const rowStart As Integer = 2
Const standardSats As Integer = 1
Const katBase As String = "TIMER-"
Const katFaktureres As String = "Timer-Faktureres"
Const fakYes As String = "Ja"
Const fakNo As String = "Nej"
Const doKm As Boolean = False
Const xlsAfstande As String = "\\srv2\[afstande.xlsx]"
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim i As Integer
Dim lngCount As Long
Dim nms As Outlook.NameSpace
Dim fld 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 appExcel = GetObject(, "Excel.Application")
Set wkb = appExcel.Workbooks.Add
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
Set nms = Application.GetNamespace("MAPI")
uname = nms.Accounts(1).UserName
Set fld = nms.PickFolder
If fld Is Nothing Then
GoTo ErrorHandlerExit
End If
'Test whether selected folder contains contact items
If fld.DefaultItemType <> olAppointmentItem Then
MsgBox "Folder is not a calendar folder"
GoTo ErrorHandlerExit
End If
lngCount = fld.Items.Count
If lngCount = 0 Then
MsgBox "No appointments to export"
GoTo ErrorHandlerExit
End If
Dim strtDato As Date
strtDato = InputBox("Indtast startdato", "Angiv start dato", "01-" & Format(DatePart("m", DateAdd("m", -1, Now()), 2, 2), "00") & "-" & DatePart("yyyy", Now()), 2, 2)
AppActivate appExcel
wks.Cells(rowStart - 1, kolDato) = "Dato"
wks.Cells(rowStart - 1, kolStart) = "Start"
wks.Cells(rowStart - 1, kol****) = "****"
wks.Cells(rowStart - 1, kolTid) = "Tid"
wks.Cells(rowStart - 1, kolSats) = "Sats"
wks.Cells(rowStart - 1, kolKunde) = "Kunde"
wks.Cells(rowStart - 1, kolSted) = "Sted"
wks.Cells(rowStart - 1, kolFaktureres) = "Faktureres"
wks.Cells(rowStart - 1, kolkat) = "Kategori"
wks.Cells(rowStart - 1, kolAf).Value = "Udført af"
wks.Cells(rowStart - 1, kolKm).Value = "Km trt"
wks.Cells(rowStart - 1, kolBeskrivelse) = "Beskrivelse"
wks.Rows(rowStart - 1).Font.Bold = True
i = rowStart
For Each itm In fld.Items
If itm.Class = olAppointment Then
If itm.Start >= strtDato And UCase(Left(itm.Categories, 6)) = katBase Then
Set rng = wks.Cells(i, kolDato)
rng.NumberFormat = "dd-MM-yyyy"
If itm.Start <> "" Then rng.Value = itm.Start
Set rng = wks.Cells(i, kolStart)
rng.NumberFormat = "HH:mm"
If itm.Start <> "" Then rng.Value = itm.Start
Set rng = wks.Cells(i, kol****)
rng.NumberFormat = "HH:mm"
If itm.End <> "" Then rng.Value = itm.End
Set rng = wks.Cells(i, kolTid)
rng.NumberFormat = "####"
rng.Formula = "=if(" & CN2C(kolFaktureres) & i & "=""Ja"",(" & CN2C(kol****) & i & "-" & CN2C(kolStart) & i & ")*" & CN2C(kolSats) & i & "*1440,0)"
Set rng = wks.Cells(i, kolSats)
rng.NumberFormat = "#"
rng.Value = standardSats
Set rng = wks.Cells(i, kolKunde)
If itm.Subject <> "" Then rng.Value = itm.Subject
Set rng = wks.Cells(i, kolSted)
If itm.Location <> "" Then rng.Value = itm.Location
Set rng = wks.Cells(i, kolFaktureres)
rng.Value = "=IF(" & CN2C(kolkat) & i & "=""" & katFaktureres & """,""" & fakYes & """,""" & fakNo & """)"
Set rng = wks.Cells(i, kolkat)
If itm.Categories <> "" Then rng.Value = itm.Categories
wks.Cells(i, kolAf).Value = uname
If doKm = True Then
Set rng = wks.Cells(i, kolKm)
rng.NumberFormat = "####"
rng.Formula = "=VLOOKUP(" & CN2C(kolSted) & i & ",'" & xlsAfstande & "afstande'!$A$2:$E$100,5,false)"
rng.Calculate
End If
Set rng = wks.Cells(i, kolBeskrivelse)
If itm.Body <> "" Then rng.Value = Replace(itm.Body, Chr(13), "")
i = i + 1
End If
End If
Next itm
wks.Columns.AutoFit
wks.Columns.VerticalAlignment = xlTop
wks.Rows.AutoFit
Set rng = wks.UsedRange
Set objrange2 = wks.Range(CN2C(kolDato) & rowStart - 1)
Set objrange3 = wks.Range(CN2C(kolStart) & rowStart - 1)
rng.Sort objrange2, xlAscending, objrange3, , xlAscending, , , xlYes
wks.Cells(i + 2, kolStart).Value = "Timer"
wks.Cells(i + 2, kolTid).Value = "=sum(" & CN2C(kolTid) & rowStart & ":" & CN2C(kolTid) & i & ")/60"
wks.Cells(i + 2, kolKm - 1).Value = "Km"
wks.Cells(i + 2, kolKm).Value = "=sum(" & CN2C(kolKm) & rowStart & ":" & CN2C(kolKm) & i & ")"
ErrorHandlerExit:
Exit Sub
ErrorHandler:
If Err.Number = 429 Then
If appExcel Is Nothing Then
Set appExcel = CreateObject("Excel.Application")
Resume Next
End If
Else
MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
Resume ErrorHandlerExit
End If
End Sub
Function CN2C(colN As Integer) As String
Dim leading As Integer
Dim ending As Integer
Dim lc As String
leading = colN / 25
ending = colN Mod 25
lc = ""
If leading > 0 Then
lc = Chr(leading + 64)
End If
CN2C = lc & Chr(colN + 64)
End Function
