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 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
    
ErrRoutine:
    MsgBox Err.Number & " - " & Err.Description, _
        vbOKOnly Or vbCritical, _
        "SaveToDesktop"
    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