Scripts VBA do Outlook - Imprimir anexos e mover e-mails

Question

Eu sou novo no script VB, então preciso de muita ajuda.

Uma alteração recente em uma conta de e-mail significa que os e-mails recebidos foram movidos para uma pasta diferente da caixa de entrada por uma regra em que eu não inseri e não posso alterar, vamos chamá-la como Folder_X.

O que estou tentando fazer é anexar automaticamente os anexos de qualquer email que chegarem na Pasta_X que tenha um anexo. Depois que o anexo for impresso, mova o email para outra pasta (Pasta_Y). Qualquer email que não tenha um anexo não deve ser movido.

Anteriormente, era possível usar uma regra de entrada de mensagens, movendo-a para Folder_Y, se tivesse um anexo e executando o seguinte script que encontrei na Internet para imprimir o anexo. Mas com essa nova configuração de regra na qual não tenho entrada, não consigo mais usar a regra anterior, pois as regras só funcionam no correio de entrada / saída e não no correio já em uma pasta (Pasta_X).

Sub LSPrint(Item As Outlook.MailItem)
    On Error GoTo OError

    'detect Temp
    Dim oFS As FileSystemObject
    Dim sTempFolder As String

    Set oFS = New FileSystemObject
    'Temporary Folder Path
    sTempFolder = oFS.GetSpecialFolder(TemporaryFolder)
    'creates a special temp folder
    cTmpFld = sTempFolder & "\OETMP" & Format(Now, "yyyymmddhhmmss")
    MkDir (cTmpFld)

    'save & print
    Dim oAtt As Attachment

    For Each oAtt In Item.Attachments
      FileName = oAtt.FileName
      FullFile = cTmpFld & "\" & FileName

      'save attachment
      oAtt.SaveAsFile (FullFile)

      'print attachment
      Set objShell = CreateObject("Shell.Application")
      Set objFolder = objShell.NameSpace(0)
      Set objFolderItem = objFolder.ParseName(FullFile)
      objFolderItem.InvokeVerbEx ("print")
    Next oAtt

    'Cleanup

    If Not oFS Is Nothing Then Set oFS = Nothing
    If Not objFolder Is Nothing Then Set objFolder = Nothing
    If Not objFolderItem Is Nothing Then Set objFolderItem = Nothing
    If Not objShell Is Nothing Then Set objShell = Nothing

OError:

    If Err <> 0 Then
      MsgBox Err.Number & " - " & Err.Description
      Err.Clear
    End If

    Exit Sub
End Sub

Qualquer sugestão sobre como adaptar este script para trabalhar em uma pasta, ou uma maneira alternativa de fazer isso seria muito apreciada.

    

Answer 1

Você pode usar o evento ItemAdd para executar o código depois que um item entra em uma pasta.

Option Explicit

'  In ThisOutlookSession
Private WithEvents addedItems As Items

Private Sub Application_Startup()
    ' Add as many  .folders(subfolder name) as is needed to navigate to the folder
    Set addedItems = Session.GetDefaultFolder(olFolderInbox).folders("folder_X").Items
End Sub

Private Sub addedItems_ItemAdd(ByVal Item As Object)

    Dim oAtt As attachment

    If Item.Attachments.count > 0 Then

        Debug.Print "Processing " & Item.subject

        For Each oAtt In Item.Attachments
            Debug.Print "Processing attachment."
        Next oAtt

        Item.move Session.GetDefaultFolder(olFolderInbox).folders("folder_Y")

    End If

End Sub