SELECT * FROM Vzakladke.net

Статьи об автоматизации и программировании


Регистрация входящих сообщений MS Outlook в MS Access, логирование записей и сохранение вложений

 

 

Для организации записи логов в журнал на базе MS Access из поступающих писем в MS Outlook можно обратиться к внутреннему функционалу MS Office по созданию макросов на VBA. В данной статье предлагается метод регистрации писем без сохранения вложений в базе, но позволяет сохранять вложения в отдельной папке, на которую мы будем давать ссылку через форму в Access. Так как у каждого письма есть свой уникальный идентификатор в почте, мы будем создавать папки с учетом этого идентификатора и давать ссылку из Access на путь, где сохраняются наши файлы. Для чего Вам это решение может потребоваться решайте сами, возможно Вы захотите поиск сделать по базе писем, может структурируете входящую почту в базе и будете там хранить свою переписку или автоматизируете в дальнейшем свои отчеты... как говорится, это уже дело фантазии.

Первым делом, чтобы разобраться как настроить регистрирование входящей почты, нам предстоит определиться в какую базу мы будем сохранять историю и в какую папку будем сохранять вложения. Для этого мы должны создать базу out.accdb на диске например E (название базы или имя диска Вы можете поправить на свои) и в прописать в Outlook следующий программный код

 

 
'////////////////////////////////////////////
' GENERAL EVENTS
'////////////////////////////////////////////


Private WithEvents myOlItems  As Outlook.Items

Private Sub Application_Startup()
    Dim olApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
      Set olApp = Outlook.Application
      Set objNS = olApp.GetNamespace("MAPI")
      Set myOlItems = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub myOlItems_ItemAdd(ByVal item As Object)

On Error GoTo ErrorHandler

  Dim Msg As Outlook.MailItem
  Dim objAtt As Outlook.Attachment
  Dim iBody, iAttachments, iRecipients As String

  If TypeName(item) = "MailItem" Then
    Set Msg = item
    ' Debug.Print Msg.Subject
   
    Dim q As Integer
    'Dim iRecipients, iAttachments As String
    With Msg
     If .Recipients.Count > 0 Then
      For q = 1 To .Recipients.Count
       iRecipients = .Recipients.item(q).Name & "; " & iRecipients
      Next q
     End If
    End With
    
    With Msg
    If .Attachments.Count > 0 Then
     For q = 1 To .Attachments.Count
      Set objAtt = .Attachments(q)
      iAttachments = objAtt.FileName & " | " & iAttachments
     Next q
    End If
    End With
    
    iBody = Replace(RemoveHTML(Msg.Body), "'", "`")

    Dim conn As New ADODB.Connection
    Dim RS As New ADODB.Recordset
    Dim stm As ADODB.Stream

    conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=E:\out.accdb;Persist Security Info=False"
    
    conn.Execute "INSERT INTO ImportOutlook " & _
    " (Subject, Body, Recipients,  " & _
    " SenderName, Recieved, FilesCount, Attachments, N)" & _
    " VALUES ('" & Msg.Subject & "' , '" & iBody & "', '" & iRecipients & "', " & _
    "'" & Msg.SenderName & "', '" & Msg.CreationTime & "', '" & Msg.Attachments.Count & "',  '" & iAttachments & "',  '" & Msg.EntryID & "')"
    
    conn.Close
    
        ' attachments (files)
        Dim MyDateID
        MyDateID = Msg.EntryID 
        DestFolder = "E:\AutoEmails2\"
        'For Each Msg In myFolder.Items.Restrict("[Unread]=TRUE")
        If Msg.Attachments.Count > 0 Then
            If Len(Dir(DestFolder & MyDateID, vbDirectory)) = 0 Then
                   MkDir DestFolder & MyDateID
            End If
            For j = 1 To Msg.Attachments.Count
             Msg.Attachments.item(j).SaveAsFile DestFolder & "\" & MyDateID & "\" & Msg.Attachments.item(j).DisplayName
             
            Next j
        End If
        ' mi.UnRead = False
        'Next
        
  End If

 
ProgramExit:
  Exit Sub
ErrorHandler:
  Debug.Print Err.Number & " - " & Err.Description
  Resume ProgramExit
End Sub

 

Что  мы сделали здесь - мы повесили обработчик событий на отслеживание получения нового непрочитанного письма,  и в этом случае мы записываем его в базу. 

Из тела письма вырезать все теги мы будем следующей функцией, т.е. будем сохранять переписку в формате plain/text:

              
Function RemoveHTML(sString As String) As String
 'MsgBox RemoveHTML("<html><b>And</b><!-- some comment --> <p>then<br/> some</p></html>")
    On Error GoTo Error_Handler
    Dim oRegEx          As Object
 
    Set oRegEx = CreateObject("vbscript.regexp")
 
    With oRegEx
        '.Pattern = "<[^>]+>"    'basic html pattern
        .Pattern = "<!*[^<>]*>"    'html tags and comments
        .Global = True
        .IgnoreCase = True
        .MultiLine = True
    End With
 
    RemoveHTML = oRegEx.Replace(sString, "")
 
Error_Handler_Exit:
    On Error Resume Next
    Set oRegEx = Nothing
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: RemoveHTML" & vbCrLf & _
           "Error Description: " & Err.Description, _
           vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

 

В Access создадим таблицу (например, с именем ImportOutlook), в которой будем хранить наши записи.

CREATE TABLE ImportOutlook
(
 ID AUTOINCREMENT PRIMARY KEY,
 Subject TEXT,
 SenderName TEXT,
 Recipients LONGTEXT,
 Recieved DATE,
 FilesCount INTEGER, 
 Attachments LONGTEXT, 
 Body LONGTEXT, 
 Category TEXT,
 Folder TEXT,
 Subfolder TEXT,
 N  TEXT
)

 

Чтобы просматривать содержимое писем в базе создадим запрос с сортировкой писем по убыванию, и укажем его в форме.

SELECT Subject, SenderName, Recipients, Body, Attachments, FilesCount, Recieved, ID, N
FROM ImportOutlook
ORDER BY ImportOutlook.ID DESC;

 

Чтобы форма была  удобной для просмотра содержимого письма необходимо сделать небольшую доработку, которая позволит просмотр многострочного текста в текстовом поле с содержанием тела письма, поскольку возможность прокрутки колесиком мыши в форме Access в стандартном режиме отсутствует.

Option Compare Database

Private Sub Form_MouseWheel(ByVal Page As Boolean, ByVal Count As Long)
'Прокрутка многострочного TextBox колесом мыши через перемещение курсора
'--------------------------------------------------------------------
Dim i As Integer
Dim x As Integer

On Error GoTo Form_MouseWheelErr

'Проверка на то что курсор стоит в нужном поле
    If Me.ActiveControl.Name <> "Body" Then GoTo Form_MouseWheelBye
    
    'Обработка направления перехода
        Select Case Count
            Case Is < 0 'Прокрутка ВВЕРХ
                x = Count * -1
                For i = 1 To x
                    SendKeys "{UP}"
                Next i
                
            Case Is > 0 'Прокрутка ВНИЗ
                x = Count
                For i = 1 To x
                    SendKeys "{DOWN}"
                Next i
        End Select
 
Form_MouseWheelBye:
    Exit Sub

Form_MouseWheelErr:
    'MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in procedure Form_MouseWheel of VBA Document Form_Movies00Set", vbCritical, "Error!"
    Resume Form_MouseWheelBye
End Sub

 

Чтобы открывать папку с вложениями сохраненными на компьютере из базу мы добавим текстовое поле, на который повесим обработчик клика мыши, папка с вложениями будет открываться как гиперссылка:

 

Private Sub ПолеPath_Click()
Application.FollowHyperlink Me.ПолеPath.Value
End Sub

 

Есть и второй вариант, когда на самом деле стоит задача просто сохранять вложения из писем в определенную папку без записи их в базу Access (допустим нам не нужна регистрация писем), то можно попробовать сделать более простой способ например с сохранением вложений на текущую дату, в этом случае последний поступивший файл будет всегда перезаписывать предыдущий, если у него совпадает имя.

Private Sub Application_NewMail()
  Call Outlook_copyAttachmentsToFolder
End Sub


'====================

Sub Outlook_copyAttachmentsToFolder()
On Error Resume Next
Dim myFolder As Outlook.MAPIFolder
Dim mi As MailItem
DestFolder = "E:\AutoEmails\"
Set myFolder = Outlook.Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
 
Dim MyDate
MyDate = Format(Date, "yyyy.mm.dd")
 
For Each mi In myFolder.Items.Restrict("[Unread]=TRUE")
    If mi.Attachments.Count > 0 Then
        If Len(Dir(DestFolder & MyDate, vbDirectory)) = 0 Then
               MkDir DestFolder & MyDate
        End If
    For j = 1 To mi.Attachments.Count
         mi.Attachments.item(j).SaveAsFile DestFolder & "\" & MyDate & "\" & mi.Attachments.item(j).DisplayName
         
    Next j
    End If
    ' mi.UnRead = False
Next
End Sub

 

 

 

Дата публикации: 2017-06-03 11:16:37

VBA

0

Отзывы:

Ваше имя:

Ваш e-mail (необязательно):

Сообщение:

Captcha