Importera journalposter från MS Outlook

Importera journalposter

I detta tips demonstreras hur vi relativt enkelt kan importera journalposter från MS Outlook. Detta förfarande kan komma till nytta om vi använder oss av MS Outlooks journalsystem för arbetstidhantering mm.

För att exemplet ska fungera krävs att en referens till MS Outlook x.x objektbibliotek anges.

Om ett felmeddelande erhålls vid kopiering till VBA-modul så läs mer här»

(© 2002 - 2003 All rights Colo - Used by permission)

Option Explicit
Sub Importera_Journalposter()

   '© 2003 Alla rättigheter XL-Dennis

   Dim olApp As Outlook.Application

   Dim olNamespace As Outlook.NameSpace

   Dim olJourFolder As Outlook.MAPIFolder

   Dim olJourItem As Outlook.JournalItem

   Dim wbBok As Workbook

   Dim wsBlad As Worksheet

   Dim lnAntal As Long, i As Long

   Set olApp = CreateObject("Outlook.Application")

   Set olNamespace = olApp.GetNamespace("MAPI")

   Set olJourFolder = olNamespace.GetDefaultFolder(olFolderJournal)

   'Här kontrollerar vi om det finns poster eller ej.

   lnAntal = olJourFolder.Items.Count

   If lnAntal = 0 Then

      MsgBox "Inga poster att importera.", vbInformation

      GoTo ErrorHandlerExit

   End If

   Set wbBok = Application.ActiveWorkbook

   Set wsBlad = wbBok.Sheets("Data")

   'Ta bort tidigare postdata.

   With wsBlad

      .Range("A2").CurrentRegion.ClearContents

      .Range("A1:J1").Value = VBA.Array("Företag", "Kontaktperson", "Kategorier", _

            "Ämne", "Aktivitet", "Total tid", "Starttid", _

            "Sluttid", "Body", "Information")

   End With

   'Här loopar vi igenom samtliga journalposter.

   i = 1

   For Each olJourItem In olJourFolder.Items

      i = i + 1

      With wsBlad

         .Cells(i, 1).Value = olJourItem.Companies

         .Cells(i, 2).Value = olJourItem.Links(1)

         .Cells(i, 3).Value = olJourItem.Categories

         .Cells(i, 4).Value = olJourItem.Subject

         .Cells(i, 5).Value = olJourItem.Type

         .Cells(i, 6).Value = olJourItem.Duration

         .Cells(i, 7).Value = olJourItem.Start

         .Cells(i, 8).Value = olJourItem.End

         .Cells(i, 9).Value = olJourItem.Body

         .Cells(i, 10).Value = olJourItem.BillingInformation

      End With

   Next olJourItem

   With wsBlad

      .Columns("A:J").EntireColumn.AutoFit

   End With

ErrorHandlerExit:

   Set olJourItem = Nothing

   Set olJourFolder = Nothing

   Set olNamespace = Nothing

   Set olApp = Nothing

   Exit Sub

ErrorHandler:

   MsgBox "Error No.: " & Err.Number & "; Description: " & Err.Description

   Resume ErrorHandlerExit

End Sub