Hi

I am very new to VBA for Outlook.
What I want to do is open a folder called DAR then check if there is emails
if there is save the attachments name as the subject line instead of the
current default one which the sender chose. (At present it is saving it with
a timpstamp which I do not mind but would prefer to have the Subject line as
the saved attachment with a time stamp. ). once it has saved the attachments
then to flag the email up as completed.

Please can you help.

Here is what I have at present.

Sub SaveAttachmentsToFolder()
' This Outlook macro checks a named subfolder in the Outlook Inbox
' (here the "DAR" folder) for messages with attached
' files of a specific type (here file with an "xls" extension)
' and saves them to disk. Saved files are timestamped. The user
' can choose to view the saved files in Windows Explorer.
' NOTE: make sure the specified subfolder and save folder exist
' before running the macro.
On Error GoTo SaveAttachmentsToFolder_err
' Declare variables
Dim ns As NameSpace
Dim inbox As MAPIFolder
Dim DARFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim varResponse As VbMsgBoxResult
Set ns = GetNamespace("MAPI")
Set inbox = ns.GetDefaultFolder(olFolderInbox)
Set DARFolder =
GetNamespace("Mapi").GetFolderFromID("000000005BD8 FFE474F6B24CBE57E135B89B3CB70100961CBE4D472B33428E C4D50A8A7E9ABC000003BC9DB00000")
i = 0

' Check subfolder for messages and exit of none found
If DARFolder.items.Count = 0 Then
MsgBox "There are no messages in the DAR folder.", vbInformation, _
"Nothing Found"
Exit Sub
End If

' Check each message for attachments
For Each Item In DARFolder.items
For Each Atmt In Item.Attachments

' Check filename of each attachment and save if it has "xls" extension
If Right(Atmt.FileName, 3) = "xls" Then
' This path must exist! Change folder name as necessary.
FileName = "C:\Email\" & _
Format(Item.CreationTime, "yyyymmdd_hhnnss_") &
Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next Item

' Show summary message
If i 0 Then
varResponse = MsgBox("I found " & i & " attached files." _
& vbCrLf & "I have saved them into the C:\Email folder." _
& vbCrLf & vbCrLf & "Would you like to view the files now?" _
, vbQuestion + vbYesNo, "Finished!")

' Open Windows Explorer to display saved files if user chooses
If varResponse = vbYes Then
Shell "Explorer.exe /e,C:\Email", vbNormalFocus
End If
Else
MsgBox "I didn't find any attached files in your mail.",
vbInformation, "Finished!"
End If

' Clear memory
SaveAttachmentsToFolder_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub

' Handle Errors
SaveAttachmentsToFolder_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachmentsToFolder_exit
End Sub

Looks like all you need to do is access the Item.Subject property and store
it in your FileName variable!

--
Eric Legault (Outlook MVP, MCDBA, MCTS: Messaging & Collaboration)
Try Picture Attachments Wizard for Outlook:
http://www.collaborativeinnovations.ca
Blog: http://blogs.officezealot.com/legault/


"VBAfunkymonk" wrote:

Hi

I am very new to VBA for Outlook.
What I want to do is open a folder called DAR then check if there is emails
if there is save the attachments name as the subject line instead of the
current default one which the sender chose. (At present it is saving it with
a timpstamp which I do not mind but would prefer to have the Subject line as
the saved attachment with a time stamp. ). once it has saved the attachments
then to flag the email up as completed.

Please can you help.

Here is what I have at present.

Sub SaveAttachmentsToFolder()
' This Outlook macro checks a named subfolder in the Outlook Inbox
' (here the "DAR" folder) for messages with attached
' files of a specific type (here file with an "xls" extension)
' and saves them to disk. Saved files are timestamped. The user
' can choose to view the saved files in Windows Explorer.
' NOTE: make sure the specified subfolder and save folder exist
' before running the macro.
On Error GoTo SaveAttachmentsToFolder_err
' Declare variables
Dim ns As NameSpace
Dim inbox As MAPIFolder
Dim DARFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim varResponse As VbMsgBoxResult
Set ns = GetNamespace("MAPI")
Set inbox = ns.GetDefaultFolder(olFolderInbox)
Set DARFolder =
GetNamespace("Mapi").GetFolderFromID("000000005BD8 FFE474F6B24CBE57E135B89B3CB70100961CBE4D472B33428E C4D50A8A7E9ABC000003BC9DB00000")
i = 0

' Check subfolder for messages and exit of none found
If DARFolder.items.Count = 0 Then
MsgBox "There are no messages in the DAR folder.", vbInformation, _
"Nothing Found"
Exit Sub
End If

' Check each message for attachments
For Each Item In DARFolder.items
For Each Atmt In Item.Attachments

' Check filename of each attachment and save if it has "xls" extension
If Right(Atmt.FileName, 3) = "xls" Then
' This path must exist! Change folder name as necessary.
FileName = "C:\Email\" & _
Format(Item.CreationTime, "yyyymmdd_hhnnss_") &
Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next Item

' Show summary message
If i 0 Then
varResponse = MsgBox("I found " & i & " attached files." _
& vbCrLf & "I have saved them into the C:\Email folder." _
& vbCrLf & vbCrLf & "Would you like to view the files now?" _
, vbQuestion + vbYesNo, "Finished!")

' Open Windows Explorer to display saved files if user chooses
If varResponse = vbYes Then
Shell "Explorer.exe /e,C:\Email", vbNormalFocus
End If
Else
MsgBox "I didn't find any attached files in your mail.",
vbInformation, "Finished!"
End If

' Clear memory
SaveAttachmentsToFolder_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub

' Handle Errors
SaveAttachmentsToFolder_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachmentsToFolder_exit
End Sub