· 6 years ago · Dec 19, 2019, 08:44 AM
1'---------------------------------------------------------------------------------
2' The sample scripts are not supported under any Microsoft standard support
3' program or service. The sample scripts are provided AS IS without warranty
4' of any kind. Microsoft further disclaims all implied warranties including,
5' without limitation, any implied warranties of merchantability or of fitness for
6' a particular purpose. The entire risk arising out of the use or performance of
7' the sample scripts and documentation remains with you. In no event shall
8' Microsoft, its authors, or anyone else involved in the creation, production, or
9' delivery of the scripts be liable for any damages whatsoever (including,
10' without limitation, damages for loss of business profits, business interruption,
11' loss of business information, or other pecuniary loss) arising out of the use
12' of or inability to use the sample scripts or documentation, even if Microsoft
13' has been advised of the possibility of such damages.
14'---------------------------------------------------------------------------------
15
16Option Explicit
17
18' *****************
19' For Outlook 2010.
20' *****************
21#If VBA7 Then
22 ' The window handle of Outlook.
23 Private lHwnd As LongPtr
24
25 ' /* API declarations. */
26 Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
27 ByVal lpWindowName As String) As LongPtr
28
29' *****************************************
30' For the previous version of Outlook 2010.
31' *****************************************
32#Else
33 ' The window handle of Outlook.
34 Private lHwnd As Long
35
36 ' /* API declarations. */
37 Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
38 ByVal lpWindowName As String) As Long
39#End If
40
41' The class name of Outlook window.
42Private Const olAppCLSN As String = "rctrl_renwnd32"
43' Windows desktop - the virtual folder that is the root of the namespace.
44Private Const CSIDL_DESKTOP = &H0
45' Only return file system directories. If the user selects folders that are not part of the file system, the OK button is grayed.
46Private Const BIF_RETURNONLYFSDIRS = &H1
47' Do not include network folders below the domain level in the dialog box's tree view control.
48Private Const BIF_DONTGOBELOWDOMAIN = &H2
49' The maximum length for a path is 260 characters.
50Private Const MAX_PATH = 260
51
52' ######################################################
53' Returns the number of attachements in the selection.
54' ######################################################
55Public Function SaveAttachmentsFromSelection() As Long
56 Dim objFSO As Object ' Computer's file system object.
57 Dim objShell As Object ' Windows Shell application object.
58 Dim objFolder As Object ' The selected folder object from Browse for Folder dialog box.
59 Dim objItem As Object ' A specific member of a Collection object either by position or by key.
60 Dim selItems As Selection ' A collection of Outlook item objects in a folder.
61 Dim atmt As Attachment ' A document or link to a document contained in an Outlook item.
62 Dim strAtmtPath As String ' The full saving path of the attachment.
63 Dim strAtmtFullName As String ' The full name of an attachment.
64 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.
65 Dim strAtmtNameTemp As String ' To save a temporary attachment file name.
66 Dim intDotPosition As Integer ' The dot position in an attachment name.
67 Dim atmts As Attachments ' A set of Attachment objects that represent the attachments in an Outlook item.
68 Dim lCountEachItem As Long ' The number of attachments in each Outlook item.
69 Dim lCountAllItems As Long ' The number of attachments in all Outlook items.
70 Dim strFolderpath As String ' The selected folder path.
71 Dim blnIsEnd As Boolean ' End all code execution.
72 Dim blnIsSave As Boolean ' Consider if it is need to save.
73
74 blnIsEnd = False
75 blnIsSave = False
76 lCountAllItems = 0
77
78 On Error Resume Next
79
80 Set selItems = ActiveExplorer.Selection
81
82 If Err.Number = 0 Then
83
84 ' Get the handle of Outlook window.
85 lHwnd = FindWindow(olAppCLSN, vbNullString)
86
87 If lHwnd <> 0 Then
88
89 ' /* Create a Shell application object to pop-up BrowseForFolder dialog box. */
90 Set objShell = CreateObject("Shell.Application")
91 Set objFSO = CreateObject("Scripting.FileSystemObject")
92 Set objFolder = objShell.BrowseForFolder(lHwnd, "Select folder to save attachments:", _
93 BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN, CSIDL_DESKTOP)
94
95 ' /* Failed to create the Shell application. */
96 If Err.Number <> 0 Then
97 MsgBox "Run-time error '" & CStr(Err.Number) & " (0x" & CStr(Hex(Err.Number)) & ")':" & vbNewLine & _
98 Err.Description & ".", vbCritical, "Error from Attachment Saver"
99 blnIsEnd = True
100 GoTo PROC_EXIT
101 End If
102
103 If objFolder Is Nothing Then
104 strFolderpath = ""
105 blnIsEnd = True
106 GoTo PROC_EXIT
107 Else
108 strFolderpath = CGPath(objFolder.Self.Path)
109
110 ' /* Go through each item in the selection. */
111 For Each objItem In selItems
112 lCountEachItem = objItem.Attachments.Count
113
114 ' /* If the current item contains attachments. */
115 If lCountEachItem > 0 Then
116 Set atmts = objItem.Attachments
117
118 ' /* Go through each attachment in the current item. */
119 For Each atmt In atmts
120
121 ' Get the full name of the current attachment.
122 strAtmtFullName = atmt.FileName
123
124 ' Find the dot postion in atmtFullName.
125 intDotPosition = InStrRev(strAtmtFullName, ".")
126
127 ' Get the name.
128 strAtmtName(0) = Left$(strAtmtFullName, intDotPosition - 1)
129 ' Get the file extension.
130 strAtmtName(1) = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition)
131 ' Get the full saving path of the current attachment.
132 strAtmtPath = strFolderpath & atmt.FileName
133
134 ' /* If the length of the saving path is not larger than 260 characters.*/
135 If Len(strAtmtPath) <= MAX_PATH Then
136 ' True: This attachment can be saved.
137 blnIsSave = True
138
139 ' /* Loop until getting the file name which does not exist in the folder. */
140 Do While objFSO.FileExists(strAtmtPath)
141 strAtmtNameTemp = strAtmtName(0) & _
142 Format(Now, "_mmddhhmmss") & _
143 Format(Timer * 1000 Mod 1000, "000")
144 strAtmtPath = strFolderpath & strAtmtNameTemp & "." & strAtmtName(1)
145
146 ' /* If the length of the saving path is over 260 characters.*/
147 If Len(strAtmtPath) > MAX_PATH Then
148 lCountEachItem = lCountEachItem - 1
149 ' False: This attachment cannot be saved.
150 blnIsSave = False
151 Exit Do
152 End If
153 Loop
154
155 ' /* Save the current attachment if it is a valid file name. */
156 If blnIsSave Then atmt.SaveAsFile strAtmtPath
157 Else
158 lCountEachItem = lCountEachItem - 1
159 End If
160 Next
161 End If
162
163 ' Count the number of attachments in all Outlook items.
164 lCountAllItems = lCountAllItems + lCountEachItem
165 Next
166 End If
167 Else
168 MsgBox "Failed to get the handle of Outlook window!", vbCritical, "Error from Attachment Saver"
169 blnIsEnd = True
170 GoTo PROC_EXIT
171 End If
172
173 ' /* For run-time error:
174 ' The Explorer has been closed and cannot be used for further operations.
175 ' Review your code and restart Outlook. */
176 Else
177 MsgBox "Please select an Outlook item at least.", vbExclamation, "Message from Attachment Saver"
178 blnIsEnd = True
179 End If
180
181PROC_EXIT:
182 SaveAttachmentsFromSelection = lCountAllItems
183
184 ' /* Release memory. */
185 If Not (objFSO Is Nothing) Then Set objFSO = Nothing
186 If Not (objItem Is Nothing) Then Set objItem = Nothing
187 If Not (selItems Is Nothing) Then Set selItems = Nothing
188 If Not (atmt Is Nothing) Then Set atmt = Nothing
189 If Not (atmts Is Nothing) Then Set atmts = Nothing
190
191 ' /* End all code execution if the value of blnIsEnd is True. */
192 If blnIsEnd Then End
193End Function
194
195' #####################
196' Convert general path.
197' #####################
198Public Function CGPath(ByVal Path As String) As String
199 If Right(Path, 1) <> "\" Then Path = Path & "\"
200 CGPath = Path
201End Function
202
203' ######################################
204' Run this macro for saving attachments.
205' ######################################
206Public Sub ExecuteSaving()
207 Dim lNum As Long
208
209 lNum = SaveAttachmentsFromSelection
210
211 If lNum > 0 Then
212 MsgBox CStr(lNum) & " attachment(s) was(were) saved successfully.", vbInformation, "Message from Attachment Saver"
213 Else
214 MsgBox "No attachment(s) in the selected Outlook items.", vbInformation, "Message from Attachment Saver"
215 End If
216End Sub