Hi all,

I'm trying to piece together code that allows me to highlight several emails in outlook (2003 or before) to then click a macro which will create a folder on my desktop before saving the selected emails to the created folder.

I am totally untrained and new to Outlook VBA (I've more self taught experience in Word and Excel) but have used the code below together with the MkDir reference to initially create the folder to save to. This manages to save the first email selected into the folder but doesn't save any more of the other emails selected.

Perhaps it's something to do with selection or not having a loop? Like I said I'm new to this. Could someone out there help????

Public Sub SaveEMailasMsg()
MkDir "C:\Documents and Settings\Desktop\Extracted Emails - Created by Outlook Macro"
Dim msg As MailItem
Const strPath As String = "C:\Documents and Settings\Desktop\Extracted Emails - Created by Outlook Macro\" ' set as desired
If Inspectors.Count 0 Then
' Assume the "active" inspector has the message to be saved
Set msg = ActiveInspector.CurrentItem
Else
' Assume the first selected item is the message to be saved
Set msg = ActiveExplorer.Selection(1)
End If
' The above will fail if we try to set msg to a non-MailItem item
' Cleanse illegal characters from subject... :/|*?"
Dim strFileName As String, intCounter As Integer
' Specific substititions
strFileName = Trim(Replace(msg.Subject, ":", ";"))
strFileName = Replace(strFileName, "", "(")
strFileName = Replace(strFileName, "", ")")
strFileName = Replace(strFileName, """", "'")
' Catch-all for the rest
For intCounter = 1 To Len(strFileName)
If InStr(1, "/|*?", Mid(strFileName, intCounter, 1)) 0 Then
Mid(strFileName, intCounter, 1) = "-"
End If
Next
strFileName = Format(msg.SentOn, "yymmdd_") & strFileName & Format(msg.SentOn, "_hhmmss") & ".msg"
msg.SaveAs Path:=strPath & strFileName, Type:=olMSG
Set msg = Nothing
End Sub

Thanks in advance.