PDA

View Full Version : Solved: Automate Saving Attachments in Selected Message Attachments



Len Piwowar
06-09-2004, 04:22 AM
It isn't Pretty but, it works! :D 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?


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

Anne Troy
06-09-2004, 01:42 PM
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?

jamescol
06-09-2004, 11:49 PM
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:


'************
'Dim the Outlook.Selection object
Dim oSel as Outlook.Selection
'***********************

.

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

___
06-10-2004, 07:45 AM
Here's what I use, hope it helps.

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

Len Piwowar
06-13-2004, 04:41 PM
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! :thumb