Excel VBA - перемещение электронной почты в другую папку - PullRequest
Новая
       18

Excel VBA - перемещение электронной почты в другую папку

0 голосов
/ 21 октября 2019

Мне дали проект, в который я захожу в определенную папку в папке входящих. Как только я попал в папку, мне нужно извлечь вложение и сохранить текст письма в виде текстового файла. Как только это будет сделано, мне нужно прикрепить эти два сообщения к электронному письму, чтобы отправить его в другой почтовый ящик (Mailbox2), к которому прикреплен наблюдатель файлов.

Я столкнулся с проблемой при попытке переместить письмов другую папку после отправки в Mailbox2 

-------------------------------------
Private Sub Application_NewMail()


Dim NS As Outlook.NameSpace
Set NS = Outlook.Application.GetNamespace("MAPI")

Dim Inbox As Folder
Set Inbox = NS.GetDefaultFolder(olFolderInbox)

Dim SubFolder As Folder
Set SubFolder = Inbox.Folders("TESTER")


Dim Destination As String
Destination = "MyFolder\"


Dim Atmt As Attachment
Dim FileName As String
Dim Subject As String
Dim txtFile As String


For Each Email In SubFolder.Items
    For Each Atmt In Email.Attachments
        If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
            FileName = Destination & Email.SenderName & " " & Atmt.FileName
            Atmt.SaveAsFile FileName
            I = I + 1
        End If
    Next Atmt

    Subject = Email.SenderName

    Dim rmv As Variant
    rmv = Array("\", "/", ":", "*", "?", """", "<", ">", "|")

    Dim r As Variant 

    For Each r In rmv 
        Subject = Replace(Subject, r, "")
    Next r

    txtFile = Destination & Subject & ".txt"

    Open txtFile For Output As #1
        Write #1, Email.Body
    Close #1

    Call Send_Mail(Subject)
    Call DeleteExample
Next Email

End Sub
-------------------------------------
Public Sub Send_Mail(Subject As String)
  Dim OutlookApp As Outlook.Application
  Dim OutlookMail As Outlook.MailItem
  Set OutlookApp = New Outlook.Application
  Set OutlookMail = OutlookApp.CreateItem(olMailItem)
  StrPath = "MyFolder\"

  With OutlookMail
  .Display
    .To = "Mailbox2@gmail.com"
    .CC = "Mailbox2@gmail.com"
    .BCC = "Mailbox2@gmail.com"
    .Subject = "Test mail"
    strfile = Dir(StrPath & "*.*")
    Do While Len(strfile) > 0
        If (Right(strfile, 3) = "txt" Or Right(strfile, 3) = "pdf" Or Right(strfile, 4) = "xlsx") Then
            .Attachments.Add StrPath & strfile
        End If
    strfile = Dir
    Loop
    .Send
  End With
End Sub
-------------------------------------
Sub DeleteExample()
'Deletes all files in the folder
    Kill "MyFolder\*.*"
End Sub
-------------------------------------

Я пытался внедрить эту логику в цикл for в Application_NewMail () 


For Each Email In SubFolder.Items
    For Each Atmt In Email.Attachments
        If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
            FileName = Destination & Email.SenderName & " " & Atmt.FileName
            Atmt.SaveAsFile FileName
            I = I + 1
        End If
    Next Atmt

    Subject = Email.SenderName

    Dim rmv As Variant
    rmv = Array("\", "/", ":", "*", "?", """", "<", ">", "|")

    Dim r As Variant 

    For Each r In rmv 
        Subject = Replace(Subject, r, "")
    Next r

    txtFile = Destination & Subject & ".txt"

    Open txtFile For Output As #1
        Write #1, Email.Body
    Close #1

    Call Send_Mail(Subject)
    Call DeleteExample
    Call MoveEmail()


Next Email
-------------------------------
Sub MoveEmail()
Dim NS As Outlook.NameSpace
Set NS = Outlook.Application.GetNamespace("MAPI")

Dim Inbox As Folder
Set Inbox = NS.GetDefaultFolder(olFolderInbox)

Dim SubFolder As Folder
Set SubFolder = Inbox.Folders("TESTER")

   For Each Email In SubFolder.Items
      SubFolder.MoveTo (Inbox.Folders("END"))
   Next Email

End Sub

. перемещение всей папки «TESTER» в папку «END»

Ответы [ 2 ]

0 голосов
/ 21 октября 2019

Не используйте «для каждого» при изменении коллекции - используйте цикл вниз: 

set items = SubFolder.Items
for i = items.Count to 1 step -1
  set Email = items(i)
  Email.Move (Inbox.Folders("END"))
Next
0 голосов
/ 21 октября 2019

Вмешиваясь еще немного, я узнал, как переместить письмо в другую папку.

Вот логика 

Sub MoveEmail()
Dim NS As Outlook.NameSpace
Set NS = Outlook.Application.GetNamespace("MAPI")

Dim Inbox As Folder
Set Inbox = NS.GetDefaultFolder(olFolderInbox)

Dim SubFolder As Folder
Set SubFolder = Inbox.Folders("TESTER")

   For Each Email In SubFolder.Items
      Email.Move (Inbox.Folders("END"))
   Next Email


End Sub
...