Sub сохранение_писем(oMailItem As Outlook.MailItem)
    Dim X, i, k As Integer
    Dim oOutlook As Outlook.Application
    Set oOutlook = New Outlook.Application
    Dim oNs As Outlook.NameSpace
    Set oNs = oOutlook.GetNamespace("MAPI")    
    Dim oInbox As Outlook.MAPIFolder
    Set oInbox = oNs.GetDefaultFolder(olFolderInbox)    
    Dim nameaf, namevl, adres, telo, teloo, tema As String
    Dim dateofmailitem As String
Dim objXls As Object
Dim wb As Object
Set objXls = CreateObject("Excel.Application")
Set wb = objXls.workbooks.Open("Y:\2_Рабочие файлы\2.1_ОКР\2.1.1_Реестр скидок\Вложения\Файлы для макроса\Хранилище писем.xlsb")
objXls.Application.Visible = True
    X = 1
    Do While objXls.Cells(X, 1).Value <> 0
        X = X + 1
    Loop
                    'Вызов приложения OutLook
                    Set objOL = CreateObject("Outlook.Application")
                    'Проверяем каждое выбранное письмо на наличие вложений.
                    'Если есть - сохраняем вложения по пути strFolderPath
                    For Each oMailItem In objSelection
                    'Превращаем переменную в коллекцию вложений
                    Set objAttachments = oMailItem.Attachments
                    'Подсчитываем вложения
                    lngCount = objAttachments.Count
                    'Если вложения есть, то...
                    If lngCount > 0 Then
'                    lngCount = 1 'ручная установка количества вложений
                    'Перебираем вложения
                    For k = 1 To lngCount
                    'Получаем имя конкретного вложения
                    namevl = objAttachments.Item(k).FileName
                    objXls.Sheets(1).Cells(X, k + 6).Value = namevl
                    Next k
                    End If
                    Next
    nameaf = oMailItem.SenderName 'имя отправителя
    adres = oMailItem.SenderEmailAddress  'адрес отправителя - работает не корректно. Дает глюки
    teloo = oMailItem.Body 'тело письма
    telo = oMailItem.HTMLBody 'тело письма
    tema = oMailItem.Subject 'тема письма
    dateofmailitem = Format(oMailItem.ReceivedTime, "dd.mm.yyyy hh.ss") 'время письма    
    objXls.Sheets(1).Cells(X, 1).Value = dateofmailitem
    objXls.Sheets(1).Cells(X, 2).Value = nameaf
    objXls.Sheets(1).Cells(X, 3).Value = adres
    objXls.Sheets(1).Cells(X, 4).Value = tema
    objXls.Sheets(1).Cells(X, 5).Value = telo
    objXls.Sheets(1).Cells(X, 6).Value = teloo
    X = X + 1
Set objXls = Nothing
wb.Save
wb.Close
End Sub

save_a(myItem As Outlook.MailItem)
Dim att_count As Integer
    For att_count = 1 To myItem.Attachments.Count
        myItem.Attachments.Item(att_count).SaveAsFile ("Y:\2_Рабочие файлы\2.1_ОКР\2.1.1_Реестр скидок\Вложения\" & myItem.Attachments.Item(att_count).FileName)
    Next
End Sub

Public Sub OpenPDF2()
    Set WshShell = CreateObject("WScript.Shell")
    ChDir ("C:\pdf2txt")
    TestValue = Shell("C:\pdf2txt\YourPage.bat", 1)
End Sub