Hỏi cách chuyển các trường dữ liệu từ Email sang Access (2007)

[Tường_Vi]

Dear các Anh Chị

Ví dụ: Email (2007) mình có
- From: (người gửi)
- Subject (tiểu đề mail)
- Received (thời gian nhận)

Khi nhận được các email từ sender, em muốn update các thông tin này sang một CSDL được lưu tại Access, thì em làm như nào ạh?

Hiện tại, em có thử
- tạo một file blank Access
- tạo 3 trường (from, Subject; Received)
- Có click chuột phải vào tên bảng, chọn Collect and Update Data via E-mail, ....nhưng hiện tại vẫn chưa được

Mong các Anh chỉ giúp

Em cám ơn

 

[Tường_Vi]

Em có sưu tầm được 02 đoạn code sau (chuyển dữ liệu sang file excel) nhưng chạy không được

Đoạn 1: cho vào trong Mail outlook

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String) 
    Dim mai As Object, XLApp As Object 
    Dim intInitial As Integer 
    Dim intFinal As Integer 
    Dim strEntryId As String 
    Dim intLength As Integer 
    Dim Tablo 
    Dim myRow As Long 
     
    Set XLApp = CreateObject("Excel.Application") 
    XLApp.Visible = True 
    XLApp.workbooks.Open "E:\donnees\daniel\mpfe\test.xls" 
    intInitial = 1 
    intLength = Len(EntryIDCollection) 
    intFinal = InStr(intInitial, EntryIDCollection, ",") 
    Do While intFinal <> 0 
        strEntryId = Strings.Mid(EntryIDCollection, intInitial, (intFinal - intInitial)) 
        Set mai = Application.Session.GetItemFromID(strEntryId) 
        Tablo = Split(mai.Subject, " ") 
        addr = mai.SenderEmailAddress 
        XLApp.Run "XLMacro", Tablo, addr 
        intInitial = intFinal + 1 
        intFinal = InStr(intInitial, EntryIDCollection, ",") 
    Loop 
    strEntryId = Strings.Mid(EntryIDCollection, intInitial, (intLength - intInitial) + 1) 
    Set mai = Application.Session.GetItemFromID(strEntryId) 
    Tablo = Split(mai.Subject, " ") 
    addr = mai.SenderEmailAddress 
    XLApp.Run "XLMacro", Tablo, addr 
    XLApp.activeworkbook.Close True 
    XLApp.Quit 
End Sub

Đoạn 2 cho vào file Test (đường dẫn như trên

Sub XLMacro(Tablo, Sender) 
    Dim myRow As Long 
    myRow = ActiveSheet.[A65000].End(xlUp).Row + 1 
    Cells(myRow, 1) = Tablo(0) 
    Cells(myRow, 2) = Tablo(1) 
    Cells(myRow, 3) = Tablo(2) 
    Cells(myRow, 4) = Sender 
End Sub