Gravar anexos do outlook

The script is provided "as is" and with no warranties - it is your risk to execute it. You're advise to make backup of your data before running it. you may copy it and change it at your responsability.

O script é disponibilizado sem qualquer garantia de funcionamento. É aconselhavel fazer backup dos dados antes da sua execussão. pode ser distribuido e alterado conforme desejarem.



a 8a maravilha do mundo
quer dizer.. a 8a sou eu.. portanto isto é a 9a
quer dizer... a 9a é o www.a-fotografia.com

portanto.. a 10ª maravilha do mundo

gravar anexos do outlook para uma pasta no disco a distância de um click

isto é a minha primeira incursão no mundo do vbscript e, mais uma vez o google deu a respectiva ajuda
encontrei dois blogs
http://www.vbaexpress.com/kb/getarticle.php?kb_id=522
http://www.inquiry.com/techtips/exo_pro/10min/10min0700.asp
que deram uma grande ajuda

o do vbaexpress não me agradou porque era um "sempre vivo"
o do inquiry.com nao me conseguia abrir pastas sem ser as "standard" -> inbox, outbox, etc
misturei os dois e deu isto!

no outlook façam alt+f11 e criem um novo módulo com o nome que quiserem

façam copy e paste do código em baixo

para isto funcionar a directoria tem de existir e, dentro dela, outra com o nome da pasta do outlook que querem "tratar"

os anexos ficarão com o nome filepath\folder_name\AssuntoEMail - FicheiroAnexo
a mensagem de mail será colocada nos "items eliminados"
caso algum dos anexos de uma mensagem nao se consiga gravar é dado um alerta e a mensagem de mail não é apagada

se não quiserem que a mensagem seja apagada é necessário apagaer apenas o oMsg.Delete


um mimo.... tratei milhares de mails em minutos

--------------------

the code below automatically saves the attachs from email messages to a directory
folder_name is the outlook folder you want to save the messages
file_path is the windows disk and directory

the outlook attachments will be saved to filepath\folder_name\MsgSubject - AttachFileName

the mail message will be deleted unless the attachment can't be saved - in this case you will be given a dialog box with the filename

if you do not wish the message to be deleted erase this bit
oMsg.Delete
------------

Option Explicit

'##### herrpedro.blogspot.com
'##### www.a-fotografia.com


'the name of the outlook folder
Const folder_name As String = "curtas e fun"
'the name of the phisical path where to save the files
Const FILE_PATH As String = "C:\attachs de mail\"


Sub anexos()

   Dim ns As Outlook.NameSpace
   Dim oMsg As Object
   Dim olAtt As Attachment
   Dim i, j As Integer
   Dim filename, letra As String
   Dim apaga_mensagem As Boolean
  

   Set ns = Application.GetNamespace("MAPI")
  
   'map and search all mail items in a outlook folder   
   For Each oMsg In ns.Folders.Item("Personal Folders").Folders.Item(folder_name).Items

      
       If oMsg.Attachments.Count > 0 Then
           For i = 1 To oMsg.Attachments.Count
               apaga_mensagem = True
               Set olAtt = oMsg.Attachments(i)

               'cleanup filename name so we wont get error in save
               filename = Replace(oMsg.Subject, ":", "") & " - " & olAtt.filename
               filename = Replace(filename, "?", "")
               filename = Replace(filename, "!", "")
               filename = Replace(filename, "<", "")                 
               filename = Replace(filename, ">", "")
               filename = Replace(filename, "|", "")
               filename = Replace(filename, "*", "")
               filename = Replace(filename, """", "")
               filename = Replace(filename, "\", "")
               filename = Replace(filename, "/", "")
               filename = Replace(filename, "%20", " ")
              
                j = 1
                While j < Len(filename)
                    letra = Mid(filename, j, 1)
                    If Asc(letra) < 32 Then
                        filename = Replace(filename, letra, "_", j)
                    End If
                    j = j + 1
                Wend

                filename = FILE_PATH & "\" & folder_name & "\" & filename
                'save the attachment
                
                On Error Resume Next
                
                olAtt.SaveAsFile filename
                
                If Err.Number <> 0 Then
                    MsgBox "nao consegui gravar o ficheiro ->" & filename
                    apaga_mensagem = False
                End If
                    
                On Error GoTo 0
                  
           Next
       End If
       
       'cleanUp
       Set olAtt = Nothing

       'if something went wrong the message is not deleted
       If apaga_mensagem = True Then
           oMsg.Delete
           apaga_mensagem = false
       End If
   Next
End Sub

---------------------