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 |
|
16 | Option 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.
|
42 | Private Const olAppCLSN As String = "rctrl_renwnd32"
|
43 | ' Windows desktop - the virtual folder that is the root of the namespace.
|
44 | Private 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.
|
46 | Private Const BIF_RETURNONLYFSDIRS = &H1
|
47 | ' Do not include network folders below the domain level in the dialog box's tree view control.
|
48 | Private Const BIF_DONTGOBELOWDOMAIN = &H2
|
49 | ' The maximum length for a path is 260 characters.
|
50 | Private Const MAX_PATH = 260
|
51 |
|
52 | ' ######################################################
|
53 | ' Returns the number of attachements in the selection.
|
54 | ' ######################################################
|
55 | Public 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 |
|
181 | PROC_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
|
193 | End Function
|
194 |
|
195 | ' #####################
|
196 | ' Convert general path.
|
197 | ' #####################
|
198 | Public Function CGPath(ByVal Path As String) As String
|
199 | If Right(Path, 1) <> "\" Then Path = Path & "\"
|
200 | CGPath = Path
|
201 | End Function
|
202 |
|
203 | ' ######################################
|
204 | ' Run this macro for saving attachments.
|
205 | ' ######################################
|
206 | Public 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
|
216 | End Sub
|