☰

Script VBA do Outlook – Imprimir anexos e mover e-mails

tag-icon • tag-icon email microsoft-outlook vba printing
Script VBA do Outlook – Imprimir anexos e mover e-mails

Sou novo em scripts 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 que não inseri e não posso alterar, vamos chamá-la de Pasta_X.

O que estou tentando fazer é imprimir automaticamente anexos de qualquer e-mail que chegue na Pasta_X que contenha um anexo. Assim que o anexo for impresso, mova o e-mail para outra pasta (Pasta_Y). Qualquer e-mail que não tenha anexo não deve ser movido.

Anteriormente eu conseguia usar uma regra para e-mails recebidos, movendo-o para Folder_Y se tivesse um anexo e executando o seguinte script que encontrei na internet para imprimir o anexo. Mas com esta nova configuração de regra na qual não tenho entrada, não posso mais usar a regra anterior, pois as regras funcionam apenas em emails de entrada/saída e não em emails que já estejam 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 funcionar em uma pasta, ou uma forma alternativa de fazer isso, seria muito apreciada.

Responder1

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

informação relacionada