Quantcast
Viewing all articles
Browse latest Browse all 15628

MsOf13 Problem with loop the VBA

Hi Everyone,
I have a VBA to save the attachment from unread emails one by one on shared mailbox. but this VBA looping only 2 times. (It will check and save the attachments with 2 mails only). I want to save the attachments from all the unread emails on shared mailbox. can anyone help me to fix this issue.

Code:

Option Explicit

    Sub saveattachment()

    Dim ol As Outlook.Application

    Dim ns As Outlook.NameSpace

    Dim fol As Outlook.Folder

        Dim folco As Outlook.MAPIFolder

    Dim i As Object

    Dim mi As Outlook.MailItem

    Dim at As Outlook.Attachment

    Dim fso As Scripting.FileSystemObject

    Dim dir As Scripting.Folder

    Dim dirName As String

    Dim dirpath As String

    Set fso = New Scripting.FileSystemObject

 

    Set ol = New Outlook.Application

    Set ns = ol.GetNamespace("MAPI")

    'Set fol = ns.Folders(1).Folders("inbox")

    Set fol = ns.Folders("local mailbox").Folders("Inbox")

        Set folco = ns.Folders("local mailbox").Folders("Deleted Items")

     

' 'Set fol = ns.Folders("Shared folder").Folders("Inbox")

' 'Set folco = ns.Folders("Shared folder").Folders("Deleted Items")

    'ns.Folders(1).Folders(1) ns.Folders("Personal Folders").Folders("Deleted Items")

 

 

    For Each i In fol.Items

 

        If i.Class = 43 Then

     

        Set mi = i

'            If mi.UnRead = True Then

            If mi.Attachments.Count > 0 Then

                'Debug.Print mi.SenderName, mi.ReceivedTime, mi.Attachments.Count

             

                dirName = _

                    "C:\users\Input\" & _

                    Format(mi.ReceivedTime, "DD-mm-YYYY hh-nn-ss ") & _

                    Left(Replace(mi.Subject, ":", ""), 10)

             

'                If fso.FolderExists(dirName) Then

'                    Set dir = fso.GetFolder(dirName)

                  dirpath = "C:\users\Input\"

'                Else

'                    Set dir = fso.CreateFolder(dirName)

'                End If

             

                For Each at In mi.Attachments

                If InStr(at.DisplayName, ".xlsx") Then

                    'Debug.Print vbTab, at.DisplayName, at.Size

'                    at.SaveAsFile dirpath & "\" & at.Filename & "\" & Format(Date, "ddmmyyyy") & "_" & at.DisplayName

                            at.SaveAsFile dirpath & "\" & Format(Date, "dd-mm-yyyy") & "_" & at.DisplayName

                            mi.Move folco

'                            mi.UnRead = False

                            End If

                Next at

             

            End If

         

        End If

'    End If

 

    Next i



End Sub

Thanks in Advance

Viewing all articles
Browse latest Browse all 15628

Trending Articles



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