kiến thức [Outlook VBA] Tự động gửi email trả lời kèm theo dữ liệu theo yêu cầu

NguyenDang95 · Nov 1, 2022

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:

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ả:

kiến thức [Outlook VBA] Tự động gửi email trả lời kèm theo dữ liệu theo yêu cầu

NguyenDang95

Senior Member

Attachments

Similar threads

Share this page