Macro – Outlook – Save as Text

Thanks to Google and many Microsoft Forum participants!
This is just a part of QAWeb's participation in the Open Source "communal" help and "leveraging" in the Internet community.
Sub SaveSelectedAsTXT()

 Dim myItem As Outlook.Inspector

Dim myOlExp As Outlook.Explorer  '
Dim myOlSel As Outlook.Selection '
Dim objItem As Object

Dim strname, strSaveToPath As String
Dim x As Integer
' CHANGE / CHOOSE YOUR TARGET FOLDER BELOW.  YOU WILL GET A CHECK FILE SPELLING ERROR IF THE FOLDER DOES NOT EXIST
strSaveToPath = getENV("USERPROFILE") & "\Desktop\"           'CURRENT USER'S DESKTOP
'strSaveToPath = getENV("HOMEPATH") & "\My Documents\txttst\"   'CURRENT USER'S "MY DOCUMENTS\XYZ OR TXTTST OR WHATEVER\" FOLDER, MUST END WITH SLASH
Set myItem = Application.ActiveInspector
Set myOlExp = Application.ActiveExplore
Set myOlSel = myOlExp.Selection
If Not TypeName(myOlExp) = "Nothing" Then

'        Set objItem = myOlExp.CurrentItem

'        strname = stripIllegalChars(objItem.Subject)

 
'Prompt the user for confirmation

 Dim strPrompt As String

 strPrompt = IIf(myOlSel.Count = 1, myOlSel.Count & " Selected Item", myOlSel.Count & " Selected Items")

 strPrompt = strPrompt & " will be saved to " & vbCrLf & strSaveToPath & vbCrLf & _

 "Any files with the same name will be OVERWRITTEN."

 If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then

 'objItem.SaveAs Environ("HOMEPATH") & "\My Documents\" & strname & ".txt", olTXT

 For x = 1 To myOlSel.Count

 strname = stripIllegalChars(myOlSel.Item(x).Subject)

 'MsgTxt = MsgTxt & vbCrLf & myOlSel.Item(x).SenderName & ";"

 'objItem.SaveAs Environ("USERPROFILE") & "\Desktop\" & strname & ".txt", olTXT

 myOlSel.Item(x).Display

 myOlSel.Item(x).SaveAs strSaveToPath & strname & ".txt", olTXT

 myOlSel.Item(x).Close olPromptForSave

 '  myFolder.Items(1).Display

 Next x

 End If

 Else

 MsgBox "There is no current active [Outlook] Explorer."

 End If

End Sub   ' SaveSelectedAsTXT  by [email protected]

Sub SaveAttachmentsToFolder()  'copied from Google search

' This Outlook macro checks a named subfolder in the Outlook Inbox

' (here the "Sales Reports" folder) for messages with attached

' files of a specific type (here file with an "xls" extension)

' and saves them to disk. Saved files are timestamped. The user

' can choose to view the saved files in Windows Explorer.

' NOTE: make sure the specified subfolder and save folder exist

' before running the macro.

 On Error GoTo SaveAttachmentsToFolder_err

' Declare variables

 Dim ns As NameSpace

 Dim Inbox As MAPIFolder

 Dim SubFolder As MAPIFolder

 Dim Item As Object

 Dim Atmt As Attachment

 Dim FileName As String

 Dim i As Integer

 Dim varResponse As VbMsgBoxResult

 Set ns = GetNamespace("MAPI")

 Set Inbox = ns.GetDefaultFolder(olFolderInbox)

 Set SubFolder = Inbox.Folders("Sales Reports") ' Enter correct subfolder name.

 i = 0

' Check subfolder for messages and exit of none found

 If SubFolder.Items.Count = 0 Then

 MsgBox "There are no messages in the Sales Reports folder.", vbInformation, _

 "Nothing Found"

 Exit Sub

 End If

' Check each message for attachments

 For Each Item In SubFolder.Items

 For Each Atmt In Item.Attachments

' Check filename of each attachment and save if it has "xls" extension

 If Right(Atmt.FileName, 3) = "xls" Then

 ' This path must exist! Change folder name as necessary.

 FileName = "C:\Email Attachments\" & _

 Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName

 Atmt.SaveAsFile FileName

 i = i + 1

 End If

 Next Atmt

 Next Item

' Show summary message

 If i > 0 Then

 varResponse = MsgBox("I found " & i & " attached files." _

 & vbCrLf & "I have saved them into the C:\Email Attachments folder." _

 & vbCrLf & vbCrLf & "Would you like to view the files now?" _

 , vbQuestion + vbYesNo, "Finished!")

' Open Windows Explorer to display saved files if user chooses

 If varResponse = vbYes Then

 Shell "Explorer.exe /e,C:\Email Attachments", vbNormalFocus

 End If

 Else

 MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"

 End If

' Clear memory

SaveAttachmentsToFolder_exit:

 Set Atmt = Nothing

 Set Item = Nothing

 Set ns = Nothing

 Exit Sub

' Handle Errors

SaveAttachmentsToFolder_err:

 MsgBox "An unexpected error has occurred." _

 & vbCrLf & "Please note and report the following information." _

 & vbCrLf & "Macro Name: GetAttachments" _

 & vbCrLf & "Error Number: " & Err.Number _

 & vbCrLf & "Error Description: " & Err.Description _

 , vbCritical, "Error!"

 Resume SaveAttachmentsToFolder_exit

End Sub

Private Function getENV(strReturn As String)

 'CALLED BY ChDir getENV("userprofile") & "\Desktop\"

Dim EnvString, Indx, Msg, PathLen    ' Declare variables.

Indx = 1    ' Initialize index to 1.

For Indx = 1 To Len(Environ(Indx)) + 2

 EnvString = Environ(Indx)    ' Get environment

 If UCase(Left(EnvString, Len(strReturn))) = UCase(strReturn) Then

 getENV = Mid(EnvString, Len(strReturn) + 2)

 End If

 Next Indx 'Loop Until EnvString = ""

End Function

Private Function stripIllegalChars(strTest As String)

Dim strTemp, testThis As String

Dim kount As Integer

strTemp = ""

strTest = Trim(strTest)

For kount = 1 To Len(strTest)

testThis = Mid(strTest, kount, 1)

If InStr(".|\/?*:<>'", testThis) > 0 Or Asc(testThis) < 32 Or Asc(testThis) = 34 Or Asc(testThis) > 129 Then

 'strTemp = strTemp & "_"

 Else: strTemp = strTemp & Mid(strTest, kount, 1)

End If

Next kount

stripIllegalChars = strTemp

End Function