AatB
Gebruiker
- Lid geworden
- 15 dec 2007
- Berichten
- 253
Goedemorgen,
Ik wil alle bijlages opslaan van een folder en zijn subfolders in Outlook.
Ben al een beetje op streek en het werkt voor een folder.
Alleen nu de subfolders nog..... wellicht dat mij iemand in de goede richting kan duwen
Bedankt alvast,
Grt Aat
Ik wil alle bijlages opslaan van een folder en zijn subfolders in Outlook.
Ben al een beetje op streek en het werkt voor een folder.
Alleen nu de subfolders nog..... wellicht dat mij iemand in de goede richting kan duwen
Bedankt alvast,
Grt Aat
Code:
Public Sub SaveAttachments()
Dim objOutLook As Outlook.Application
Dim objSelection As Outlook.Selection
Dim objMsg As Outlook.MailItem
Dim objAttachment As Outlook.Attachment
Dim YearFolder As String
Dim TmpFolder As String
Dim FldrName As String
Dim SenderFolder As String
Dim Map As String
Dim Fname As String
Dim Ext As String
Dim dd As Date
'Check if main folder exist ---------------------------------------------------
TmpFolder = CreateObject("WScript.Shell").SpecialFolders(16) & "\ABBA" 'OneDrive\ABBA\
Map = Dir(TmpFolder, vbDirectory)
If Map = "" Then MkDir TmpFolder
TmpFolder = TmpFolder & "\Bijlagen Outlook" 'OneDrive\ABBA\Bijlagen Outlook
Map = Dir(TmpFolder, vbDirectory)
If Map = "" Then MkDir TmpFolder
'--------------------------------------------------------------------------
Set objOutLook = CreateObject("Outlook.Application")
' Get the collection of selected objects ----------------------------------
Set objSelection = objOutLook.ActiveExplorer.Selection
' Check for attachments and save them in the folder \Year\Sendername\ ------
For Each objMsg In objSelection
FldrName = objMsg.Sender
'Check if YearFolder exist ------------------------------------------
dd = Format(objMsg.ReceivedTime, "yyyy-mm-dd")
YearFolder = TmpFolder & "\" & Year(dd)
Map = Dir(YearFolder, vbDirectory)
If Map = "" Then MkDir YearFolder
'Check of senderfolder bestaat ------------------------------------------
SenderFolder = YearFolder & "\" & FldrName
Map = Dir(SenderFolder, vbDirectory)
If Map = "" Then MkDir SenderFolder
'----------------------------------------------------------------------
For Each objAttachment In objMsg.Attachments
Fname = objAttachment.DisplayName
If InStrRev(Fname, ".") Then
Ext = LCase(Mid(Fname, InStrRev(Fname, ".")))
Select Case Ext
Case ".pdf", ".doc", ".docx", ".xls", ".xlsx", ".xlsm"
objAttachment.SaveAsFile SenderFolder & "\" & dd & " " & Fname
End Select
End If
Next
Next
Set objOutLook = Nothing
Set objSelection = Nothing
Set objMsg = Nothing
Set objAttachment = Nothing
End Sub