Макрос Outlook для прочтения и сохранения писем

Sub SaveAattachments(myItem As Outlook.MailItem)
 
'Sub SaveAattachments()
 
Dim oNameSpace As NameSpace
Dim oFolder As MAPIFolder
'Dim MI As MailItem
Dim MI
Dim DestFolder As String
Dim i As Integer
 
    Set oNameSpace = ThisOutlookSession.Session
    Set oFolder = oNameSpace.GetDefaultFolder(olFolderInbox)
    
    If Len(Dir("L:\Карты\CardPL\Files\In\")) = 0 Then
 
        DestFolder = "C:\Card_In\"
    Else
        DestFolder = "L:\Карты\CardPL\Files\In\"
    End If
        
    For Each MI In oFolder.Items
        If MI.UnRead = True Then
        If MI.Attachments.Count > 0 Then
            For i = 1 To MI.Attachments.Count
                MI.Attachments.Item(i).SaveAsFile DestFolder & MI.Attachments.Item(i).DisplayName
            Next
        End If
        MI.UnRead = False
        End If
    Next
End Sub

If Len(Dir("L:\Карты\CardPL\Files\In\")) = 0 Then
 
DestFolder = "C:\Card_In\"
Else
DestFolder = "L:\Карты\CardPL\Files\In\"
End If

Option Explicit
 
Sub test()
'http://www.jpsoftwaretech.com/ _
         save-all-attachments-from-selected-folder/
  Call SaveAllAttachments("L:\Карты\MY_POST\", False)
End Sub
 
Sub SaveAllAttachments(ByVal folderName As String, _
      ByVal StripAttachments As Boolean)
' save all attachments from all emails in a folder to a folder on the hard disk
' optionally delete the attachments as well
' by Jimmy Pena, [url]http://www.jpsoftwaretech.com[/url] 4/28/2009
 
' check if folder exists, if not then create it
' if folder cannot be created, exit
If Not FolderExists(folderName) Then
  On Error Resume Next
  MkDir folderName
  If Err <> 0 Then Exit Sub
  On Error GoTo 0
End If
 
' check that folderName ends with "\"
If Right$(folderName, 1) <> "\" Then
  folderName = folderName & "\"
End If
 
' get default Inbox items collection
Dim olFldr As Outlook.MAPIFolder
Dim itms As Outlook.Items
Set olFldr = GetDefaultFolder(olFolderInbox)
Set itms = olFldr.Items
 
' create subset of items collection
Dim newItems As Outlook.Items
Set newItems = itms.Restrict("[Attachment] > 0")
 
' if there are no messages with attachments, exit
If newItems.Count = 0 Then
  RmDir folderName
  Exit Sub
End If
 
' loop through items subset, save all attachments to disk folder
Dim Msg As Outlook.MailItem
Dim MsgAttach As Outlook.attachments
Dim attachmentNumber As Integer
For Each Msg In newItems
  Set MsgAttach = Msg.attachments
  For attachmentNumber = MsgAttach.Count To 1 Step -1
    MsgAttach.Item(attachmentNumber).SaveAsFile _
      folderName & MsgAttach.Item(attachmentNumber).Filename
    ' delete attachment (optional)
    If StripAttachments Then
      MsgAttach.Item(attachmentNumber).Delete
    End If
  Next attachmentNumber
Next Msg
 
End Sub
 
Private Function GetDefaultFolder(outlookFolder As OlDefaultFolders) As _
      Outlook.MAPIFolder
' returns MAPIFolder object from default folder list to calling program
 
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
 
Set GetDefaultFolder = olNS.GetDefaultFolder(outlookFolder)
 
End Function
 
Function FolderExists(ByVal strPath As String) As Boolean
' from [url]http://allenbrowne.com[/url]
    On Error Resume Next
    FolderExists = ((GetAttr(strPath) And vbDirectory) = vbDirectory)
End Function