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.ActiveExplorer
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 allanwhitworth@yahoo.com
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