Code gởi mail từ excel theo danh sách cho sẵn

[LuuGiaPhúc]

Nhờ các anh chị viết dùm đoạn code để gởi mail (em dùng Excel 365) theo quy luật :
Tiêu đề mail : lấy từ ô B1
Nội dung mail: lấy từ ô B2
chữ ký : nếu lấy theo chữ ký mặc định đã tạo sẵn trong outlook được thì tốt, không thì lấy từ nội dung của ô B3

Địa chỉ mail ở ô E4 : để vào mục To
Địa chĩ mail từ E5:E hàng cuối cùng để vào mục Bcc .
Số lượng mail từ E5 trở xuống chưa biết bao nhiêu hàng, tùy theo mỗi lần gởi

Cảm ơn các anh chị

 

[Hoàng Tuấn 868]

Nhờ các anh chị viết dùm đoạn code để gởi mail (em dùng Excel 365) theo quy luật :
Tiêu đề mail : lấy từ ô B1
Nội dung mail: lấy từ ô B2
chữ ký : nếu lấy theo chữ ký mặc định đã tạo sẵn trong outlook được thì tốt, không thì lấy từ nội dung của ô B3

Địa chỉ mail ở ô E4 : để vào mục To
Địa chĩ mail từ E5:E hàng cuối cùng để vào mục Bcc .
Số lượng mail từ E5 trở xuống chưa biết bao nhiêu hàng, tùy theo mỗi lần gởi

Cảm ơn các anh chị

View attachment 301083

Nếu không có gì bất thường thì chắc đến bốn con chín phần trăm ở đây không đáp ứng đủ tất cả các tiêu chí của yêu cầu này.

 

[Châu Bá Thông]

Dưới đây là đoạn code VBA để gửi email từ Excel 365 với các thông tin như bạn đã yêu cầu:

Sub GuiMailTuExcel()
    Dim OutlookApp As Object
    Dim Mail As Object
    Dim cell As Range
    Dim LastRow As Long
    Dim EmailTo As String
    Dim EmailBcc As String

    ' Tạo đối tượng Outlook
    Set OutlookApp=CreateObject("Outlook.Application")
    ' Tạo email mới
    Set Mail = OutlookApp.CreateItem(0)

    With Mail
        ' Thiết lập tiêu đề mail từ ô B1
        .Subject = ThisWorkbook.Sheets("Sheet1").Range("B1").Value
        ' Thiết lập nội dung mail từ ô B2
        .Body = ThisWorkbook.Sheets("Sheet1").Range("B2").Value
        ' Thiết lập chữ ký (nếu có chữ ký mặc định trong Outlook thì sẽ sử dụng, không thì lấy từ ô B3)
        If .BodyFormat = 1 Then ' Kiểm tra nếu định dạng Body là Plain Text
            .Body = .Body & vbCrLf & ThisWorkbook.Sheets("Sheet1").Range("B3").Value
        End If
        ' Thiết lập địa chỉ email người nhận (To) từ ô E4
        .To = ThisWorkbook.Sheets("Sheet1").Range("E4").Value
        ' Tìm hàng cuối cùng có dữ liệu trong cột E để thiết lập Bcc
        LastRow = ThisWorkbook.Sheets("Sheet1").Cells(ThisWorkbook.Sheets("Sheet1").Rows.Count, "E").End(xlUp).Row
        ' Lặp qua từng ô từ E5 đến hàng cuối cùng để thêm vào Bcc
        For Each cell In ThisWorkbook.Sheets("Sheet1").Range("E5:E" & LastRow)
            EmailBcc = EmailBcc & cell.Value & ";"
        Next cell
        ' Loại bỏ dấu ";" cuối cùng
        EmailBcc = Left(EmailBcc, Len(EmailBcc) - 1)
        .BCC = EmailBcc
        ' Gửi email
        .Send
    End With

    ' Dọn dẹp
    Set Mail = Nothing
    Set OutlookApp = Nothing
End Sub

Hãy chắc chắn rằng bạn đã thêm tham chiếu đến thư viện Outlook trong VBA trước khi chạy đoạn code này. Để làm điều này, vào VBA Editor, chọn **Tools** > **References**, sau đó tìm và chọn **Microsoft Outlook 16.0 Object Library**.

Lưu ý: Code này giả định rằng bạn đã có chữ ký mặc định trong Outlook. Nếu không, nó sẽ thêm nội dung của ô B3 vào cuối email như là chữ ký. Đảm bảo rằng bạn đã mở Outlook trước khi chạy macro này để tránh bất kỳ lỗi nào liên quan đến việc tạo đối tượng Outlook. Chúc bạn thành công!

 

[Hoàng Tuấn 868]

Với code này chắc đến năm con chín là sử dụng trí tuệ chưa thông minh và không chạy được.

 

[LuuGiaPhúc]

Dưới đây là đoạn code VBA để gửi email từ Excel 365 với các thông tin như bạn đã yêu cầu:

Sub GuiMailTuExcel()
    Dim OutlookApp As Object
    Dim Mail As Object
    Dim cell As Range
    Dim LastRow As Long
    Dim EmailTo As String
    Dim EmailBcc As String

    ' Tạo đối tượng Outlook
    Set OutlookApp=CreateObject("Outlook.Application")
    ' Tạo email mới
    Set Mail = OutlookApp.CreateItem(0)

    With Mail
        ' Thiết lập tiêu đề mail từ ô B1
        .Subject = ThisWorkbook.Sheets("Sheet1").Range("B1").Value
        ' Thiết lập nội dung mail từ ô B2
        .Body = ThisWorkbook.Sheets("Sheet1").Range("B2").Value
        ' Thiết lập chữ ký (nếu có chữ ký mặc định trong Outlook thì sẽ sử dụng, không thì lấy từ ô B3)
        If .BodyFormat = 1 Then ' Kiểm tra nếu định dạng Body là Plain Text
            .Body = .Body & vbCrLf & ThisWorkbook.Sheets("Sheet1").Range("B3").Value
        End If
        ' Thiết lập địa chỉ email người nhận (To) từ ô E4
        .To = ThisWorkbook.Sheets("Sheet1").Range("E4").Value
        ' Tìm hàng cuối cùng có dữ liệu trong cột E để thiết lập Bcc
        LastRow = ThisWorkbook.Sheets("Sheet1").Cells(ThisWorkbook.Sheets("Sheet1").Rows.Count, "E").End(xlUp).Row
        ' Lặp qua từng ô từ E5 đến hàng cuối cùng để thêm vào Bcc
        For Each cell In ThisWorkbook.Sheets("Sheet1").Range("E5:E" & LastRow)
            EmailBcc = EmailBcc & cell.Value & ";"
        Next cell
        ' Loại bỏ dấu ";" cuối cùng
        EmailBcc = Left(EmailBcc, Len(EmailBcc) - 1)
        .BCC = EmailBcc
        ' Gửi email
        .Send
    End With

    ' Dọn dẹp
    Set Mail = Nothing
    Set OutlookApp = Nothing
End Sub

Hãy chắc chắn rằng bạn đã thêm tham chiếu đến thư viện Outlook trong VBA trước khi chạy đoạn code này. Để làm điều này, vào VBA Editor, chọn **Tools** > **References**, sau đó tìm và chọn **Microsoft Outlook 16.0 Object Library**.

Lưu ý: Code này giả định rằng bạn đã có chữ ký mặc định trong Outlook. Nếu không, nó sẽ thêm nội dung của ô B3 vào cuối email như là chữ ký. Đảm bảo rằng bạn đã mở Outlook trước khi chạy macro này để tránh bất kỳ lỗi nào liên quan đến việc tạo đối tượng Outlook. Chúc bạn thành công!

Cảm ơn bạn đã hướng dẫn, nhưng mình chép đoạn code vào thì nó không hoạt động, không có báo lỗi và củng không có phản ứng gì sảy ra.



sau đó mình có thử sửa dòng code này :
Set OutlookApp=CreateObject("Outlook.Application") thành
Set OutApp = CreateObject("Outlook.Application.16")
nhưng kết quả cũng không có thay đổi gì cả.
Nhờ bạn xem thêm dùm mình nhé

 

[Châu Bá Thông]

Bạn có thể bổ sung một số bẫy lỗi như sau:
(Và nên mở Outlook trước, sau đó hãy chạy code)
Lưu ý: Giả định rằng bạn đang dùng Office 365, Ứng dụng email mặc định của bạn là Outlook 365.

Tham khảo 1 số kiến thức HTML tại đây:

Introduction to HTML

W3Schools offers free online tutorials, references and exercises in all the major languages of the web. Covering popular subjects like HTML, CSS, JavaScript, Python, SQL, Java, and many, many more.

www.w3schools.com

Sub SendMailWithBCC()
On Error Resume Next
'Bỏ qua DDE (Dynamic Data Exchange)
Application.IgnoreRemoteRequests = True

Dim outApp As Object
Dim outMail As Object
Dim mCell As Range
Dim xRow As Long
Dim eTo As String
Dim eCC As String
Dim eBcc As String
Dim eSubject As String
Dim eBody As String
Dim eSignature As String
Dim DefaultSignature As String

With Sheet1
  eTo = .[E4].Value
  eCC = ""
  eSubject = .[B1].Value
  eBody = .[B2].Value
  eSignature = .[B3].Value
  xRow = .Cells(Rows.Count, "E").End(xlUp).Row  '==> Xác định dòng cuối cùng có dữ liệu ở cột E'
  'Nếu dòng cuối này lớn hơn 4, nghĩa là có BCC email.
  If xRow > 4 Then
    For Each mCell In .Range("E5:E" & xRow)    '==> Tạo 1 chuỗi nối các địa chỉ emails lại, phân cách bằng dấu ";"
      eBcc = eBcc & mCell.Value & ";"
    Next mCell
    eBcc = Left(eBcc, Len(eBcc) - 1)      '==> Loại bỏ dấu ";" thừa bên phải
  End If
End With

'Khởi tạo 1 email mới
Set outApp = CreateObject("Outlook.Application")
Set outMail = outApp.CreateItem(0)

'Hiển thị email lên để kiểm tra xem chữ ký mặc định có hay không , và copy nó gán vào biến DefaultSignature
outMail.Display
DefaultSignature = outMail.HTMLBody

'Đưa thông tin vào email:
With outMail
  .to = eTo
  .CC = eCC
  .Subject = eSubject
  .BCC = eBcc
  If Len(DefaultSignature) > 0 Then
   '==>'Nếu có chữ ký mặc định sẵn thì dùng chữ ký mặc định của outlook | Vì là HTML, nên eBody cần đặt vào <p> .....</p> như là 1 pagragraph
    .HTMLBody = "<p>" & eBody & "</p>" & DefaultSignature   
  Else
    .HTMLBody = "<p>" & eBody & "</p>" & "<p>" & eSignature & "</p>"   '==>'Nếu không thì lấy giá trị của biến eSignature.
  End If
 '.Attachments.Add ActiveWorkbook.FullName   '==> Đính kèm file (nếu cần thiết)
  .Display   '==> hiển thị cửa sổ email để xem, người dùng tự mình gửi email từ outlook.
  '.Send   '==> gửi email tự động mà không cần xem trước
End With

'Đừng quên dọn dẹp:
On Error GoTo 0
Set outMail = Nothing: Set outApp = Nothing

End Sub

 

[LuuGiaPhúc]

Bạn có thể bổ sung một số bẫy lỗi như sau:
(Và nên mở Outlook trước, sau đó hãy chạy code)
Lưu ý: Giả định rằng bạn đang dùng Office 365, Ứng dụng email mặc định của bạn là Outlook 365.

Tham khảo 1 số kiến thức HTML tại đây:

Introduction to HTML

W3Schools offers free online tutorials, references and exercises in all the major languages of the web. Covering popular subjects like HTML, CSS, JavaScript, Python, SQL, Java, and many, many more.

www.w3schools.com

Sub SendMailWithBCC()
On Error Resume Next
'Bỏ qua DDE (Dynamic Data Exchange)
Application.IgnoreRemoteRequests = True

Dim outApp As Object
Dim outMail As Object
Dim mCell As Range
Dim xRow As Long
Dim eTo As String
Dim eCC As String
Dim eBcc As String
Dim eSubject As String
Dim eBody As String
Dim eSignature As String
Dim DefaultSignature As String

With Sheet1
  eTo = .[E4].Value
  eCC = ""
  eSubject = .[B1].Value
  eBody = .[B2].Value
  eSignature = .[B3].Value
  xRow = .Cells(Rows.Count, "E").End(xlUp).Row  '==> Xác định dòng cuối cùng có dữ liệu ở cột E'
  'Nếu dòng cuối này lớn hơn 4, nghĩa là có BCC email.
  If xRow > 4 Then
    For Each mCell In .Range("E5:E" & xRow)    '==> Tạo 1 chuỗi nối các địa chỉ emails lại, phân cách bằng dấu ";"
      eBcc = eBcc & mCell.Value & ";"
    Next mCell
    eBcc = Left(eBcc, Len(eBcc) - 1)      '==> Loại bỏ dấu ";" thừa bên phải
  End If
End With

'Khởi tạo 1 email mới
Set outApp = CreateObject("Outlook.Application")
Set outMail = outApp.CreateItem(0)

'Hiển thị email lên để kiểm tra xem chữ ký mặc định có hay không , và copy nó gán vào biến DefaultSignature
outMail.Display
DefaultSignature = outMail.HTMLBody

'Đưa thông tin vào email:
With outMail
  .to = eTo
  .CC = eCC
  .Subject = eSubject
  .BCC = eBcc
  If Len(DefaultSignature) > 0 Then
   '==>'Nếu có chữ ký mặc định sẵn thì dùng chữ ký mặc định của outlook | Vì là HTML, nên eBody cần đặt vào <p> .....</p> như là 1 pagragraph
    .HTMLBody = "<p>" & eBody & "</p>" & DefaultSignature  
  Else
    .HTMLBody = "<p>" & eBody & "</p>" & "<p>" & eSignature & "</p>"   '==>'Nếu không thì lấy giá trị của biến eSignature.
  End If
 '.Attachments.Add ActiveWorkbook.FullName   '==> Đính kèm file (nếu cần thiết)
  .Display   '==> hiển thị cửa sổ email để xem, người dùng tự mình gửi email từ outlook.
  '.Send   '==> gửi email tự động mà không cần xem trước
End With

'Đừng quên dọn dẹp:
On Error GoTo 0
Set outMail = Nothing: Set outApp = Nothing

End Sub

Tuyệt vời. Code hoạt động tốt, cảm ơn bạn rất nhiều.
Cho mình hỏi thêm 1 ý (do lúc đầu đặt câu hỏi đúng là chưa nghĩ tới tình huống này) trong phần nội dung mail mà mình sẵn trong ô B2 , lúc đưa qua body mail , thì toàn bộ định dạng mất hết (bao gồm màu chữ , xuống dòng .....)



Nếu có thể làm cho nó giữ nguyên định dạng thì sẽ tuyệt hơn nữa...

Nội dung mail thì cũng ngắn gọn thôi, thường chỉ khoảng 5 đến 6 hàng, nhưng có xuống dòng , có tô đậm màu 1 vài chữ ... khi qua body mail thì nó viết gom hết lại thành 1 cỡ chữ thì cũng chưa hoàn hảo lắm thôi.

 

[Châu Bá Thông]

Tuyệt vời. Code hoạt động tốt, cảm ơn bạn rất nhiều.
Cho mình hỏi thêm 1 ý (do lúc đầu đặt câu hỏi đúng là chưa nghĩ tới tình huống này) trong phần nội dung mail mà mình sẵn trong ô B2 , lúc đưa qua body mail , thì toàn bộ định dạng mất hết (bao gồm màu chữ , xuống dòng .....)

View attachment 301099

Nếu có thể làm cho nó giữ nguyên định dạng thì sẽ tuyệt hơn nữa...

Nội dung mail thì cũng ngắn gọn thôi, thường chỉ khoảng 5 đến 6 hàng, nhưng có xuống dòng , có tô đậm màu 1 vài chữ ... khi qua body mail thì nó viết gom hết lại thành 1 cỡ chữ thì cũng chưa hoàn hảo lắm thôi.

View attachment 301100

Bạn có thể nghiên cứu về xử lý clipboard để chuyển thành html xem sao (kiểu như copy ô đó rồi dán (paste) cả format vào outlook hay Word ấy. Riêng tôi thì không nắm rõ các Hàm API của Microsoft để can thiệp vào bộ nhớ đệm và clipboard để xử lý.

 

[Hai Lúa Miền Tây]

Bạn có thể nghiên cứu về xử lý clipboard để chuyển thành html xem sao (kiểu như copy ô đó rồi dán (paste) cả format vào outlook hay Word ấy. Riêng tôi thì không nắm rõ các Hàm API của Microsoft để can thiệp vào bộ nhớ đệm và clipboard để xử lý.

Bạn tìm và thay thế chỗ xuống dòng bằng thẻ <br> là được nhé.
Ví dụ như sau:

eBody = WorksheetFunction.Substitute(.[B2].Value, Chr(10), "<br>")
eSignature = WorksheetFunction.Substitute(.[B3].Value, Chr(10), "<br>")

 

[befaint]

thay thế chỗ xuống dòng bằng thẻ <br> là được

Đâu có được bác. Xuống dòng chỉ là 1 phần bé tẻo teo.
Người ta muốn y chang dữ liệu ban đầu đó, bao gồm: Font size/ style, color

---
Mấy cái đó lấy trong xml là đủ hết.

 

[LuuGiaPhúc]

Bạn có thể nghiên cứu về xử lý clipboard để chuyển thành html xem sao (kiểu như copy ô đó rồi dán (paste) cả format vào outlook hay Word ấy. Riêng tôi thì không nắm rõ các Hàm API của Microsoft để can thiệp vào bộ nhớ đệm và clipboard để xử lý.

Cảm ơn bạn nhé. Mình sẽ tìm hiểu thêm về cách này

 

[quanluu]

Bạn tìm kiến hàm rangetohtml nhé. Nó bản chất là lưu vùng dữ liệu sang html của excel.

 

[tieutuvodanh192]

Lấy nguyên định dạng từ Excel qua Outlook thì thiết lập Email Body kiểu:

...
Dim olMail As Outlook.MailItem
Dim emailBodyRange As Range
Set emailBodyRange = Sheets("Sheet1").Range("B1:B3") ' Vùng chứa nội dung email
olMail.HTMLBody = RangetoHTML(emailBodyRange)& Signatures 'Nếu Outlook có sẵn chữ ký thì thêm "& Signatures" như vậy
...



Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function