Outlook macro help

[supert8ch]

having issues at this part of the macro.

I wish to have the format show up as

MMDDYYYY HHMM Name Subject.msg

(name would be who sent email as showing in Outlook)

I end up getting:

MMDDYYYYY HHMM AMD Subject.msg

Here is the code I found that gets me almost to the right setup.

Sub SaveAsnewname()

'this macro saves selected emails to a chosen location with the format

' "DATE TIME INITIALS message subject", and includes the attachments in it as it is in .msg format Dim Mitem As Outlook.MailItem
Dim prompt As String
Dim name As String
Dim Nname As String
Dim Exp As Outlook.Explorer
Dim sln As Outlook.Selection

Set Exp = Application.ActiveExplorer
Set sln = Exp.Selection
If sln.Count = 0 Then
MsgBox "No objects selected."
Else
myPath = BrowseForFolder("\\")

Set Mitem = Outlook.ActiveExplorer.Selection.Item(1)



Nname = InputBox("Please enter subject or leave blank for email subject line(S) Please note THIS WILL GIVE ALL SELECTED EMAILS THE SAME TITLE, therefore they will only be distinguishable by date and time.")

For Each Mitem In sln


If Mitem.Class = olMail Then
If Nname = "" Then
name = Mitem.subject
Else
name = Nname
End If

(removed code)

If myPath = False Then
MsgBox "No directory chosen !", vbExclamation
Else
Mitem.SaveAs myPath & "\" & Format(Mitem.ReceivedTime, "MMDDYYYY HHMM") & " AmB " & name & ".msg", olMSG
End If
Else
MsgBox "You have not saved"
End If

Next Mitem

End If

End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function To Browse for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function

Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False

End Function

 

[Diane Poremsky]

I get AMB:

03132013 1024 AmB TEST.msg

Because the code says so:
mItem.SaveAs myPath & "\" & Format(mItem.ReceivedTime, "MMDDYYYY HHMM") & " AmB " & name & ".msg", olMSG

My test message subject had an invalid filename character (/) and it failed with that - I have code that strips invalid characters if you need it. Save Messages as *.DOC File Type - Slipstick Systems - it's at a the bottom of the code

 

[Diane Poremsky]

I tweaked to it to strip invalid characters - added this code - use mItem.Sender to get the sender's name.

Dim sName As String

sName = Format(mItem.ReceivedTime, "MMDDYYYY HHMM") & " " & mItem.Sender & " " & name
ReplaceCharsForFileName sName, "_"
mItem.SaveAs myPath & "\" & sName & ".msg", olMSG

and the ReplaceCharsForFileName macro from the link I posted.

 

[supert8ch]

I tweaked to it to strip invalid characters - added this code - use mItem.Sender to get the sender's name.

Dim sName As String

sName = Format(mItem.ReceivedTime, "MMDDYYYY HHMM") & " " & mItem.Sender & " " & name
ReplaceCharsForFileName sName, "_"
mItem.SaveAs myPath & "\" & sName & ".msg", olMSG

and the ReplaceCharsForFileName macro from the link I posted.

I had to strip some code as it would not let me post some where around 4000 characters. Here is the code I stripped, it belongs at the (removed code )

' Cleanse illegal characters from subject... :/|*?<>" etc or sharepoint wont have it!
name = Replace(name, "<", "(")
name = Replace(name, ">", ")")
name = Replace(name, "&", "n")
name = Replace(name, "%", "pct")
name = Replace(name, """", "'")
name = Replace(name, "´", "'")
name = Replace(name, "`", "'")
name = Replace(name, "{", "(")
name = Replace(name, "[", "(")
name = Replace(name, "]", ")")
name = Replace(name, "}", ")")
name = Replace(name, " ", "_")
name = Replace(name, " ", "_")
name = Replace(name, " ", "_")
name = Replace(name, "..", "_")
name = Replace(name, ".", "_")
name = Replace(name, "__", "_")
name = Replace(name, ": ", "_")
name = Replace(name, ":", "_")
name = Replace(name, "/", "_")
name = Replace(name, "\", "_")
name = Replace(name, "*", "_")
name = Replace(name, "?", "_")
name = Replace(name, """", "_")
name = Replace(name, "__", "_")
name = Replace(name, "|", "_")



Thank you for your input will try it out later this afternoon.

 

[supert8ch]

View attachment export email script.txt I am not sure where to fix what you was asking. I tried your code but still does not get me the right results. Here is the format of mine.

 

[Diane Poremsky]

Ah - so that is what was cut out of the code.

The code below goes right after the last of the replace names - and the bolded part is what you need to replace or edit. I replaced it with "_" & mItem.Sender & "_" for this format:

03132013_1530_Ben_Smith_RE_Follow_up_from_call.msg
If myPath = False Then
MsgBox "No directory chosen !", vbExclamation
Else
mItem.SaveAs myPath & "\" & Format(mItem.ReceivedTime, "YYYY-MM-DD HHMM") & "AmB " & name & ".msg", olMSG
End If
Else
MsgBox "You have not saved"
End If

 

[Diane Poremsky]

One more thing - you have these 3 removing blanks but 2 have 2 spaces, so spaces don't get removed from mitem.subject.
name = Replace(name, " ", "_")
name = Replace(name, " ", "_")
name = Replace(name, " ", "_")

 

[Diane Poremsky]

Here is a full version of the macro with my edits. If you want to use replace letters in the entire file name, you need to replace the strings after you put the filename together.




View attachment dianes-version.txt

 

[supert8ch]

Not sure if its the version I am running but it does not like this line:

name = Format(mItem.ReceivedTime, "MMDDYYYY HHMM") & " " & mItem.Sender & " " & name

And states:

Run time error '438'

Object doesn't support this property or method.

maybe the mItem.Sender is suppose to be something else. Will try changing it to something else tonight when I get home. Thank you for the help on this. I am new to macros and VB so this helps me in the right direction.

 

[Diane Poremsky]

Use sendername with Outlook 2003, not sender. I forgot to look at your version.

ETA: sendername will work on all versions.

 

[supert8ch]

Well that was the issue. It works great. Now I have to play with it and see if I can get it to work on email directories. I have couple hundred with thousands of emails to output to file.

Thank you for your time on this.