Private Declare Function SHGetSpecialFolderLocation _
Lib "shell32" (ByVal hWnd As Long, _
ByVal nFolder As Long, ppidl As Long) As Long
Private Declare Function SHGetPathFromIDList _
Lib "shell32" Alias "SHGetPathFromIDListA" _
(ByVal Pidl As Long, ByVal pszPath As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)
Dim objAttachments As AttachmentSelection
Private Sub Application_AttachmentContextMenuDisplay( _
ByVal CommandBar As Office.CommandBar, _
ByVal Attachments As AttachmentSelection)
Dim objButton As CommandBarButton
On Error GoTo ErrRoutine
If Attachments.Count > 0 Then
' Get a reference to the selected attachments
' so we can work with them in the
' SaveToDesktop routine.
Set objAttachments = Attachments
' Create a new menu item and place it
' just after the Reply To All button
Set objButton = CommandBar.Controls.Add( _
msoControlButton, , , , True)
' Configure the menu item.
With objButton
.Style = msoButtonIconAndCaption
.Caption = "Save to &Desktop"
.FaceId = 355
' If you place this sample in a class module
' other than ThisOutlookSession, update this
' line of code to ensure that the OnAction
' property contains the correct project,
' class, and routine name.
.OnAction = "Project1.ThisOutlookSession.SaveToDesktop"
End With
End If
EndRoutine:
On Error GoTo 0
Set objButton = Nothing
Exit Sub
ErrRoutine:
MsgBox Err.Number & " - " & Err.Description, _
vbOKOnly Or vbCritical, _
"Application_AttachmentContextMenuDisplay"
GoTo EndRoutine
End Sub
Private Sub Application_ContextMenuClose(ByVal ContextMenu As OlContextMenu)
On Error Resume Next
If ContextMenu = olAttachmentContextMenu Then
' Once the context menu closes, remove the
' object reference to the attachments.
If Not (objAttachments Is Nothing) Then
Set objAttachments = Nothing
End If
End If
On Error GoTo 0
End Sub
Private Sub SaveToDesktop()
Dim lngPidlFound As Long
Dim lngFolderFound As Long
Dim lngPidl As Long
Dim strPath As String
Dim objAttachment As Attachment
Const CSIDL_DESKTOPDIRECTORY = &H10
Const MAX_PATH = 260
Const NOERROR = 0
On Error GoTo ErrRoutine
' Obtain the physical path to the desktop folder
' for the current user.
strPath = Space(MAX_PATH)
lngPidlFound = SHGetSpecialFolderLocation( _
0, CSIDL_DESKTOPDIRECTORY, lngPidl)
If lngPidlFound = NOERROR Then
lngFolderFound = SHGetPathFromIDList(lngPidl, strPath)
If lngFolderFound Then
strPath = Left$(strPath, _
InStr(1, strPath, vbNullChar) - 1)
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
End If
End If
CoTaskMemFree lngPidl
' Save each selected attachment to the
' desktop folder.
If strPath <> "" Then
For Each objAttachment In objAttachments
objAttachment.SaveAsFile strPath & objAttachment.FileName
Next
End If
EndRoutine:
On Error GoTo 0
Set objAttachment = Nothing
Exit Sub