Quantcast
Channel: Active questions tagged excel - Stack Overflow
Viewing all articles
Browse latest Browse all 88854

Automaticaly create a windows folder to store Outlook e-mail attachments

$
0
0

I have a code that works perfectly when I run it in VBA/EXCEL. I created a module, and wrote the code below.

When I run the macro, It takes every e-mail in the outlook folder and create a new folder for each email with it's own attachments.

It's fine, but I have to run the macro to see the results. I want the process to be automatic, I dont want to have to run something. I want the automatic folder creation and attachments storage to be automaticaly done when I receive an email.

Thank you for your help.

Option Explicit

Sub Application_Startup()

Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim fol As Outlook.Folder
Dim i As Object
Dim mi As Outlook.MailItem
Dim at As Outlook.Attachment
Dim rootfol As Outlook.Folder
Dim fso As Scripting.FileSystemObject
Dim dir As Scripting.Folder
Dim dirName As String



Set fso = New Scripting.FileSystemObject

Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set rootfol = ns.Folders(1)
Set fol = rootfol.Folders("boîte de réception").Folders("test")

For Each i In fol.Items
        If i.Class = olMail Then
                Set mi = i
                If mi.Attachments.Count > 0 Then

               dirName = "C:\Users\chadi\OneDrive\Documents\VBA\"& Format(mi.ReceivedTime, "yyyy-mm-dd hh-nn-ss ") & Left(Replace(mi.Subject, ":", ""), 20)

              If fso.FolderExists(dirName) Then
          Set dir = fso.GetFolder(dirName)
              Else
          Set dir = fso.CreateFolder(dirName)

          Dim mySpecialWordDocument As String
          mySpecialWordDocument = "C:\Users\chadi\OneDrive\Documents\Scanned Documents\CHADICV.docx"
          fso.CopyFile mySpecialWordDocument, dirName & "\"& Split(mySpecialWordDocument, "\")(UBound(Split(mySpecialWordDocument, "\")))

       End If

                For Each at In mi.Attachments
                at.SaveAsFile dir.Path & "\"& at.Filename


                Next at

                End If     
        End If

    Next i


End Sub



Viewing all articles
Browse latest Browse all 88854


<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>