Option
Explicit
Private
Type MailDataType
AcceptanceDate
As
Date
RequestDate
As
Date
StartDate
As
Date
EndDate
As
Date
DurationPerDay
As
Integer
RequestFor
As
String
End
Type
Private
Sub
Application_NewMail()
Dim
objItems
As
Outlook.Items
Set
objItems = GetNamespace(
"MAPI"
).GetDefaultFolder(olFolderInbox).Items
Set
objItems = objItems.Restrict(
"[UnRead] = True AND [MessageClass] = 'IPM.Note'"
)
Call
objItems.Sort(
"SentOn"
)
Dim
objMailItem
As
Outlook.MailItem
Dim
udtMailData
As
MailDataType
For
Each
objMailItem
In
objItems
udtMailData = EmptyMailDataType()
If
GetMailData(objMailItem.HTMLBody, udtMailData)
Then
Debug.Print
String
(15,
"-"
)
Debug.Print
"AcceptanceDate: "
; udtMailData.AcceptanceDate
Debug.Print
" RequestDate: "
; udtMailData.RequestDate
Debug.Print
" RequestFor: "
;
"'"
; udtMailData.RequestFor;
"'"
Debug.Print
" From: "
; DateValue(udtMailData.StartDate);
"(Start: "
; TimeValue(udtMailData.StartDate);
")"
Debug.Print
" To: "
; udtMailData.EndDate
Else
End
If
Next
End
Sub
Private
Function
GetMailData(MailContentHTML
As
String
,
ByRef
MailData
As
MailDataType)
As
Boolean
Dim
objHTML
As
MSHTML.HTMLDocument
Set
objHTML =
New
MSHTML.HTMLDocument
Call
CallByName(objHTML,
"writeln"
, VbMethod, MailContentHTML)
With
objHTML.DocumentElement
With
.getElementsByTagName(
"TABLE"
)
If
.Length > 0
Then
GetMailData = FetchMailData(.Item(0), MailData)
End
If
End
With
End
With
End
Function
Private
Function
FetchMailData(HTMLTable
As
MSHTML.HTMLTable,
ByRef
MailData
As
MailDataType)
As
Boolean
On
Error
GoTo
ErrHandler
With
CreateObject(
"VBScript.RegExp"
)
.Global =
True
.IgnoreCase =
True
.MultiLine =
True
Dim
str
As
String
str = HTMLTable.PreviousSibling.innerText
.Pattern =
"\bfor\b"
str = .Replace(str,
"for :"
)
.Pattern =
":\s*\b(.+)\b\s*$"
With
.Execute(str)
MailData.AcceptanceDate = DateConv(.Item(0).SubMatches(0))
MailData.RequestFor = .Item(1).SubMatches(0)
MailData.RequestDate = DateConv(.Item(2).SubMatches(0))
End
With
End
With
Dim
tableRow
As
MSHTML.HTMLTableRow
Dim
tableCell
As
MSHTML.HTMLTableCell
Dim
i
As
Long
With
HTMLTable.Rows(1).Cells
For
i = 0
To
.Length - 1
Select
Case
i
Case
0
MailData.StartDate = DateConv(.Item(i).innerText)
Case
1
MailData.EndDate = DateConv(.Item(i).innerText)
Case
2
MailData.DurationPerDay = Trim(.Item(i).innerText)
Case
3
MailData.StartDate = MailData.StartDate + TimeValue(.Item(i).innerText)
End
Select
Next
End
With
FetchMailData =
True
Exit
Function
ErrHandler:
FetchMailData =
False
MailData = EmptyMailDataType()
End
Function
Private
Function
DateConv(Expr
As
String
)
As
Date
With
CreateObject(
"VBScript.RegExp"
)
.Pattern =
"(\d{2})/(\d{2})/(\d{4})"
DateConv = DateValue(.Replace(Expr,
"$3-$1-$2"
))
End
With
End
Function
Private
Function
EmptyMailDataType()
As
MailDataType
End
Function