MyTetra Share
Делитесь знаниями!
Автоматическое чтение данных документов Excel из почты
Время создания: 01.08.2020 17:12
Текстовые метки: VBA_Outlook, вложения почты
Раздел: !Закладки - VBA - Outlook

Помогите пожалуйста со скриптом VB, который
1. перебирает почтовые сообщения (по Subject, имени Excel документа в скрепке)
2. найдя нужные параметры читает данные из оперделенной ячейки Excel документа (который в скрепке)
3. складывает эти данные в другой документ Excel


net_Alex_tut,

Разобрался
Написал скрипт
Все работает :
Ищутся непрочтенные письма по теме и типу приложения выбираются аттач и читаются данные
после прочтения данных сообщение помечается как прочитанное

два но:
1) при небольшом количестве непрочтенных сообщений - 6-15 при общем колве в инбох около 300-400 работает норм
если же количество непрочтенных 30-60 начинаются глюки- перескакивает через пачку сообщений в результате куски сообщений нерочтенные
приходится по нескольку раз запускать чтобы все сообщения перебрались
в чем тут дело ?
2) для чтения из эксель файла - аттачмента его нужно открыть что занимет время особенно если док эксель большой
можно ли без открытия эксель файла из него читать данные ?

Const olFolderInbox As Integer = 6
'~~> Path for the attachment
Const AttachmentPath As String = "e:\temp\"


Sub DORscan_1()
    Dim oOlAp As Object, oOlns As Object, oOlInb As Object
    Dim oOlItm As Object, oOlAtch As Object
    Dim wb As Workbook
    Dim i As Integer
    i = 1
    Dim value As Variant
    Dim value1 As Variant
    Dim value2 As Variant
    Dim value3 As Variant
    Dim value4 As Variant
    Dim value5 As Variant
    
    Dim v_date As String
        
    '~~> New File Name for the attachment
    Dim NewFileName As String
    NewFileName = AttachmentPath & "test1.xls"

    '~~> Get Outlook instance
    Set oOlAp = GetObject(, "Outlook.application")
    Set oOlns = oOlAp.GetNamespace("MAPI")
    Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)

    '~~> Check if there are any actual unread emails
    If oOlInb.Items.Restrict("[UnRead] = True").Count = 0 Then
        MsgBox "NO Unread Email In Inbox"
        Exit Sub
    End If

    '~~> Extract the attachment from the 1st unread email
    For Each oOlItm In oOlInb.Items.Restrict("[UnRead] = True")

    
        '~~> Check if the email actually has an attachment
        sSubj = oOlItm.Subject
        If Left(sSubj, 9) = "WD/CD DOR" Then
            If oOlItm.Attachments.Count <> 0 Then
                For Each oOlAtch In oOlItm.Attachments
                           
                        If Left(Right(oOlAtch.Filename, 5), 4) = ".xls" And Left(oOlAtch.Filename, 2) = "WD" Then
                            '~~> Download the attachment
                            oOlAtch.SaveAsFile NewFileName
                            Set wb = Workbooks.Open(NewFileName, UpdateLinks:=0)
                            i = i + 1
                            
                            Sheets("WDDP-A Daily Highlight").Select
                            
                            v_date = Range("L4")
                            value = Range("E33")
                            value1 = Range("E34")
                            
                            
                            Windows("WD DOR.xlsm").Activate
                            Sheets("list1").Select
                            Cells(i, 1).value = v_date
                            Cells(i, 2).value = value
                            Cells(i, 3).value = value1
                            
                            If i = 30 Or i = 100 Or i = 200 Or i = 300 Or i = 400 Then
                                ActiveWorkbook.Save
                            Else
                            End If
                            Application.DisplayAlerts = False
                            Workbooks("test1.xls").Close SaveChanges:=False
                            
                            
                            Else
                           ' MsgBox "attachment is not excel"
                        End If
                        'Exit For
                 Next
            Else
                'MsgBox "The First item doesn't have an attachment"
            End If
        Else
        End If
    
        
        oOlItm.UnRead = False
        'DoEvents
        'oOlItm.Save
    
    
    Next
         
 End Sub
Так же в этом разделе:
 
MyTetra Share v.0.53
Яндекс индекс цитирования