Парсинг письма в OutLook

Простенький пример макроса в Outlook, который демонстрирует работу с регулярными выражениями, парсинг тела письма и взаимодействие с Excel.
У меня этот макрос используется для личного учёта заявок на определённые работы. Макрос работает на выделенное письмо (не открытое).
Очень важное замечание — данные вставляются в активную книгу Excel. Так что если открыто несколько книг, то могут быть косяки=) Если Excel не запущен, то откроется целевой файл.
Тело письма выглядит так:

Данные, которые нужны для учёта — дата, время начала, время окончания и адрес сервера

Sub ServerNameSelect()
    Dim DoW As String 'Дата начала работ
    Dim lastrow As Long 'переменная поиска последней строки в Excel
    
    Dim olItem As Outlook.MailItem 'переменная, определяющая письмо
    Dim sText As String 'массив данных для поиска соответствий регекспов
    
    Dim Excel As Object
    Dim ExcelBook As Object
    
    Set olItem = ActiveExplorer.Selection.Item(1)
    sText = olItem.Body
    On Error Resume Next
    DoW = CStr(Year(Now))
    Set Excel = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        Set Excel = CreateObject("Excel.Application")
        Excel.Visible = True
        Set ExcelBook = Excel.Workbooks.Open("C:\test\works.xlsm")
        Set worksheet = Excel.Application.ActiveSheet
        lastrow = worksheet.Cells(worksheet.Rows.Count, 1).End(xlUp).Row + 1
        worksheet.Cells(lastrow, 4).Value = SN(sText)
        worksheet.Cells(lastrow, 1).Value = CDate(WT(sText) & " " & DoW)
        worksheet.Cells(lastrow, 2).Value = TB(sText)
        worksheet.Cells(lastrow, 3).Value = TE(sText)
    Else
        Set worksheet = Excel.Application.ActiveSheet
        lastrow = worksheet.Cells(worksheet.Rows.Count, 1).End(xlUp).Row + 1
        worksheet.Cells(lastrow, 4).Value = SN(sText)
        worksheet.Cells(lastrow, 1).Value = CDate(WT(sText) & " " & DoW)
        worksheet.Cells(lastrow, 2).Value = TB(sText)
        worksheet.Cells(lastrow, 3).Value = TE(sText)
    End If
    On Error GoTo 0
    
    
    'MsgBox (SN(sText) & vbCr & WT(sText) & vbCr & TB(sText) & vbCr & TE(sText))
End Sub
 'Адрес инстанса
Function SN(strData As String) As String
    Dim RE As Object, REMatches As Object
     
    Set RE = CreateObject("vbscript.regexp")
    With RE
        .MultiLine = True
        .Global = True
        .IgnoreCase = True
        .Pattern = "(\w{2}\-\w{3}\-\w\d+\\\w+)"
    End With
     
    Set REMatches = RE.Execute(strData)
    SN = REMatches(0)
     Exit Function
     
End Function
'Дата работ
Function WT(strData As String) As String
    Dim RE As Object, REMatches As Object
     
    Set RE = CreateObject("vbscript.regexp")
    With RE
        .MultiLine = True
        .Global = True
        .IgnoreCase = True
        .Pattern = "(\d{1,2}\s[\wа-яА-ЯёЁ]{3,10})"
    End With
     
    Set REMatches = RE.Execute(strData)
    WT = REMatches(0)
    Exit Function
     
End Function
'Время начала
Function TB(strData As String) As String
    Dim RE As Object, REMatches As Object
     
    Set RE = CreateObject("vbscript.regexp")
    With RE
        .MultiLine = True
        .Global = True
        .IgnoreCase = True
        .Pattern = "(\d{2}\:\d{2})"
    End With
     
    Set REMatches = RE.Execute(strData)
    TB = REMatches(0)
     Exit Function
     
End Function
'Время окончания
Function TE(strData As String) As String
    Dim RE As Object, REMatches As Object
     
    Set RE = CreateObject("vbscript.regexp")
    With RE
        .MultiLine = True
        .Global = True
        .IgnoreCase = True
        .Pattern = "(\d{2}\:\d{2})"
    End With
     
    Set REMatches = RE.Execute(strData)
    TE = REMatches(1)
     Exit Function
     
End Function


Макрос не лишён недостатков, но общие принципы должны быть понятны=)

ЗЫ: макросом пользуюсь уже месяцев 7.
для работы необходимо подключить следующие библиотеки

0 комментариев

Только зарегистрированные и авторизованные пользователи могут оставлять комментарии.