Consulting

Results 1 to 3 of 3

Thread: Solved: Automate Saving Message Attachments

  1. #1

    Solved: Automate Saving Message Attachments

    I use win2000 with Office 2000 at work I am new to VBA in outlook but, have a some VB knowledge and have mostly worked with VBA in excel. I receive E-mail messages with an excel sheet attached and have created a rule wizard to place them automatically in a sub folder called (Weekly asking) which is located in a folder named (Overtime Info) in the outlook folder the sheets I receive each week have different revisions ex; wkasking.060704.rev1.xls I clean these out and back up to the local PC hard drive since my outlook pst file is on the server and my space is limited. I would like to create a procedure to automate this. I currently right click and do a save as, I would like to be able to select all the files at one time in the Weekly asking folder and click the macro button and have all the attachments from each message saved to c:\my documents\xl\wk asking folder I wrote a little code from the help file examples but the message had to be opened before I ran the procedure and I could only do one message at a time It would be just as easy to do right click & SaveAs. Also how is the code written for folder objects that are in sub folders? Any help or ideas would be appreciated THANKS IN ADVANCE!

  2. #2
    Site Admin
    The Princess
    VBAX Guru Anne Troy's Avatar
    Joined
    May 2004
    Location
    Arlington Heights, IL
    Posts
    2,530
    Location
    Blatantly stolen:


    [vba]
    Option Explicit
    Private Const MAX_PATH = 255

    Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

    '_____________________

    Public Function SaveAttachments(Optional PathName As String) As Boolean

    Dim oOutlook As Outlook.Application
    Dim oNs As Outlook.NameSpace
    Dim oFldr As Outlook.MAPIFolder
    Dim oMessage As Object
    Dim sPathName As String
    Dim oAttachment As Outlook.Attachment
    Dim iCtr As Integer
    Dim iAttachCnt As Integer

    On Error GoTo ErrHandler

    If PathName = "" Then
    sPathName = GetTempDir
    Else
    sPathName = PathName
    End If

    If Right(sPathName, 1) <> "\" Then sPathName = sPathName & "\"
    If Dir(sPathName, vbDirectory) = "" Then Exit Function

    Set oOutlook = New Outlook.Application
    Set oNs = oOutlook.GetNamespace("MAPI")
    Set oFldr = oNs.GetDefaultFolder(olFolderInbox)
    For Each oMessage In oFldr.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

    ErrHandler:
    Set oMessage = Nothing
    Set oFldr = Nothing
    Set oNs = Nothing
    Set oOutlook = Nothing
    End Function
    '______________

    Public Function GetTempDir() As String
    Dim sRet As String, lngLen As Long
    'create buffer
    sRet = String(MAX_PATH, 0)
    lngLen = GetTempPath(MAX_PATH, sRet)
    If lngLen = 0 Then Err.Raise Err.LastDllError
    GetTempDir = Left$(sRet, lngLen)
    End Function
    [/vba]

    I hope YOU know what to do with it.
    ~Anne Troy

  3. #3
    VBAX Tutor jamescol's Avatar
    Joined
    May 2004
    Location
    Charlotte, NC
    Posts
    251
    Location
    Len,
    If you already have code and just need a way to iterate through all the messages, use this section of the sample Dreamboat posted:

    [vba]
    For Each oMessage In oFldr.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
    [/vba]

    You will need to set you oFldr tp your "Overtime\Weekly Asking" folder, and the sPathName to the "c:\my documents\xl\wk" path.

    Let us know if you need more help putting it all together. If so, post the code you've already written and I'm sure we can get it working like you want.

    Cheers,
    James
    "All that's necessary for evil to triumph is for good men to do nothing."

Posting Permissions

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