Public Sub SaveMessagesAndAttachments() ' Export for Single Message Dim objOL As Outlook.Application Dim objMsg As Outlook.MailItem 'Object Dim objAttachments As Outlook.Attachments Dim i As Long Dim lngCount As Long Dim StrFile As String Dim StrName As String Dim StrFolderPath As String Dim strDeletedFiles As String Dim sFileType As String Dim enviro As String enviro = CStr(Environ("USERPROFILE")) Dim FSO As Object Dim oldName Set FSO = CreateObject("Scripting.FileSystemObject") On Error Resume Next Set objOL = CreateObject("Outlook.Application") Set objMsg = objOL.ActiveExplorer.Selection.Item(1) StrName = StripIllegalChar(objMsg.subject) StrFolderPath = enviro & "\Documents\" & StrName & "\" If Not FSO.FolderExists(StrFolderPath) Then FSO.CreateFolder (StrFolderPath) End If objMsg.SaveAs StrFolderPath & StrName & ".htm", olHTML Set objAttachments = objMsg.Attachments lngCount = objAttachments.Count If lngCount > 0 Then For i = lngCount To 1 Step -1 StrFile = objAttachments.Item(i).FileName Debug.Print StrFile StrFile = StrFolderPath & StrFile objAttachments.Item(i).SaveAsFile StrFile Next i End If ExitSub: Set objAttachments = Nothing Set objMsg = Nothing Set objSelection = Nothing Set objOL = Nothing End Sub Function StripIllegalChar(StrInput) Dim RegX As Object Set RegX = CreateObject("vbscript.regexp") RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]" RegX.IgnoreCase = True RegX.Global = True StripIllegalChar = RegX.Replace(StrInput, "") ExitFunction: Set RegX = Nothing End Function