Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 29.07.2018, 03:44   #1
Jadovita_ja
Новичок
Джуниор
 
Регистрация: 29.07.2018
Сообщений: 1
По умолчанию Аутлук

Доброе время суток!
Прошу помощи у знающих людей, есть макрос для оутлук который срабатывает по поучении письма в папку, то есть когда письмо поступает в папку 1 оно автоматически копируется в папку А-1 на жестком диске.
Хотелось бы понять как можно его доработать, чтобы срабатывал он одновременно в нескольких папках(01,02,03) и копировал тоже в несколько (А-1,Б-2,В-3). То есть когда письмо придет в папку 02 - его копия должна попасть в папку Б-2, а 03 - В-3.


Код:
Private WithEvents Items As Outlook.Items
 
Private Sub Application_Startup()
' ппочты = Array("01", "02")
' For i = 0 To Ubaund(ппочты)
  Dim Ns As Outlook.NameSpace
  Set Ns = Application.GetNamespace("MAPI")
  Set mItems = Ns.GetDefaultFolder(olFolderInbox).Folders("01") 'папка из которой копируем
  Set Items = mItems.Items.Restrict("[Unread]=TRUE")
  'For Each Items In Ns.GetDefaultFolder(olFolderInbox).Folders("я").Items.Restrict("[Unread]=TRUE")
' For Each mItems In Ns.GetDefaultFolder(olFolderInbox).Folders(UBound(ппочты))
'Next
End Sub
 
 
Private Sub Items_ItemAdd(ByVal Item As Object)
  If TypeOf Item Is Outlook.MailItem Then
    SaveMailAsFile Item
  End If
  
End Sub
 
 
Private Sub SaveMailAsFile(oMail As Outlook.MailItem)
  Dim dtDate As Date
  Dim sName As String
  Dim sFile As String
  Dim sExt As String
  sPath = "D:\01\"  ' d:\mails
  sExt = ".msg"
  sName = oMail.Subject
  ReplaceCharsForFileName sName, "_"
  dtDate = oMail.ReceivedTime
  sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "-hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & sExt
  oMail.SaveAs sPath & sName, olMSG
End Sub
Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub
_____
Код программы нужно выделять (форматировать) тегами [CODE] (читать FAQ)
Модератор

Последний раз редактировалось Serge_Bliznykov; 29.07.2018 в 09:14.
Jadovita_ja вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
очень нужна помощь скрипт для аутлук ebjik-br Фриланс 2 01.04.2016 09:38