Добро пожаловать в форум, Guest  >>   Войти | Регистрация | Поиск | Правила | В избранное | Подписаться
Все форумы / Visual Basic Новый топик    Ответить
 обработка всех входящих писем Outlook  [new]
fiore97
Member

Откуда:
Сообщений: 1
Есть код который при получении письма с заголовком ЗАДАЧА обрабатывает его и отправляет в задачи Outlook. Если получено сразу два-три письма то обрабатывается только одно. Как сделать что бы обрабатывались все входящие?

+ код

Private Sub Application_NewMail()

    Dim myOlApp As New Outlook.Application
    Dim myNameSpace As Outlook.NameSpace
    Dim myInbox As Outlook.MAPIFolder
    Dim myDestFolder As Outlook.MAPIFolder

  
    Dim mailItems As Items
    Dim mailmsg As MailItem
    Dim Sender$
    
    Dim numchar1, numchar2 As Integer
    Dim str1$
    Dim shablon$

    Set mailItems = Application.Session.GetDefaultFolder(olFolderInbox).Items

'    MsgBox TypeName(mailItems.GetLast)
    
'    Sender$ = mailItems.Class
    
' If Not (mailItems.GetFirst Is Nothing) Or Not (mailItems.GetLast Is Nothing) Then
   ' Set mailmsg = mailItems.GetLast ' выбираем последнее
   ' Sender$ = mailmsg.SenderName
' End If
   
   shablon$ = "[Задача]"
   numchar1 = InStr(mailmsg.Subject, shablon$)
  ' MsgBox "Приняли письмо от " & Sender$
If numchar1 > 0 Then
    mailmsg.UnRead = False  ' установить признак "Прочтенное"
'   mailmsg.Delete   ' удалить
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
    Set myDestFolder = myNameSpace.GetDefaultFolder(olFolderTasks)
    'mailmsg.Move myDestFolder
  
'======================================================
  
    Dim olNS As Outlook.NameSpace
    Dim objTask As Outlook.TaskItem

    
    Set olNS = Application.GetNamespace("MAPI")
    Set objTask = Application.CreateItem(olTaskItem)
            
        objTask.Subject = mailmsg.Subject
        objTask.Body = mailmsg.Body
        objTask.Importance = olImportanceHigh
        
        shablon$ = "Дата документа: "
        numchar1 = InStr(mailmsg.Body, shablon$)
    If numchar1 > 0 Then
        numchar2 = InStr(numchar1 + Len(shablon$), mailmsg.Body, ";")
        str1$ = Mid(mailmsg.Body, numchar1 + Len(shablon$), numchar2 - Len(shablon$) - numchar1)
        If Len(str1$) > 0 Then
            objTask.StartDate = str1$
        Else
            objTask.StartDate = mailmsg.SentOn
        End If
    End If
        
        shablon$ = "Срок исполнения: "
        numchar1 = InStr(mailmsg.Body, shablon$)
    If numchar1 > 0 Then
        numchar2 = InStr(numchar1 + Len(shablon$), mailmsg.Body, ";")
        str1$ = Mid(mailmsg.Body, numchar1 + Len(shablon$), numchar2 - Len(shablon$) - numchar1)
        If Len(str1$) > 0 Then
            objTask.DueDate = str1$
        Else
            objTask.DueDate = objTask.StartDate + 10
        End If
    End If
        
        shablon$ = "Дата совещания: "
        numchar1 = InStr(mailmsg.Body, shablon$)
    If numchar1 > 0 Then
        numchar2 = InStr(numchar1 + Len(shablon$), mailmsg.Body, ";")
        str1$ = Mid(mailmsg.Body, numchar1 + Len(shablon$), numchar2 - Len(shablon$) - numchar1)
        If Len(str1$) > 0 Then
            objTask.DueDate = str1$
        Else
            objTask.DueDate = objTask.StartDate + 10
        End If
    End If
        
        shablon$ = "Дата контрольного талона: "
        numchar1 = InStr(mailmsg.Body, shablon$)
    If numchar1 > 0 Then
        numchar2 = InStr(numchar1 + Len(shablon$), mailmsg.Body, ";")
        str1$ = Mid(mailmsg.Body, numchar1 + Len(shablon$), numchar2 - Len(shablon$) - numchar1)
        If Len(str1$) > 0 Then
            objTask.DueDate = str1$
        Else
            objTask.DueDate = objTask.StartDate + 10
        End If
    End If
                                         
        
        shablon$ = "Дата поручения: "
        numchar1 = InStr(mailmsg.Body, shablon$)
    If numchar1 > 0 Then
        numchar2 = InStr(numchar1 + Len(shablon$), mailmsg.Body, ";")
        str1$ = Mid(mailmsg.Body, numchar1 + Len(shablon$), numchar2 - Len(shablon$) - numchar1)
        If Len(str1$) > 0 Then
            objTask.DueDate = str1$
        Else
            objTask.DueDate = objTask.StartDate + 10
        End If
    End If
    
'        shablon$ = "Поручатель: "
'        numchar1 = InStr(mailmsg.Body, shablon$)
'        numchar2 = InStr(numchar1 + Len(shablon$), mailmsg.Body, ";")
'        str1$ = Mid(mailmsg.Body, numchar1 + Len(shablon$), numchar2 - Len(shablon$) - numchar1)
'        If str1$ = "" Then
'        objTask.Owner = str1$
'        End If
        
        objTask.ReminderSet = True
        objTask.ReminderTime = objTask.DueDate + CDate("9:00")
        objTask.Save
        'objTask.Display (True)

'    Call CopyAttachments(olMail, objTask)
    
    Set objTask = Nothing
    Set olNS = Nothing

  End If
  
End Sub


Сообщение было отредактировано: 18 июн 10, 19:03
18 июн 10, 11:10    [8962244]     Ответить | Цитировать Сообщить модератору
 Re: обработка всех входящих писем Outlook  [new]
Игорь Горбонос
Member

Откуда: Днепропетровск
Сообщений: 4236

> Автор: fiore97
> Set mailItems = Application.Session.GetDefaultFolder(olFolderInbox).Items

У тебя здесь получается коллекция содержимого входящей папки вот и поизучай саму коллекцию на предмет получения
подмножеста непрочитанных писем или если такого не найдется, тога сам организовывай цикл по этой коллекции и каждый Итем
проверяй на "непрочитанность" и обрабатываей если он непрочитан :)

Posted via ActualForum NNTP Server 1.4

18 июн 10, 12:37    [8963034]     Ответить | Цитировать Сообщить модератору
 Re: обработка всех входящих писем Outlook  [new]
Игорь Горбонос
Member

Откуда: Днепропетровск
Сообщений: 4236

И ещё, возможно там было что-то ещё, но твоя портянка не располагает созерцать свою внутренную гармонию

Posted via ActualForum NNTP Server 1.4

18 июн 10, 12:38    [8963050]     Ответить | Цитировать Сообщить модератору
 Re: обработка всех входящих писем Outlook  [new]
Shamanus
Member

Откуда: мы пришли, кто мы, куда идем?
Сообщений: 6021
Блог
fiore97,

есть вот такой код

' этот исполняемый код
Sub СохранитьВложения()

On Error Resume Next
Dim income(1000) As String
Dim FolderName As String
Dim Myf(50) As String
Dim data As Date
Dim MonNum As String
msg = 1

Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")


' Тут идет проверка количества оцениваемых сообщений (бежать по всем входящим нет смысла, долго)
Max = myNameSpace.GetDefaultFolder(olFolderInbox).Items.Count + 1
' в частности здесь берется 10 последних сообщений
MesBuffer = 10
If Max < MesBuffer Then MesBuffer = Max - 1
'проверяем больше ли чем 0 сообщений
If Max > 0 Then
' цикл по этим сообщениям
For msg = Max - MesBuffer To Max
' считаем количство вложений
atcount = myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).Attachments.Count
' смотрим тему
subj = myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).Subject
' вот тут нужно установить бесплатную прогу, которая убирает уведомления на чтение адресов
' расположена http://www.mapilab.com/ru/outlook/security прога бесплатна и для коммерческого и для некоммерческого использования

' смотрим ИФО отправителя
SendName = myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).SenderName
' адрес отправителя
Send = myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).SenderEmailAddress

' Если сообщение имеет статус непрочтеное и вложений не равно 0
If myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).UnRead = True And atcount <> 0 Then
' цикл по всем вложениям
For I = 1 To atcount
' наименование вложения
income(msg) = myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).Attachments(1)

' тут можно сделать проверку наименования вложения
' проверка

' задаем место хранения (можно в зависимости от наименования вложения назначить путь по условию
pathOL = "E:\New\"
' Наименование файла вложения Адрес + Тема + НомерСообщения + НомерВложения + НаименованиеВложения (номер сообщения от конца)
MessageName = Send & subj & (Max - msg) & I & income(msg)
' проверяем файл на существование, если он существует в цикле создаем новую версию и ещё раз проверяем
N = 0
Do While Dir(pathOL & MessageName) <> ""
            N = N + 1
            MessageName = N & Send & subj & (Max - msg) & I & income(msg)
Loop
' сохраняем вложение
myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).Attachments(1).SaveAsFile pathOL & MessageName

'End If
Next I
' конец файлов непрочитанных со вложениями
End If
' помечаем сообщение как прочитанное (любое)
myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).UnRead = False
'следующее вложение
Next msg
' очищаем память
Erase income
' завершаем проверку на количество сообщений больше 0
End If

End Sub

доработайте под свою задачу
18 июн 10, 16:57    [8965669]     Ответить | Цитировать Сообщить модератору
 Re: обработка всех входящих писем Outlook  [new]
big-duke
Member

Откуда:
Сообщений: 6813
fiore97
Есть код

Модератор: Кроме кода еще есть теги SRC и spoiler
18 июн 10, 19:04    [8966600]     Ответить | Цитировать Сообщить модератору
 Re: обработка всех входящих писем Outlook  [new]
nikk225
Member

Откуда:
Сообщений: 1
Помогите кто знает! Плиз!!!
Пришло письмо в оутлок седьмой и сплошная абракодабра. кодировку где поменять не могу найти уже пол дня роюсь. Сколько раз не просил переслать письмо приходит абракодабра. Вот пример:
в 19:39, Мирисёва Оксана
24 июн 10, 12:32    [8993654]     Ответить | Цитировать Сообщить модератору
 Re: обработка всех входящих писем Outlook  [new]
Игорь Горбонос
Member

Откуда: Днепропетровск
Сообщений: 4236

> Автор: nikk225
> в 19:39, Мирисёва Оксана

Это юникод, ищи кнопку с надписью "кодировка"

Posted via ActualForum NNTP Server 1.4

24 июн 10, 13:00    [8994018]     Ответить | Цитировать Сообщить модератору
Между сообщениями интервал более 1 года.
 Re: обработка всех входящих писем Outlook  [new]
Алексей Уникальный без номера
Member

Откуда:
Сообщений: 1
Shamanus,

В outlook не сильно разбираюсь что к чему.

очень заинтересовал приведенный вами код у меня та-же задача что и у создателя темы

Shamanus
' этот исполняемый код
Sub СохранитьВложения()

On Error Resume Next
Dim income(1000) As String
Dim FolderName As String
Dim Myf(50) As String
Dim data As Date
Dim MonNum As String
msg = 1

Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")


' Тут идет проверка количества оцениваемых сообщений (бежать по всем входящим нет смысла, долго)
Max = myNameSpace.GetDefaultFolder(olFolderInbox).Items.Count + 1
' в частности здесь берется 10 последних сообщений
MesBuffer = 10
If Max < MesBuffer Then MesBuffer = Max - 1
'проверяем больше ли чем 0 сообщений
If Max > 0 Then
' цикл по этим сообщениям
For msg = Max - MesBuffer To Max
' считаем количство вложений
atcount = myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).Attachments.Count
' смотрим тему
subj = myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).Subject
' вот тут нужно установить бесплатную прогу, которая убирает уведомления на чтение адресов
' расположена http://www.mapilab.com/ru/outlook/security прога бесплатна и для коммерческого и для некоммерческого использования

' смотрим ИФО отправителя
SendName = myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).SenderName
' адрес отправителя
Send = myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).SenderEmailAddress

' Если сообщение имеет статус непрочтеное и вложений не равно 0
If myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).UnRead = True And atcount <> 0 Then
' цикл по всем вложениям
For I = 1 To atcount
' наименование вложения
income(msg) = myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).Attachments(1)

' тут можно сделать проверку наименования вложения
' проверка

' задаем место хранения (можно в зависимости от наименования вложения назначить путь по условию
pathOL = "E:\New\"
' Наименование файла вложения Адрес + Тема + НомерСообщения + НомерВложения + НаименованиеВложения (номер сообщения от конца)
MessageName = Send & subj & (Max - msg) & I & income(msg)
' проверяем файл на существование, если он существует в цикле создаем новую версию и ещё раз проверяем
N = 0
Do While Dir(pathOL & MessageName) <> ""
N = N + 1
MessageName = N & Send & subj & (Max - msg) & I & income(msg)
Loop
' сохраняем вложение
myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).Attachments(1).SaveAsFile pathOL & MessageName

'End If
Next I
' конец файлов непрочитанных со вложениями
End If
' помечаем сообщение как прочитанное (любое)
myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).UnRead = False
'следующее вложение
Next msg
' очищаем память
Erase income
' завершаем проверку на количество сообщений больше 0
End If

End Sub


все просто замечательно за одним маленьким исключение если данный код загнать в событие получение нового письма то он начинает висеть мне нужно максимально возможно разгрузить процессы выполнения так как на почтовый яшик в котором будет выполняться макрос приходят письма от 500 метров частями а пропускная способность канала 100 метров сами понимаете вся доступная оперативка почты сосредоточена на принятии письма и его обработка тоже съест что-то по времени ограничений нет но желательно чтобы решение не могло привести к зависанию на весь день подскажите как упростить данный код или провести через другое событие.
1 июл 14, 11:05    [16242314]     Ответить | Цитировать Сообщить модератору
Все форумы / Visual Basic Ответить