Views

Histats

Vitrine

Outlook VBA - Imprima documentos anexados






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
End Sub

Tags: VBA, Outlook, print, attached, 



✔ VBA Brazil®

✔ VBA Brazil®
brazilsalesforceeffectiveness@gmail.com
Related Posts Plugin for WordPress, Blogger...
diHITT - Notícias