mbmbmbmbmbmb
05-23-2012, 01:35 AM
hiya, guess it's time to delurk..
thanks for the wonderful site, has been a lot of help to me in the past :)
yesterday IT upgraded my computer to windows 7 with Office 2010.
i've had this macro in 2007 which has been a Godsend in making me actually file emails properly.. but i can't seem to get it to work in 2010, tried various iterations of declaring and setting as different things to no avail.. any help greatly appreciated!
Sub SaveAsnewname()
' Simplified from JohnBF's code, and then complicated some more by meeeeee
'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
' 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, "|", "_")
If myPath = False Then
MsgBox "No directory chosen !", vbExclamation
Else
Mitem.SaveAs myPath & "\" & Format(Mitem.ReceivedTime, "YYMMDD 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)
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
thanks for the wonderful site, has been a lot of help to me in the past :)
yesterday IT upgraded my computer to windows 7 with Office 2010.
i've had this macro in 2007 which has been a Godsend in making me actually file emails properly.. but i can't seem to get it to work in 2010, tried various iterations of declaring and setting as different things to no avail.. any help greatly appreciated!
Sub SaveAsnewname()
' Simplified from JohnBF's code, and then complicated some more by meeeeee
'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
' 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, "|", "_")
If myPath = False Then
MsgBox "No directory chosen !", vbExclamation
Else
Mitem.SaveAs myPath & "\" & Format(Mitem.ReceivedTime, "YYMMDD 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)
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