Senders email address in saved attachment

  • Thread starter Thread starter Mara
  • Start date Start date
M

Mara

Hi,
I'm currently using the below VBA to export all email attachments into one
folder.
I however also need to capture the senders email address, preferrably in the
file name of the saved attachment. Is this possible or are you able to
advise another solution to capture this information?

'<DieseOutlookSitzung>
Public Sub LoopMailFolderByFolderPath()
On Error GoTo ERR_HANDLER
Dim oFld As Outlook.MAPIFolder
Dim obj As Object

Set oFld = GetFolder("Mailbox - ! TSN Credit Approvals\testing")
If Not oFld Is Nothing Then
For Each obj In oFld.Items
If TypeOf obj Is Outlook.MailItem Then
SaveAttachments obj
End If
Next
End If
Exit Sub
ERR_HANDLER:
MsgBox Err.Description, vbExclamation
End Sub

Public Function GetFolder(strFolderPath As String) As Outlook.MAPIFolder
'
' Author: Sue Mosher
'
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim I As Long
On Error Resume Next

strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objNS = Application.Session
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For I = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(I))
If objFolder Is Nothing Then
Exit For
End If
Next
End If

Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
End Function

Public Sub SaveAttachments(ByRef olMail As Outlook.MailItem)
On Error Resume Next
Dim olAtt As Outlook.Attachment
Dim sPath As String
Dim sName As String

sPath = "C:\Documents and Settings\c887954\My Documents\My Documents\NEW
OMR Stuff for Mara\CAS\CAS emailed\"
sPath = sPath & Format(olMail.ReceivedTime, "yyyymmdd_hhnnss_", vbMonday,
vbFirstJan1)


For Each olAtt In olMail.Attachments
sName = olAtt.FileName
'ReplaceCharsForFileName sName, "_"
olAtt.SaveAsFile sPath & sName
Next
End Sub

Private Sub ReplaceCharsForFileName(ByRef sName As String, sChr As String)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
End Sub
'</DieseOutlookSitzung>



Thankyou,
 
Hi,
Managed to find the answer on previous "Excel Postings".
For those interested, I updated the code with:
olAtt.SaveAsFile MyPath & olMi.SenderName & ".xls"
 
Back
Top