Separera bilagor från E-post

 

I detta tips demonstreras hur vi relativt enkelt kan separera e-postbilagor i MS Outlook. Därutöver hur vi kan spara dessa i en önskad mapp samt hur vi kan dokumentera vissa egenskaper för e-postmeddelanden.

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 Information_Spara_TaBort_Bilagor()

   'Technical solution - working with attachments © 2003 All rights Ivan F Moala

   'Used by permission and revised by XL-Dennis © 2003 All rights XL-Dennis

   Dim olApp As Outlook.Application

   Dim olNameSpace As Outlook.NameSpace

   Dim olMapp As Outlook.MAPIFolder

   Dim olInBox As Outlook.MAPIFolder, olAvd As Outlook.MAPIFolder

   Dim oItem As Object, oAttach As Object

   Dim wbBok As Workbook

   Dim wsBlad As Worksheet

   Dim stMapp As String

   Dim lnAntal As Long, i As Long, x As Long

 

   Set olApp = CreateObject("Outlook.Application")

   Set olNameSpace = olApp.GetNamespace("MAPI")

   Set olMapp = olNameSpace.Folders("Personliga mappar")

   Set olInBox = olMapp.Folders("Inbox")

   'Denna mapp ligger under Inbox-mappen.

   Set olAvd = olInBox.Folders("Avd")

 

   'Här kontrollerar vi om det finns e-post eller ej i mappen.

   lnAntal = olAvd.Items.Count

 

   If lnAntal = 0 Then

      MsgBox "Inga poster att importera.", vbInformation

      GoTo ErrorHandlerExit

   End If

 

   'Mapp där bilagorna ska sparas separat i.

   stMapp = "c:\Test\"

 

   Set wbBok = Application.ActiveWorkbook

   Set wsBlad = wbBok.Sheets("Data")

 

   'Tar bort tidigare bilagedata.

   With wsBlad

      .Range("A2").CurrentRegion.ClearContents

      .Range("A1:F1").Value = VBA.Array("Ärende", "Avsändare", "Mottaget", _

            "Antal bilagor", "Bilaga 1", "Bilaga 2")

   End With

 

   'Här loopar vi igenom samtliga e-post i mappen "Avd"

   i = 1

   For Each oItem In olAvd.Items

      i = i + 1

      'Skriver uppgifter till arbetsbladet "Data".

      With wsBlad

         .Cells(i, 1).Value = oItem.Subject

         .Cells(i, 2).Value = oItem.SenderName

         .Cells(i, 3).Value = oItem.ReceivedTime

      End With

      'Om e-post har bilaga så...

      Set oAttach = oItem.Attachments

      If oAttach.Count <> 0 Then

         For x = 1 To oAttach.Count

            With oAttach

               'Skriver uppgifter till arbetsbladet "Data"

               With wsBlad

                  .Cells(i, 4).Value = oAttach.Count

                  .Cells(i, 4 + x) = oItem.Attachments.Item(x).Filename

               End With

               'Sparar bilaga i önskad mapp.

               .Item(x).SaveAsFile stMapp & .Item(x).Filename

               'Tar bort bilaga från e-post.

               .Item(x).Delete

            End With

         Next x

      End If

   Next oItem

 

   With wsBlad

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

   End With

 

ErrorHandlerExit:

   Set oAttach = Nothing

   Set oItem = Nothing

   Set olAvd = Nothing

   Set olInBox = Nothing

   Set olMapp = Nothing

   Set olNameSpace = Nothing

   Set olApp = Nothing

   Exit Sub

 

ErrorHandler:

   MsgBox "Fel nr: " & Err.Number & "; Description: " & Err.Description

   Resume ErrorHandlerExit

End Sub