'---------------------------------------------------------------------------------
' The sample scripts are not supported under any Microsoft standard support
' program or service. The sample scripts are provided AS IS without warranty
' of any kind. Microsoft further disclaims all implied warranties including,
' without limitation, any implied warranties of merchantability or of fitness for
' a particular purpose. The entire risk arising out of the use or performance of
' the sample scripts and documentation remains with you. In no event shall
' Microsoft, its authors, or anyone else involved in the creation, production, or
' delivery of the scripts be liable for any damages whatsoever (including,
' without limitation, damages for loss of business profits, business interruption,
' loss of business information, or other pecuniary loss) arising out of the use
' of or inability to use the sample scripts or documentation, even if Microsoft
' has been advised of the possibility of such damages.
'---------------------------------------------------------------------------------
Option Explicit
' *****************
' For Outlook 2010.
' *****************
#If VBA7 Then
' The window handle of Outlook.
Private lHwnd As LongPtr
' /* API declarations. */
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
' *****************************************
' For the previous version of Outlook 2010.
' *****************************************
#Else
' The window handle of Outlook.
Private lHwnd As Long
' /* API declarations. */
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
#End If
' The class name of Outlook window.
Private Const olAppCLSN As String = "rctrl_renwnd32"
' Windows desktop - the virtual folder that is the root of the namespace.
Private Const CSIDL_DESKTOP = &H0
' Only return file system directories. If the user selects folders that are not part of the file system, the OK button is grayed.
Private Const BIF_RETURNONLYFSDIRS = &H1
' Do not include network folders below the domain level in the dialog box's tree view control.
Private Const BIF_DONTGOBELOWDOMAIN = &H2
' The maximum length for a path is 260 characters.
Private Const MAX_PATH = 260
' ######################################################
' Returns the number of attachements in the selection.
' ######################################################
Public Function SaveAttachmentsFromSelection() As Long
Dim objFSO As Object ' Computer's file system object.
Dim objShell As Object ' Windows Shell application object.
Dim objFolder As Object ' The selected folder object from Browse for Folder dialog box.
Dim objItem As Object ' A specific member of a Collection object either by position or by key.
Dim selItems As Selection ' A collection of Outlook item objects in a folder.
Dim atmt As Attachment ' A document or link to a document contained in an Outlook item.
Dim strAtmtPath As String ' The full saving path of the attachment.
Dim strAtmtFullName As String ' The full name of an attachment.
Dim strAtmtName(1) As String ' strAtmtName(0): to save the name; strAtmtName(1): to save the file extension. They are separated by dot of an attachment file name.
Dim strAtmtNameTemp As String ' To save a temporary attachment file name.
Dim intDotPosition As Integer ' The dot position in an attachment name.
Dim atmts As Attachments ' A set of Attachment objects that represent the attachments in an Outlook item.
Dim lCountEachItem As Long ' The number of attachments in each Outlook item.
Dim lCountAllItems As Long ' The number of attachments in all Outlook items.
Dim strFolderPath As String ' The selected folder path.
Dim blnIsEnd As Boolean ' End all code execution.
Dim blnIsSave As Boolean ' Consider if it is need to save.
Dim sFileEmail As String ' TXT Email data File Name
Dim sFileAttachment As String ' TXT Attachment data File Name
Dim sFileBodyText As String ' TXT For Email body
Dim sBody As String ' Email Body
Dim i As Long
blnIsEnd = False
blnIsSave = False
lCountAllItems = 0
i = 0
Set selItems = ActiveExplorer.Selection
If Err.Number = 0 Then
' Get the handle of Outlook window.
lHwnd = FindWindow(olAppCLSN, vbNullString)
If lHwnd <> 0 Then
' /* Create a Shell application object to pop-up BrowseForFolder dialog box. */
Set objShell = CreateObject("Shell.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objShell.BrowseForFolder(lHwnd, "Select folder to save attachments:", _
BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN, CSIDL_DESKTOP)
' /* Failed to create the Shell application. */
If Err.Number <> 0 Then
MsgBox "Run-time error '" & CStr(Err.Number) & " (0x" & CStr(Hex(Err.Number)) & ")':" & vbNewLine & _
Err.Description & ".", vbCritical, "Error from Attachment Saver"
blnIsEnd = True
GoTo PROC_EXIT
End If
If objFolder Is Nothing Then
strFolderPath = ""
blnIsEnd = True
GoTo PROC_EXIT
Else
strFolderPath = CGPath(objFolder.Self.Path)
sFileEmail = strFolderPath & "PST_Report.txt"
sFileAttachment = strFolderPath & "ATT_Report.txt"
sFileBodyText = strFolderPath & "BodyText_Report.txt"
Open sFileEmail For Output As #1
Print #1, "EntryID,Importance,Subject,From,Sender_Name,CC,To,Received,Message_Size," & _
"Created,Modified,AttachmentsCount"
Open sFileAttachment For Output As #2
Print #2, "EntryID,Attachment_FileName,Attachment_Location,Attachment_Link"
Open sFileBodyText For Output As #3
Print #3, "EntryID,BodyText"
' /* Go through each item in the selection. */
For Each objItem In selItems
i = i + 1
On Error Resume Next
sBody = Left(F_Body(objItem.Body), 10000)
On Error GoTo 0
Print #3, objItem.EntryID & "," & """" & sBody & """"
On Error Resume Next
Print #1, objItem.EntryID & "," & objItem.Importance & "," & """" & objItem.Subject & """" & "," & _
objItem.SenderEmailAddress & "," & """" & objItem.SenderName & """" & "," & """" & objItem.CC & """" & _
"," & """" & objItem.To & """" & "," & objItem.ReceivedTime & "," & _
objItem.Size & "," & objItem.CreationTime & "," & objItem.LastModificationTime & "," & CStr(lCountEachItem)
If Err.Number <> 0 Then
On Error GoTo 0
Print #1, objItem.EntryID & "," & objItem.Importance & "," & """" & objItem.Subject & """"
Debug.Print objItem.EntryID & "," & objItem.Importance & "," & """" & objItem.Subject & """" & "Err1"
End If
On Error GoTo 0
On Error Resume Next
lCountEachItem = objItem.Attachments.Count
If Err.Number <> 0 Then
On Error GoTo 0
lCountEachItem = 0
Debug.Print objItem.EntryID & "," & objItem.Importance & "," & """" & objItem.Subject & """" & "Err2"
End If
On Error GoTo 0
' /* If the current item contains attachments. */
If lCountEachItem > 0 Then
Set atmts = objItem.Attachments
' /* Go through each attachment in the current item. */
For Each atmt In atmts
On Error Resume Next
If InStr(1, atmt.FileName, ".") > 0 _
And Err.Number = 0 Then
Print #2, objItem.EntryID & "," & atmt.FileName & "," & strFolderPath & "," & strFolderPath & atmt.FileName
' Get the full name of the current attachment.
strAtmtFullName = atmt.FileName
' Find the dot postion in atmtFullName.
intDotPosition = InStrRev(strAtmtFullName, ".")
' Get the name.
strAtmtName(0) = Left$(strAtmtFullName, intDotPosition - 1)
' Get the file extension.
strAtmtName(1) = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition)
' Get the full saving path of the current attachment.
strAtmtPath = strFolderPath & atmt.FileName
' /* If the length of the saving path is not larger than 260 characters.*/
If Len(strAtmtPath) <= MAX_PATH Then
' True: This attachment can be saved.
blnIsSave = True
' /* Loop until getting the file name which does not exist in the folder. */
Do While objFSO.FileExists(strAtmtPath)
strAtmtNameTemp = strAtmtName(0) & _
Format(Now, "_mmddhhmmss") & _
Format(Timer * 1000 Mod 1000, "000")
strAtmtPath = strFolderPath & strAtmtNameTemp & "." & strAtmtName(1)
' /* If the length of the saving path is over 260 characters.*/
If Len(strAtmtPath) > MAX_PATH Then
lCountEachItem = lCountEachItem - 1
' False: This attachment cannot be saved.
blnIsSave = False
Exit Do
End If
Loop
' /* Save the current attachment if it is a valid file name. */
If blnIsSave Then atmt.SaveAsFile strAtmtPath
Else
lCountEachItem = lCountEachItem - 1
End If
ElseIf Err.Number > 0 Then
On Error GoTo 0
Print #2, objItem.EntryID & "," & "Error" & "," & strFolderPath
Else
On Error GoTo 0
Print #2, objItem.EntryID & "," & atmt.FileName & "," & strFolderPath
End If
On Error GoTo 0
Next
End If
' Count the number of attachments in all Outlook items.
lCountAllItems = lCountAllItems + lCountEachItem
Next
Close #3
Close #2
Close #1
End If
Else
MsgBox "Failed to get the handle of Outlook window!", vbCritical, "Error from Attachment Saver"
blnIsEnd = True
GoTo PROC_EXIT
End If
' /* For run-time error:
' The Explorer has been closed and cannot be used for further operations.
' Review your code and restart Outlook. */
Else
MsgBox "Please select an Outlook item at least.", vbExclamation, "Message from Attachment Saver"
blnIsEnd = True
End If
PROC_EXIT:
SaveAttachmentsFromSelection = lCountAllItems
' /* Release memory. */
If Not (objFSO Is Nothing) Then Set objFSO = Nothing
If Not (objItem Is Nothing) Then Set objItem = Nothing
If Not (selItems Is Nothing) Then Set selItems = Nothing
If Not (atmt Is Nothing) Then Set atmt = Nothing
If Not (atmts Is Nothing) Then Set atmts = Nothing
' /* End all code execution if the value of blnIsEnd is True. */
If blnIsEnd Then End
If lCountAllItems > 0 Then
MsgBox CStr(lCountAllItems) & " attachment(s) was(were) saved successfully from " & i & " Emails.", vbInformation, "Message from Attachment Saver"
Else
MsgBox "No attachment(s) in the selected Outlook items.", vbInformation, "Message from Attachment Saver"
End If
End Function
' #####################
' Convert general path.
' #####################
Public Function CGPath(ByVal Path As String) As String
If Right(Path, 1) <> "\" Then Path = Path & "\"
CGPath = Path
End Function
' ######################################
' Run this macro for saving attachments.
' ######################################
Public Sub ExecuteSaving()
Dim lNum As Long
lNum = SaveAttachmentsFromSelection
End Sub
Public Function F_Body(sBody As String)
'Remove Vertical Tabs
sBody = Replace(sBody, Chr(13), "")
'Remove Horizontal Tabs
sBody = Replace(sBody, Chr(9), "")
'Remove new line
sBody = Replace(sBody, Chr(10), "")
'Remove 'excessive' spaces
Do While InStr(1, sBody, " ") > 0
sBody = Replace(sBody, " ", " ")
Loop
F_Body = sBody
End Function