NguyenDang95
Senior Member
Cũng giống như Excel và nhiều ứng dụng Office khác, Outlook cũng được trang bị khả năng lập trình macro VBA để mở rông thêm nhiều chức năng cho Outlook. Tuy vậy, khác với những ứng dụng Office khác như Word, Excel, v.v, Outlook lại không được trang bị tính năng Macro Recorder (trình ghi lại macro) do đặc thù của ứng dụng này, cho nên chúng ta sẽ mất kha khá thời gian tìm hiểu để có thể viết và triển khai được macro tự động hóa trong Outlook.
Bài viết này giới thiệu một ví dụ về việc sử dụng macro VBA trong Outlook.
Tự động gửi email trả lời kèm theo dữ liệu theo yêu cầu
Giả sử người dùng mong muốn Outlook có khả năng tự động như sau:
Với những dữ kiện trên, chúng ta tiến hành viết macro.
Đầu tiên, từ cửa sổ chính của Outlook, chúng ta chọn tab Developer và chọn Visual Basic để mở cửa sổ soạn thảo code. Trường hợp chưa thấy tab Developer thì có thể làm theo hướng dẫn như sau: https://support.microsoft.com/en-us...oper tab isn't,select the Developer check box.
Tiếp theo, trong cửa sổ soạn thảo code, chúng ta tạo một Class Module mới với tên là "AutoReplyIncomingMail" và nội dung như sau:
Class Module này dùng sự kiện Item_Add, áp dụng cho thư mục Inbox của store mặc định, tức là khi có item mới (chính là email mới) trong thư mục Inbox thì Outlook kích hoạt sự kiện này.
Lưu ý, "store" trong Outlook chính là như hình dưới (nguyendang@danghom...):
Để Outlook bắt sự kiện này, chúng ta cần khai báo cho Class Module "AutoReplyIncomingMail" trong mục ThisOutlookSession
Nhấn phím F5 hoặc khởi động lại Outlook để macro có hiệu lực.
Giải thích:
Phần việc quan trọng nhất của macro này, trích xuất dữ liệu từ tệp Excel, có thể thực hiện được là do Excel cho phép chúng ta thực hiện truy vấn SQL trực tiếp đến tệp Excel mà không cần phải mở tệp. Chính nhờ thao tác này mà chúng ta không cần phải mở tệp Excel và thực hiện những thao tác trích lọc như AutoFilter và Advanced Filter mà chỉ cần một truy vấn SQL duy nhất là có thể giải quyết được vấn đề một cách nhanh gọn.
Nhược điểm của macro này là người dùng phải giữ cho Outlook luôn hoạt động thì macro mới có tác dụng.
Tiến hành chạy thử để xem kết quả:
Bài viết này giới thiệu một ví dụ về việc sử dụng macro VBA trong Outlook.
Tự động gửi email trả lời kèm theo dữ liệu theo yêu cầu
Giả sử người dùng mong muốn Outlook có khả năng tự động như sau:
- Người dùng đang có sẵn một tập dữ liệu, chứa trong một tệp Excel.
- Người khác có thể lấy được dữ liệu từ tệp Excel này dựa vào một tiêu chí nhất định (trong ví dụ này là SBD).
- Khi nhận được email yêu cầu truy vấn dữ liệu từ tệp Excel nói trên từ người yêu cầu, Outlook tự động trích xuất thông tin từ tệp Excel đó, tổ chức dữ liệu thành dạng bảng và gửi trả kết quả cho người yêu cầu.
Với những dữ kiện trên, chúng ta tiến hành viết macro.
Đầu tiên, từ cửa sổ chính của Outlook, chúng ta chọn tab Developer và chọn Visual Basic để mở cửa sổ soạn thảo code. Trường hợp chưa thấy tab Developer thì có thể làm theo hướng dẫn như sau: https://support.microsoft.com/en-us...oper tab isn't,select the Developer check box.
Tiếp theo, trong cửa sổ soạn thảo code, chúng ta tạo một Class Module mới với tên là "AutoReplyIncomingMail" và nội dung như sau:
Code:
Option Explicit
Private WithEvents colItems As Outlook.Items
Private Sub CreateDataTable(ReplyMail As Outlook.MailItem)
Dim objMail As Outlook.MailItem
Dim arrData() As Variant
Dim i As Long, j As Long, a As Long
Dim strSBD As String, strSQL As String
Dim arrSBD() As String
strSBD = Trim(RegexExtract(ReplyMail.Body, "[0-9]{3}[A-Z]"))
If strSBD <> vbNullString Then
arrSBD = Split(strSBD, ",")
strSQL = "SELECT * FROM [Sheet2$A2:J16] WHERE [SBD] LIKE '" & strSBD & "' "
If UBound(arrSBD) > 0 Then
For a = 0 To UBound(arrSBD)
If a = UBound(arrSBD) Then
strSQL = strSQL & "OR [SBD] LIKE '" & arrSBD(a) & "';"
Else: strSQL = strSQL & "OR [SBD] LIKE '" & arrSBD(a) & "' "
End If
Next
End If
arrData = ExecuteSQL(strSQL, "E:\nguyendang_Ex3.xlsm")
Set objMail = ReplyMail.Reply
With objMail
.BodyFormat = olFormatHTML
.HTMLBody = "<html><body><table border=" & Quote("1") & "<tr>"
If Is2DArray(arrData) Then
For i = 0 To UBound(arrData, 2)
.HTMLBody = .HTMLBody & "<th>" & arrData(0, i) & "</th>"
Next
.HTMLBody = .HTMLBody & "</tr><tr>"
For i = 1 To UBound(arrData)
For j = 0 To UBound(arrData, 2)
.HTMLBody = .HTMLBody & "<td>" & arrData(i, j) & "</td>"
Next
.HTMLBody = .HTMLBody & "</tr>"
Next
Else
For i = 0 To UBound(arrData)
.HTMLBody = .HTMLBody & "<th>" & arrData(i) & "</th>"
Next
End If
.HTMLBody = .HTMLBody & "</table></body></html>"
.Display
.Send
End With
Set objMail = Nothing
End If
End Sub
Private Function ExecuteSQL(SQLStatement As String, WorkbookFile As String) As Variant
Dim objCnn As ADODB.Connection
Dim objCmd As ADODB.Command
Dim objRs As ADODB.Recordset
Dim arrResult() As Variant, arrMergedArray() As Variant, arrColumnNames() As Variant
Dim strCnn As String, strColumnName As String
Dim i As Long
strCnn = GetConnectionString(WorkbookFile)
Set objCnn = New ADODB.Connection
With objCnn
.ConnectionString = strCnn
.Open
End With
Set objCmd = New ADODB.Command
With objCmd
.ActiveConnection = objCnn
.CommandText = SQLStatement
On Error Resume Next
Set objRs = .Execute
If Err.Number <> 0 Then
MsgBox Err.Description, vbExclamation, "Error"
Exit Function
End If
End With
If Not objRs Is Nothing Then
On Error Resume Next
arrResult = Transpose2DArray(objRs.GetRows)
ReDim arrColumnNames(0 To objRs.Fields.Count - 1)
For i = 0 To objRs.Fields.Count - 1
arrColumnNames(i) = objRs.Fields.Item(i).Name
Next
If Err.Number <> 0 Then
ExecuteSQL = arrColumnNames
Else
arrMergedArray = PrepareOutputData(arrColumnNames, arrResult)
ExecuteSQL = arrMergedArray
End If
Erase arrColumnNames
Erase arrResult
End If
objRs.Close
objCnn.Close
Set objCnn = Nothing
Set objCmd = Nothing
Set objRs = Nothing
End Function
Private Function PrepareOutputData(ColumnNames As Variant, TableData As Variant)
Dim arrResult() As Variant
Dim i As Long, j As Long
If Is2DArray(TableData) Then
ReDim arrResult(0 To UBound(TableData), 0 To UBound(ColumnNames))
For i = 0 To UBound(ColumnNames)
arrResult(0, i) = ColumnNames(i)
Next
For i = 1 To UBound(TableData)
For j = 0 To UBound(ColumnNames)
arrResult(i, j) = TableData(i, j + 1)
Next
Next
Else
ReDim arrResult(0 To 1, 0 To UBound(ColumnNames))
For i = 0 To UBound(ColumnNames)
arrResult(0, i) = ColumnNames(i)
Next
For j = 0 To UBound(ColumnNames)
arrResult(1, j) = TableData(j + 1)
Next
End If
PrepareOutputData = arrResult
End Function
Private Function Is2DArray(InputArray As Variant) As Boolean
Dim lngMaxColumnIndex As Long
On Error Resume Next
lngMaxColumnIndex = UBound(InputArray, 2)
If Err.Number = 9 Then
Err.Clear
Is2DArray = False
Else: Is2DArray = True
End If
End Function
Private Function GetConnectionString(FileName As String) As String
Dim strConnectionString As String
Select Case GetFileExtension(FileName)
Case ".xlsx"
strConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";Extended Properties='Excel 12.0 Xml;HDR=YES';"
Case ".xlsm"
strConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";Extended Properties='Excel 12.0 Macro;HDR=YES';"
Case ".xlsb"
strConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";Extended Properties='Excel 12.0;HDR=YES';"
Case ".xls"
strConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";Extended Properties='Excel 8.0;HDR=YES';"
End Select
GetConnectionString = strConnectionString
End Function
Private Function GetFileExtension(FileName As String) As String
On Error Resume Next
GetFileExtension = Mid(FileName, InStrRev(FileName, "."))
If Err.Number = 5 Then
GetFileExtension = vbNullString
End If
End Function
Private Function Transpose2DArray(InputArray As Variant) As Variant
Dim arrResult() As Variant
Dim i As Integer, j As Integer
Dim lngMaxColumnIndex As Long
On Error Resume Next
lngMaxColumnIndex = UBound(InputArray, 2)
If Err.Number = 9 Then
Err.Clear
Transpose2DArray = InputArray
Exit Function
End If
ReDim arrResult(1 To UBound(InputArray, 2) + 1, 1 To UBound(InputArray) + 1)
For i = 1 To UBound(InputArray) + 1
For j = 1 To UBound(InputArray, 2) + 1
arrResult(j, i) = InputArray(i - 1, j - 1)
Next
Next
Transpose2DArray = arrResult
End Function
Private Function Quote(Text As String) As String
Quote = Chr(34) & Text & Chr(34)
End Function
Private Function RegexExtract(Value As Variant, Pattern As String) As String
Dim objRegex As Object
Dim objRegexMatch As Object
Dim colRegexMatches As Object
Set objRegex = CreateObject("VBScript.Regexp")
With objRegex
.Pattern = Pattern
.Global = True
.IgnoreCase = False
.MultiLine = True
End With
Set colRegexMatches = objRegex.Execute(Value)
For Each objRegexMatch In colRegexMatches
RegexExtract = RegexExtract & "," & objRegexMatch.Value
Next
Set objRegex = Nothing
Set objRegexMatch = Nothing
Set colRegexMatches = Nothing
End Function
Private Sub Class_Initialize()
Dim objStore As Outlook.Store
Dim objInbox As Outlook.Folder
Set objStore = Application.Session.DefaultStore
Set objInbox = objStore.GetDefaultFolder(olFolderInbox)
Set colItems = objInbox.Items
Set objStore = Nothing
Set objInbox = Nothing
End Sub
Private Sub Class_Terminate()
Set colItems = Nothing
End Sub
Private Sub colItems_ItemAdd(ByVal Item As Object)
Dim objMail As Outlook.MailItem
If TypeOf Item Is Outlook.MailItem Then
Set objMail = Item
Call CreateDataTable(objMail)
End If
Set objMail = Nothing
End Sub
Class Module này dùng sự kiện Item_Add, áp dụng cho thư mục Inbox của store mặc định, tức là khi có item mới (chính là email mới) trong thư mục Inbox thì Outlook kích hoạt sự kiện này.
Lưu ý, "store" trong Outlook chính là như hình dưới (nguyendang@danghom...):
Để Outlook bắt sự kiện này, chúng ta cần khai báo cho Class Module "AutoReplyIncomingMail" trong mục ThisOutlookSession
Code:
Option Explicit
Private AutoReplyIncomingMail As AutoReplyIncomingMail
Private Sub Application_MAPILogonComplete()
Set AutoReplyIncomingMail = New AutoReplyIncomingMail
End Sub
Nhấn phím F5 hoặc khởi động lại Outlook để macro có hiệu lực.
Giải thích:
Phần việc quan trọng nhất của macro này, trích xuất dữ liệu từ tệp Excel, có thể thực hiện được là do Excel cho phép chúng ta thực hiện truy vấn SQL trực tiếp đến tệp Excel mà không cần phải mở tệp. Chính nhờ thao tác này mà chúng ta không cần phải mở tệp Excel và thực hiện những thao tác trích lọc như AutoFilter và Advanced Filter mà chỉ cần một truy vấn SQL duy nhất là có thể giải quyết được vấn đề một cách nhanh gọn.
Nhược điểm của macro này là người dùng phải giữ cho Outlook luôn hoạt động thì macro mới có tác dụng.
Tiến hành chạy thử để xem kết quả: