Исходный текст

Option Explicit
Call CopyAttachmentsToDesktop()


'==============================================================================
'Поместить объекты, вложенные в отобранные почтовые сообщения, на Рабочий стол

Sub CopyAttachmentsToDesktop()
        
        Dim FiltMsgs, mess, AddObjs, AttachObj, objCol, qryTemp, RetVal 
        
        'Среди всей почты пользователя отобрать сообщения от Системного администратора
        Set FiltMsgs = ThisApplication.Messages
        With FiltMsgs
                .Filter.From = "SYSADMIN"
                .Filter.To = ThisApplication.CurrentUser.SysName 
                .Filter.On = True 'включить фильтр сообщений
        End With

        'Создать временную объектную переменную objCol типа TDMSObjects
        Set qryTemp = ThisApplication.CreateQuery
        Set objCol = qryTemp.Objects
        
        'Добавить во временную коллекцию все объекты-вложения из почтовых сообщений
        For Each mess In FiltMsgs 
                If mess.Attachments.Count > 0 Then
                        For Each AttachObj In mess.Attachments
                                objCol.Add AttachObj
                        Next
                End If
        Next
        
        'Если коллекция объектов-вложений непустая, спросить пользователя - 
        'надо ли переместить эти объекты на Рабочий стол
        If objCol.Count > 0 Then 
                RetVal = MsgBox("В отобранных почтовых сообщениях (" & FiltMsgs.Count &_
                             ") содержится " & objCol.Count & " объектов-вложений. Поместить их на Рабочий стол?", _
                             vbQuestion & vbYesNo, "Обработка почтовых сообщений")
        Else 
                'Если объектов-вложений нет, то выйти из подпрограммы
                Msgbox "Отобранные почтовые сообщения не содержат вложений."
                Exit Sub
        End If

    'Перемещаем объекты-вложения на Рабочий стол.
    If RetVal <> vbNo Then
            On Error Resume Next
            AddObjs = 0 'Счетчик перемещенных объектов
            For Each AttachObj In objCol
                    ThisApplication.Desktop.Objects.Add AttachObj 'Поместить объект на Рабочий стол
                    MsgBox ("Новый объект-вложение будет перемещен на рабочий стол. Индекс - " & FiltMsgs.Index(AttachObj))
                    If Err <> 0 Then
                            'Сообщить об ошибке перемещения объекта
                            MsgBox "Во время перемещения объекта """ & AttachObj.Description & """" & Chr(13) & _
                                    "произошла ошибка. Возможно, объект уже на Рабочем столе.", vbInformation
                            Exit For
                    Else: AddObjs = AddObjs + 1 'Увеличить счетчик
                    End If
            Next
            'Сообщить о результате операции
            MsgBox AddObjs & " объектов помещено на Рабочий стол.", vbInformation
    End If
    
    'Обнулить объектные переменные
    Set objCol = Nothing
    Set qryTemp  = Nothing
    Set FiltMsgs = Nothing
End Sub 
'==============================================================================