ReSQL.ru
     
powered by simpleCommunicator - 2.0.52     © 2025 Programmizd 02
Мобильная версия    Контакт    Правила    FAQ    Помощь
Доб. в избранное | Игнор. тему | Прикреп. тему | Пометить прочит. / непрочит. | Фильтр
Форумы / Visual Basic [игнор отключен] [закрыт для гостей] / обработка всех входящих писем Outlook
8 сообщений из 8, страница 1 из 1
обработка всех входящих писем Outlook
    #36694280
fiore97
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
fiore97
Гость
Есть код который при получении письма с заголовком ЗАДАЧА обрабатывает его и отправляет в задачи Outlook. Если получено сразу два-три письма то обрабатывается только одно. Как сделать что бы обрабатывались все входящие?

 
код
Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
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
...
Рейтинг: 0 / 0
18.06.2010, 11:10
| Ответить | Цитировать | Написать  
обработка всех входящих писем Outlook
    #36694524
Фотография Игорь Горбонос
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Игорь Горбонос
Участник
> Автор: fiore97
> Set mailItems = Application.Session.GetDefaultFolder(olFolderInbox).Items

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

Posted via ActualForum NNTP Server 1.4
...
Рейтинг: 0 / 0
18.06.2010, 12:37
| Ответить | Цитировать | Написать  
обработка всех входящих писем Outlook
    #36694528
Фотография Игорь Горбонос
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Игорь Горбонос
Участник
И ещё, возможно там было что-то ещё, но твоя портянка не располагает созерцать свою внутренную гармонию

Posted via ActualForum NNTP Server 1.4
...
Рейтинг: 0 / 0
18.06.2010, 12:38
| Ответить | Цитировать | Написать  
обработка всех входящих писем Outlook
    #36695260
Фотография Shamanus
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Shamanus
Участник
fiore97,

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

Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
' этот исполняемый код
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

доработайте под свою задачу
...
Рейтинг: 0 / 0
18.06.2010, 16:57
| Ответить | Цитировать | Написать  
обработка всех входящих писем Outlook
    #36695593
Фотография big-duke
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
big-duke
Участник
fiore97Есть код
Модератор: Кроме кода еще есть теги SRC и spoiler
...
Рейтинг: 0 / 0
18.06.2010, 19:04
| Ответить | Цитировать | Написать  
обработка всех входящих писем Outlook
    #36705537
nikk225
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
nikk225
Гость
Помогите кто знает! Плиз!!!
Пришло письмо в оутлок седьмой и сплошная абракодабра. кодировку где поменять не могу найти уже пол дня роюсь. Сколько раз не просил переслать письмо приходит абракодабра. Вот пример:
в 19:39, Мирисёва Оксана
...
Рейтинг: 0 / 0
24.06.2010, 12:32
| Ответить | Цитировать | Написать  
обработка всех входящих писем Outlook
    #36705637
Фотография Игорь Горбонос
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Игорь Горбонос
Участник
> Автор: nikk225
> в 19:39, Мирисёва Оксана

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

Posted via ActualForum NNTP Server 1.4
...
Рейтинг: 0 / 0
24.06.2010, 13:00
| Ответить | Цитировать | Написать  
Период между сообщениями больше года.
обработка всех входящих писем Outlook
    #38684491
Алексей Уникальный без номера
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Алексей Уникальный без номера
Гость
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 метров сами понимаете вся доступная оперативка почты сосредоточена на принятии письма и его обработка тоже съест что-то по времени ограничений нет но желательно чтобы решение не могло привести к зависанию на весь день подскажите как упростить данный код или провести через другое событие.
...
Рейтинг: 0 / 0
01.07.2014, 11:05
| Ответить | Цитировать | Написать  
8 сообщений из 8, страница 1 из 1
Форумы / Visual Basic [игнор отключен] [закрыт для гостей] / обработка всех входящих писем Outlook
Целевая тема:
Создать новую тему:
Автор:
Закрыть
Цитировать
Найденые пользователи ...
Разблокировать пользователей ...
Читали тему (0):
Читали форум (0):
Пользователи онлайн (0):
Польз. соглашение
NoSQL.ru       Новости, Чат       Фотоальбом: Участники, Встречи
Закрыть
start [/forum/topic.php?fid=60&msg=36694528&tid=2156290]:
 0ms
get settings:
 9ms
get forum list:
 13ms
check forum access:
 4ms
check topic access:
 4ms
track hit:
 161ms
get topic data:
 13ms
get forum data:
 3ms
get page messages:
 51ms
get tp. blocked users:
 2ms
others: 13ms
total:  273ms
созд. / загр.: 273ms
x
x
Закрыть


Просмотр
0 / 0
Close
Debug Console [Select Text]