✔ Programação GLOBAL®: Outlook VBA - Imprima documentos anexados

Outlook VBA - Imprima documentos anexados

Receba 3 Calendários Customizáveis de 2013 em Excel

Você tem direito as informações da sua empresa

MIS - Usufruindo a excelência na análise das suas Informações

Dados ou Informações?

Dashboards - 8 Importantes características desejáveis

Key Performance Indicators - 7 Características desejáveis

Tópicos relacionados:

Envie um email sem o aviso de segurança

Coleta de dados por meio de mensagens de email

Como enviar um email com uma assinatura dinâmica
Anexando arquivo ao email
Avalia o endereço do email
Como criar um código no Outlook
Pesquise todos os emails no Outlook e extraia informações

Enviando E-mail sem o aviso de segurança

Enviando e-mails a partir do Excel

Como exportar as tarefas do MS Outlook para o MS Excel

LOTUS NOTES DOMINO - Código de envio de emails

Criei um código para imprimir todos os anexos que receber mesmo que estes cheguem compactados. O modo como escolhi fazer isso envolve salvar o arquivo zipado para um local temporário e descompactá-lo de lá.

Mas isso não funciona tão bem, o problema é que ao salvar o arquivo zipado, recebo automaticamente um alerta do explorer perguntando se quero descompactá-lo.

Para evitar este pop-up precisei renomear o arquivo como .TXT, saldo-o assim e em seguida, após tê-lo salvo, renomeá-lo novamente para .ZIP.

Sub PrintMail()

Dim ns As NameSpace

Dim Item As Outlook.MailItem

Dim Inbox As MAPIFolder

Dim Atmt As Attachment

Dim FileName As String

Dim Done As MAPIFolder

Dim i As Integer

Dim Fname1 As String

Dim myMailBox As String

Dim currentTime As Date

Dim unzipedFile As String

Dim atmtName As String

Dim searchString As String

Dim oApp As Object

Dim FileNameFolder As Variant

Dim FSO As Object

Set ns = GetNamespace("MAPI")

Let myMailBox = "Mailbox - AD"

Let searchString = ".zip"

Select Case ns.GetDefaultFolder(olFolderInbox).Parent

Case myMailBox

Set MyInbox = ns.Folders(myMailBox).Folders("Inbox").Items

Set PrintMailBox = ns.Folders("Mailbox - PRINT").Folders("Inbox").Items

Set Inbox = ns.Folders("Mailbox - PRINT").Folders("Inbox")

Set Done = Inbox.Folders("Printed")

Case "Mailbox - PRINT"

Set PrintMailBox = ns.Folders("Mailbox - PRINT").Folders("Inbox").Items

Set Inbox = ns.Folders("Mailbox - PRINT").Folders("Inbox")

Set Done = Inbox.Folders("Printed")

End Select

If PrintMailBox.Count > 0 Then

For Each Item In PrintMailBox

If Item.Attachments.Count > 0 Then

Item.PrintOut

For Each Atmt In Item.Attachments

If Right(Atmt.FileName, 3) = "zip" Then

'FileNameFolder = "C:\Temp\"

'FileName = FileNameFolder & Atmt.FileName

'Atmt.SaveAsFile FileName 'THIS IS WHERE THE POP UP OCCURS

'Set oApp = CreateObject("Shell.Application")

'oApp.NameSpace((FileNameFolder)).CopyHere oApp.NameSpace((FileName)).Items

Let FileNameFolder = "C:\Temp\"

Let FileName = FileNameFolder & Left(Atmt.FileName, (InStr(1, Atmt.FileName, ".zip") - 1)) & ".txt"

Atmt.SaveAsFile FileName 'copy the file to the folder

Let FileNameT = FileNameFolder & Atmt.FileName

Name FileName As FileNameT

Set oApp = CreateObject("Shell.Application")

oApp.NameSpace((FileNameFolder)).CopyHere oApp.NameSpace((FileNameT)).Items

On Error Resume Next

Set FSO = CreateObject("scripting.filesystemobject")

FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True

Kill FileName

Let atmtName = Atmt.FileName

Let unzipedFile = Left(atmtName, (InStr(1, atmtName, searchString) - 1))

Select Case Right(unzipedFile, 3)

Case "doc"

Let FileName = Left(unzipedFile, (InStr(1, unzipedFile, "-doc") - 1))

Let FileName = "C:\Temp\" & FileName & ".doc"

ShellExecute 0, "print", FileName, vbNullString, vbNullString, 0

Case "ocx"

Let FileName = Left(unzipedFile, (InStr(1, unzipedFile, "-docx") - 1))

Let FileName = "C:\Temp\" & FileName & ".docx"

ShellExecute 0, "print", FileName, vbNullString, vbNullString, 0

Case "xls"

Let FileName = Left(unzipedFile, (InStr(1, unzipedFile, "-xls") - 1))

Let FileName = "C:\Temp\" & FileName & ".xls"

ShellExecute 0, "print", FileName, vbNullString, vbNullString, 0

Case "lxs"

Let FileName = Left(unzipedFile, (InStr(1, unzipedFile, "-xlsx") - 1))

Let FileName = "C:\Temp\" & FileName & ".xlsx"

ShellExecute 0, "print", FileName, vbNullString, vbNullString, 0

Case "ppt"

Let FileName = Left(unzipedFile, (InStr(1, unzipedFile, "-ppt") - 1))

Let FileName = "C:\Temp\" & FileName & ".ppt"

ShellExecute 0, "print", FileName, vbNullString, vbNullString, 0

Case "pps"

Let FileName = Left(unzipedFile, (InStr(1, unzipedFile, "-pps") - 1))

Let FileName = "C:\Temp\" & FileName & ".pps"

ShellExecute 0, "print", FileName, vbNullString, vbNullString, 0

Case "ptx"

Let FileName = Left(unzipedFile, (InStr(1, unzipedFile, "-pptx") - 1))

Let FileName = "C:\Temp\" & FileName & ".pptx"

ShellExecute 0, "print", FileName, vbNullString, vbNullString, 0

Case "pdf"

Let FileName = Left(unzipedFile, (InStr(1, unzipedFile, "-pdf") - 1))

Let FileName = "C:\Temp\" & FileName & ".pdf"

ShellExecute 0, "print", FileName, vbNullString, vbNullString, 0

End Select

Else

Let FileName = "C:\Temp\" & Atmt.FileName

Atmt.SaveAsFile FileName

ShellExecute 0, "print", FileName, vbNullString, vbNullString, 0

End If

Next Atmt

Item.Move Done

End If

Next Item

End If

Let currentTime = Now

Do Until currentTime + TimeValue("00:00:30") <= Now

Loop

Call DeleteFiles