Consulting

Results 1 to 5 of 5

Thread: Solved: Automate Saving Attachments in Selected Message Attachments

  1. #1

    Solved: Automate Saving Attachments in Selected Message Attachments

    It isn't Pretty but, it works! Thanks So Much

    P.S ? Could the same be done but, instead of all the items in the folder only save attachments of messages that have been selected and are Highlighted?

    [vba]
    Sub SavAttachment002()
    Dim oOutlook As Outlook.Application
    Dim oNs As Outlook.NameSpace 'Main Outlook Today
    Dim oFldrSb As Outlook.MAPIFolder 'Sub Folder in Outlook Today
    Dim oFldrSbSb As Outlook.MAPIFolder 'Sub in Sub Folder
    Dim oFldrSbSbSb As Outlook.MAPIFolder 'Sub in Sub of Sub Folder
    Dim oMessage As Object
    Dim sPathName As String
    Dim oAttachment As Outlook.Attachment
    Dim iCtr As Integer
    Dim iAttachCnt As Integer
    sPathName = "C:\Documents and Settings\My Name\My Documents\XL\Hrs\Asking\" 'My Folder Path where to save attachments
    Set oOutlook = New Outlook.Application
    Set oNs = oOutlook.GetNamespace("MAPI")
    Set oFldrSb = oNs.Folders("Mailbox ? My Name")
    Set oFldrSbSb = oFldrSb.Folders("Incoming OT Info")
    Set oFldrSbSbSb = oFldrSbSb.Folders("Weekend Asking")
    For Each oMessage In oFldrSbSbSb.Items
    With oMessage.Attachments
    iAttachCnt = .Count
    If iAttachCnt > 0 Then
    For iCtr = 1 To iAttachCnt
    .Item(iCtr).SaveAsFile sPathName _
    & .Item(iCtr).FileName
    Next iCtr
    End If
    End With
    DoEvents

    Next oMessage
    SaveAttachments = True
    End Sub
    [/vba]

  2. #2
    Site Admin
    The Princess
    VBAX Guru Anne Troy's Avatar
    Joined
    May 2004
    Location
    Arlington Heights, IL
    Posts
    2,530
    Location
    Hi, Len. Figure I oughtta just clarify...

    You mean selected, say, from a list of messages in your inbox, right? Whether a group selected with shift and/or ctrl keys, right?
    ~Anne Troy

  3. #3
    VBAX Tutor jamescol's Avatar
    Joined
    May 2004
    Location
    Charlotte, NC
    Posts
    251
    Location
    Sure - all you need to do is create an Outlook Selection object and loop through it instead of the entire folder. I haven't tested it, but the modifications below should do what you want:

    [vba]
    '************
    'Dim the Outlook.Selection object
    Dim oSel as Outlook.Selection
    '***********************[/vba]

    .
    [vba]
    Set oFldrSbSbSb = oFldrSbSb.Folders("Weekend Asking")
    '*******************
    'Begin changes
    'Set the oSel object equal to the selection collection in the folder
    Set oSel = oFldrSBSBSB.Selection

    'Check to see if a selection was made
    If oSel.Count > 0 Then

    For Each oSel In oSel.Items
    Set oMessage = oSel.Item
    With oMessage.Attachments
    iAttachCnt = .Count
    If iAttachCnt > 0 Then
    For iCtr = 1 To iAttachCnt
    .Item(iCtr).SaveAsFile sPathName _
    & .Item(iCtr).FileName
    Next iCtr
    End If
    End With
    DoEvents

    Next oSel

    Else
    'If no selection made
    Msgbox "No selection was made"
    End if
    '***********************
    'End changes[/vba]
    "All that's necessary for evil to triumph is for good men to do nothing."

  4. #4
    VBAX Regular ___'s Avatar
    Joined
    Jun 2004
    Posts
    22
    Location
    Here's what I use, hope it helps.
    [vba]
    Sub SveAtt()
    Dim objOL As Outlook.Application
    Dim objMsg As Object
    Dim objAttachments As Outlook.Attachments
    Dim objSelection As Outlook.Selection
    Dim i As Long
    Dim lngCount As Long
    Dim strFile As String
    Dim strFolder As String

    On Error Resume Next

    Set objOL = CreateObject("Outlook.Application")

    Set objSelection = objOL.ActiveExplorer.Selection

    strFolder = GetTempDir()
    If strFolder = "" Then
    MsgBox "Could not get Temp folder", vbOKOnly
    GoTo ExitSub
    End If

    For Each objMsg In objSelection

    objMsg.UnRead = False
    objMsg.Save

    If objMsg.Class = olMail Then
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
    If lngCount > 0 Then

    For i = lngCount To 1 Step -1
    strFile = objAttachments.Item(i).FileName
    strFile = strFolder & strFile
    objAttachments.Item(i).SaveAsFile strFile
    Next i
    End If
    objMsg.Save
    End If
    Next

    ExitSub:
    Set objAttachments = Nothing
    Set objMsg = Nothing
    Set objSelection = Nothing
    Set objOL = Nothing
    End Sub

    '---------------------------------------

    Private Function GetTempDir() As String
    Const TemporaryFolder = 2

    Dim fso As Scripting.FileSystemObject
    Dim tFolder As Scripting.Folder

    On Error Resume Next

    Set fso = CreateObject("Scripting.FileSystemObject")

    Set tFolder = fso.GetFolder("C:\Documents and Settings\My Name\My Documents\XL\Hrs\Asking\")

    If Err Then
    GetTempDir = ""
    Else
    GetTempDir = LCase(tFolder.Path)

    If Right$(GetTempDir, 1) <> "\" Then
    GetTempDir = GetTempDir & "\"
    End If
    End If

    Set fso = Nothing
    Set tFolder = Nothing
    End Function
    [/vba]
    Last edited by mark007; 06-10-2004 at 08:04 AM. Reason: Replaced code with vba tags...
    Nemo hic adest illius nominis
    ??????????????????
    ??????

  5. #5

    Thanks All

    I was able to get the code working for saving attachments. I did enhance the code a little and added some if statements so now depending on the file name of the attachment the file will save to the proper folder on the Hard Drive.
    Thanks to all for the HELP!

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •