danny147
Terugkerende gebruiker
- Lid geworden
- 29 apr 2007
- Berichten
- 4.744
Beste, 
Graag zou ik mijn e-mails (Outlook) in een Excel bestandje willen zien.
Heb een code gekregen van Daniël maar wil deze niet testen omdat er een regel in staat die het geheugen wist.
Kan iemand deze aanpassen, of heeft iemand zo een code ??
Groetjes Danny. :thumb:
Graag zou ik mijn e-mails (Outlook) in een Excel bestandje willen zien.
Heb een code gekregen van Daniël maar wil deze niet testen omdat er een regel in staat die het geheugen wist.
Kan iemand deze aanpassen, of heeft iemand zo een code ??
Code:
Sub GetAttachments()
' Deze Outlook macro controleert de Outlook Inbox op attachements van elk type
' Attentie: Maak eerst een map "Email Attachements" in de hoofdmap
' of wijzig het path in deze code.
' Begin van de macro
On Error GoTo GetAttachments_err
' Declaratie van de variabelen
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0
' Controleer de Inbox op boodschappen en exit wanneer niets gevonden wordt
If Inbox.Items.Count = 0 Then
MsgBox "Er staan geen boodschappen in de Inbox.", vbInformation, _
"Niets gevonden"
Exit Sub
End If
' Controleer de boodschappen op attachments
For Each Item In Inbox.Items
' Sla de gevonden attachments op
For Each Atmt In Item.Attachments
' Dit path moet bestaan! Wijzig indien nodig de map naam.
FileName = "C:\Email Attachments\" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
Next Item
' Toon een boodschappen venster
If i > 0 Then
MsgBox "Ik vond " & i & " attached bestanden." _
& vbCrLf & "Ik heb ze opgeslagen in C:\Email Attachments map." _
& vbCrLf & vbCrLf & "Veel plezier ermee.", vbInformation, "Gereed!"
Else
MsgBox "Ik vond geen attached bestanden in je mail.", vbInformation, "Gereed!"
End If
' Wis het geheugen
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
' Zorg voor de fouten
GetAttachments_err:
MsgBox "Er is een onverwachte fout opgetreden." _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit
End Sub
Sub SaveAttachmentsToFolder()
' Deze macro controleerd de subfolders in de inbox
On Error GoTo SaveAttachmentsToFolder_err
' Declaratie van de variabelen
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim varResponse As VbMsgBoxResult
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("Sales Reports") ' Enter correct subfolder name.
i = 0
' Controleer de subfolder op boodschappen of anders exit.
If SubFolder.Items.Count = 0 Then
MsgBox "Er zijn geen boodschappen.", vbInformation, _
"Niets gevonden"
Exit Sub
End If
' Controleer alle boodschappen op attachments
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
' Controleer de bestandsnaam van elk attachment en sla deze op als het een "xls" extensie heeft
If Right(Atmt.FileName, 3) = "xls" Then
' Dit path moet bestaan! verander de map naam wanneer dat nodig is.
FileName = "C:\Email Attachments\" & _
Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next Item
' Toon een overzicht
If i > 0 Then
varResponse = MsgBox("Ik vond " & i & " attached bestanden." _
& vbCrLf & "Ik heb ze opgeslagen in de map C:\Email Attachments folder." _
& vbCrLf & vbCrLf & "Wilt u deze bestanden nu bekijken?" _
, vbQuestion + vbYesNo, "Gereed!")
' Open Windows Explorer om de bestanden te tonen als de gebruiker dat wenst
If varResponse = vbYes Then
Shell "Explorer.exe /e,C:\Email Attachments", vbNormalFocus
End If
Else
MsgBox "Ik vond geen gekoppelde attached bestanden in uw mail.", vbInformation, "Gereed!"
End If
' Maak het geheugen leeg
SaveAttachmentsToFolder_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
' Handel de fouten af
SaveAttachmentsToFolder_err:
MsgBox "Een onverwachte fout is opgetreden'" _
& vbCrLf & "Fout nummer: " & Err.Number _
& vbCrLf & "Fout omschrijving: " & Err.Description _
, vbCritical, "Fout!"
Resume SaveAttachmentsToFolder_exit
End SubGroetjes Danny. :thumb:
