Quaisquer soluções e/ou desenvolvimento de aplicações pessoais, ou da empresa, que não constem neste Blog podem ser tratados como consultoria freelance.




DONUT PROJECT - VBA - Outlook - Salvando todos os arquivos anexados nos e-mails

DONUT PROJECT - VBA - Outlook - Salvando todos os arquivos anexados nos e-mails

Este código é totalmente funcional. foi criado para funcionar como VB Script Outlook e não será executado corretamente se usado através VB6 ou DOT Net. 

Sub SalveTodosAnexos (objitem As MailItem)
    Dim objMessage As Object
    Dim objHighlighted As Outlook.Items
    Dim objAttachments As Outlook.Attachments
    Dim strName, strLocation As String
    Dim dblCount, dblLoop As Double

    ' If you are using this code you will need to edit this
    ' line so that it matches the location within outlook
    ' of the folder you intend to scan
    ' NOTE!! Only edit the "Personal Folders\Processing..."
Set fld = GetFolder("Personal Folders\Processing...")
Set objHighlighted = fld.Items ' Tell it what to scan
    ' This is the location of the folder I want to save my attachments to
    ' You will most likely need to edit this to match the location of
    ' the folder you intend to save your attachments in.
    ' NOTE! Only edit C:\Documents and Settings\Administrator\Desktop\macro\
    Let strLocation = "C:\Documents and Settings\Administrator\Desktop\macro\"
    On Error GoTo ExitSub
    ' Check each selected item for attachments.
    ' If attachments exist, save them to the Macro
    ' folder on the Desktop.
    For Each objMessage In objHighlighted   ' For each email in the folder
     If objMessage.Class = olMail Then  ' ONLY scan emails!!
            Set objAttachments = objMessage.Attachments
            ' Now to set my loop to the amount of attachments
            ' on the current email the script is processing.
            Let dblCount = objAttachments.Count
        If dblCount <= 0 Then GoTo 100  ' If no attachments exsist
                                        ' go to the next email.
                ' I know this part looks weird...But If I counted
                ' upwards, the script was not recognizing every
                ' email and was skipping like half of them. By
                ' counting downwards, this problem is resolved.
                ' Thanks to for solving this one.
            For dblLoop = dblCount To 1 Step -1
                    ' This will be appended to the file name of each attachment to insure
                    ' that there are no duplicates, and therefor nothing gets overwritten
                    Let strID = " from " & Format(Date, "mm-dd-yy")           'Append the Date
                    Let strID = strID & " at " & Format(Time, "hh`mm`ss AMPM") 'Append the Time
                    ' These lines are going to retrieve the name of the
                    ' attachment, attach the strID to it to insure it is
                    ' a unique name, and then insure that the file
                    ' extension is appended to the end of the file name.
                    Let strName = objAttachments.Item(dblLoop).FileName 'Get attachment name
                    Let strExt = Right$(strName, 4)                     'Store file Extension
                    Let strName = Left$(strName, Len(strName) - 4)      'Remove file Extension
                    Let strName = strName & strID & strExt              'Reattach Extension
                    ' Tell the script where to save it and
                    ' what to call it
                    Let strName = strLocation & strName                 'Put it all together
                    ' Save the attachment as a file.
                    objAttachments.Item(dblLoop).SaveAsFile strName 'Save the attachment
                ' This next line DELETES the email completly.
                ' If you do not wish to delete the email
                ' change this line to read  objMessage.Save
                ' This section of code is optional. It puts a 1 second
                ' delay between file saves so that my strID is unique
                ' for EVERY file. I do this because the script does
                ' not confirm overwrites and this would be an issue for
                ' the client I am writing this for. If this is not an
                ' issue for you, just delete the entire section or
                ' simply comment it out.
                Dim PauseTime, Start, Finish, TotalTime
                    Let PauseTime = 1
                    Let Start = Timer
                    Do While Timer < Start + PauseTime
                    Let Finish = Timer
            Next dblLoop
         End If

    Set objAttachments = Nothing
    Set objMessage = Nothing
    Set objHighlighted = Nothing
    Set objOutlook = Nothing
End Sub
  ' This entire section of code was provided to me by Sue.
  ' This is NOT my work and I am NOT taking credit for it.
Function GetFolder(FolderPath)
  ' folder path needs to be something like
  '   "Public Folders\All Public Folders\Company\Sales"
  Dim aFolders
  Dim fldr
  Dim i
  Dim objNS
  On Error Resume Next

  Let strFolderPath = Replace(FolderPath, "/", "\")
  Let aFolders = Split(FolderPath, "\")
  'get the Outlook objects
  ' use intrinsic Application object in form script
  Set objNS = Application.GetNamespace("MAPI")
  'set the root folder
  Set fldr = objNS.Folders(aFolders(0))
  'loop through the array to get the subfolder
  'loop is skipped when there is only one element in the array
  For i = 1 To UBound(aFolders)
    Set fldr = fldr.Folders(aFolders(i))
    'check for errors
    If Err <> 0 Then Exit Function
  Set GetFolder = fldr
  ' dereference objects
  Set objNS = Nothing
End Function

André Luiz Bernardes

Inline image 1
Related Posts Plugin for WordPress, Blogger...
diHITT - Notícias