nguyendang95
Thành viên chính thức
- Tham gia
- 25/5/22
- Bài viết
- 71
- Được thích
- 74
Nhân tiện gần đây có bạn hỏi "Làm thế nào để tìm những thư nhận được trong ngày từ Outlook và xuất kết quả tìm kiếm thành một báo cáo Excel hoàn chỉnh, vì yêu cầu công việc rất cần thao tác này" nên tôi xin viết về chủ đề này.
Trường hợp này ta có thể viết macro VBA trong Outlook giúp thống kê một cách tự động và nhanh chóng mà không cần dò tìm và viết thông tin của từng cái email sang Excel một cách thủ công.
Trong một thư mục email không chỉ chứa mỗi email mà còn có những item khác như tập tin đính kèm theo email. Nếu viết vòng lặp For Each hay For Next theo kiểu "nông dân" thì cũng được nhưng sẽ là thảm họa khi trong thư mục có hàng trăm, thậm chí lên đến hàng nghìn email khác nhau và ngày giờ nhận email cũng khác nhau, như thế code sẽ chạy cực kỳ chậm. May thay, Outlook cung cấp cho chúng ta nhiều đối tượng để tìm kiếm item trong Outlook như AdvancedSearch, Items.Restrict, Table, ... bằng truy vấn DASL hay DAV,... giúp cho ra kết quả rất nhanh và chính xác.
Macro dưới đây sử dụng đối tượng Table trong Outlook để tìm kiếm những thư nhận được trong ngày và trả kết quả sang tập tin Excel mới.
Kết quả minh họa sau khi chạy macro:
Trường hợp này ta có thể viết macro VBA trong Outlook giúp thống kê một cách tự động và nhanh chóng mà không cần dò tìm và viết thông tin của từng cái email sang Excel một cách thủ công.
Trong một thư mục email không chỉ chứa mỗi email mà còn có những item khác như tập tin đính kèm theo email. Nếu viết vòng lặp For Each hay For Next theo kiểu "nông dân" thì cũng được nhưng sẽ là thảm họa khi trong thư mục có hàng trăm, thậm chí lên đến hàng nghìn email khác nhau và ngày giờ nhận email cũng khác nhau, như thế code sẽ chạy cực kỳ chậm. May thay, Outlook cung cấp cho chúng ta nhiều đối tượng để tìm kiếm item trong Outlook như AdvancedSearch, Items.Restrict, Table, ... bằng truy vấn DASL hay DAV,... giúp cho ra kết quả rất nhanh và chính xác.
Macro dưới đây sử dụng đối tượng Table trong Outlook để tìm kiếm những thư nhận được trong ngày và trả kết quả sang tập tin Excel mới.
Mã:
Option Explicit
Public Sub CreateSimpleCustomReport()
Dim objolNS As Outlook.NameSpace
Dim objolStore As Outlook.Store
Dim objolFldr As Outlook.Folder
Dim objolTbAllMails As Outlook.Table
Dim objolTbUnreadMails As Outlook.Table
Dim objolRow As Outlook.Row
Dim objolAcc As Outlook.Account
Dim objolcolAccs As Outlook.Accounts
Dim lngRow As Long
Dim Data() As Variant
Dim objXlApp As Object
Dim objXlWb As Object
Dim objxlSh As Object
Dim strFilter As String
Const xlContinuous As Byte = 1
Const xlOpenXMLWorkbook As Byte = 51
strFilter = "@SQL=%today(" & Quote("urn:schemas:httpmail:datereceived") & ")%"
Set objolNS = Application.Session
Set objXlApp = CreateObject("Excel.Application")
With objXlApp
.Visible = True
.DisplayAlerts = False
Set objXlWb = .Workbooks.Add 'Tao t?p tin Excel d? làm báo
End With
Set objolcolAccs = objolNS.Accounts
For Each objolAcc In objolcolAccs 'Duy?t qua t?ng tài kho?n email
Set objolStore = objolAcc.DeliveryStore
Set objolFldr = objolStore.GetDefaultFolder(olFolderInbox) 'Xác d?nh h?p thu Inbox
Set objolTbAllMails = objolFldr.GetTable(strFilter) 'Tìm nh?ng thu dã nh?n trong ngày hôm nay
Set objolTbUnreadMails = objolTbAllMails.Restrict("@SQL=" & Quote("urn:schemas:httpmail:read") & "= 0") 'L?c ra k?t qu? nh?ng thu chua d?c t? k?t qu? tìm ki?m ? trên
With objolTbAllMails.Columns 'Xác d?nh nh?ng thu?c tính c?a thu c?n l?y thông tin
.Add "http://schemas.microsoft.com/mapi/proptag/0x0C1A001E" 'PR_SENDER_NAME
.Add "UnRead" 'Read/Unread, tr? v? ki?u Boolean
.Add "http://schemas.microsoft.com/mapi/proptag/0x10820040" 'PR_LAST_VERB_EXECUTION_TIME
.Add "http://schemas.microsoft.com/mapi/proptag/0x10810003" 'PR_LAST_VERB_EXECUTED
.Add "ReceivedTime" 'Th?i gian nh?n thu
End With
Set objxlSh = objXlWb.Sheets.Add 'Thêm Sheet m?i
With objxlSh
'.Name = objolAcc.SMTPAddress 'Ð?a ch? email
.Range("B2").Value = "Account name: " & objolAcc.SMTPAddress 'Tên ngu?i dùng tài kho?n email
.Range("B3").Value = "Folder: " & objolFldr.Name 'Tên thu m?c Inbox
.Range("B4").Value = "Date: " & Format$(Date, "dd/mm/yyyy")
.Range("B5").Value = "Number of incoming mails: " & objolTbAllMails.GetRowCount
.Range("B6").Value = "Number of unread mails: " & objolTbUnreadMails.GetRowCount
.Range("B8").Value = "Subject"
.Range("C8").Value = "From"
.Range("D8").Value = "Received Time"
.Range("E8").Value = "Read/Unread"
.Range("F8").Value = "Reply/Forward"
.Range("G8").Value = "Reply Time"
End With
lngRow = 9 'Dòng cu?i cùng trong Sheet tru?c khi vi?t d? li?u
With objxlSh 'Ti?n hành d?nh d?ng c?t
.Range("B:G").EntireColumn.AutoFit 'T? d?ng giãn c?t
.Range("B8:G8").Font.Bold = True
.Range("B9").CurrentRegion.Borders.LineStyle = xlContinuous 'Thêm vi?n cho toàn b? b?ng
End With
If objolTbAllMails.GetRowCount > 0 Then 'N?u trong ngày hôm nay nh?n du?c 1 thu tr? lên
Do Until objolTbAllMails.EndOfTable 'Duy?t qua b?ng k?t qu? d? l?y d? li?u
Set objolRow = objolTbAllMails.GetNextRow
Data() = objolRow.GetValues 'Ghi k?t qu? tìm ki?m vào m?ng
With objxlSh 'Ghi d? li?u tìm ki?m t? b?ng ra t?p tin Excel
.Cells(lngRow, 2).Value = Data(1) 'Subject
.Cells(lngRow, 3).Value = Data(5) 'From
.Cells(lngRow, 4).Value = Format$(Data(9), "dd/mm/yyyy hh:mm") 'Received Time
Select Case Data(6) 'Read/Unread
Case True: .Cells(lngRow, 5).Value = "Unread"
Case False: .Cells(lngRow, 5).Value = "Read"
End Select
.Cells(lngRow, 6).Value = LastVerbText(CByte(Data(8))) 'Reply?
.Cells(lngRow, 7).Value = Data(7) 'Reply Time
End With
lngRow = lngRow + 1 'Xuong hang khi da ghi xong mot dong
Loop
With objxlSh
.Range("B:G").EntireColumn.AutoFit
.Range("B9").CurrentRegion.Borders.LineStyle = xlContinuous
.Cells(lngRow + 1, 2).Value = "Date and Time of Report: " & Format$(Date, "dd/mm/yyyy") & " " & Format$(Time, "hh:mm:ss")
End With
Else: objxlSh.Cells(lngRow + 2, 2).Value = "Date and Time of Report: " & Now
End If
Next
With objXlApp
.ScreenUpdating = True
.DisplayAlerts = True
End With
Set objolNS = Nothing
Set objolStore = Nothing
Set objolFldr = Nothing
Set objolTbAllMails = Nothing
Set objolTbUnreadMails = Nothing
Set objolRow = Nothing
Set objXlApp = Nothing
Set objXlWb = Nothing
Set objxlSh = Nothing
Set objolAcc = Nothing
Set objolcolAccs = Nothing
End Sub
Private Function LastVerbText(Value As Byte) As String
Select Case Value
Case 102: LastVerbText = "Reply"
Case 103: LastVerbText = "Reply to all"
Case 104: LastVerbText = "Forward"
Case Else: LastVerbText = "None"
End Select
End Function
Private Function Quote(Text As String) As String
Quote = Chr(34) & Text & Chr(34)
End FunctionKết quả minh họa sau khi chạy macro:
