Chép nội dung lên mail kèm định dạng tô đỏ, in đậm ...

Nguyễn Minh Đạt

Thành viên mới
A/C ơi cho mình hỏi, mình tìm được code để gửi mail tự động bằng VBA nhưng phần nội dung mail mình chỉ copy được nội dung từ ô trong sheets, không chép được định dạng như hightlight, tô đỏ, in đậm ... ==> nhờ mọi người hỗ trợ giúp mình với
 

Ngày Mới

Thành viên
@Nguyễn Minh Đạt Tại Cell [A1] tôi có một nội dung như sau
Bạn cần đăng nhập để thấy hình ảnh


Sau khi chạy code, tôi được Mail với nội dung Body như sau
Bạn cần đăng nhập để thấy hình ảnh

Và đây là nội dung của code:
Mã:
Sub Mail_Selection_Range_Outlook_Body()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Working in Excel 2000-2019
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim toMail, ccMail, SubjectMail, bccMail As String
    Set rng = Nothing
    On Error Resume Next
   
   
   
    '//DAY LA O CHUA NOI DUNG CUA MAIL
    toMail = "thv@gmail.com"
    ccMail = ""
    bccMail = ""
    SubjectMail = "Day la email Test"
    '//DAY LA O CHUA NOI DUNG BODY CUA MAIL
    Set rng = ActiveSheet.Range("A1").SpecialCells(xlCellTypeVisible)
   
   
'********************************************************************************************************************************
    On Error GoTo 0
    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        '.ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = toMail
        .CC = ccMail
        .BCC = bccMail
        .Subject = SubjectMail
        .HTMLBody = fnConvert2HTML(rng)
        .Send   'or use .Display
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Function fnConvert2HTML(myCell As Range) As String
Dim bldTagOn, itlTagOn, ulnTagOn, colTagOn As Boolean
Dim i, chrCount As Integer
Dim chrCol, chrLastCol, htmlTxt As String

bldTagOn = False
itlTagOn = False
ulnTagOn = False
colTagOn = False
chrCol = "NONE"
htmlTxt = "<html>"
chrCount = myCell.Characters.Count

For i = 1 To chrCount
    With myCell.Characters(i, 1)
        If (.Font.Color) Then
            chrCol = fnGetCol(.Font.Color)
            If Not colTagOn Then
                htmlTxt = htmlTxt & "<font color=#" & chrCol & ">"
                colTagOn = True
            Else
                If chrCol <> chrLastCol Then htmlTxt = htmlTxt & "</font><font color=#" & chrCol & ">"
            End If
        Else
            chrCol = "NONE"
            If colTagOn Then
                htmlTxt = htmlTxt & "</font>"
                colTagOn = False
            End If
        End If
        chrLastCol = chrCol

        If .Font.Bold = True Then
            If Not bldTagOn Then
                htmlTxt = htmlTxt & "<b>"
                bldTagOn = True
            End If
        Else
            If bldTagOn Then
                htmlTxt = htmlTxt & "</b>"
                bldTagOn = False
            End If
        End If

        If .Font.Italic = True Then
            If Not itlTagOn Then
                htmlTxt = htmlTxt & "<i>"
                itlTagOn = True
            End If
        Else
            If itlTagOn Then
                htmlTxt = htmlTxt & "</i>"
                itlTagOn = False
            End If
        End If

        If .Font.Underline > 0 Then
            If Not ulnTagOn Then
                htmlTxt = htmlTxt & "<u>"
                ulnTagOn = True
            End If
        Else
            If ulnTagOn Then
                htmlTxt = htmlTxt & "</u>"
                ulnTagOn = False
            End If
        End If

        If (Asc(.Text) = 10) Then
            htmlTxt = htmlTxt & "<br>"
        Else
            htmlTxt = htmlTxt & .Text
        End If
    End With
Next

If colTagOn Then
    htmlTxt = htmlTxt & "</font>"
    colTagOn = False
End If
If bldTagOn Then
    htmlTxt = htmlTxt & "</b>"
    bldTagOn = False
End If
If itlTagOn Then
    htmlTxt = htmlTxt & "</i>"
    itlTagOn = False
End If
If ulnTagOn Then
    htmlTxt = htmlTxt & "</u>"
    ulnTagOn = False
End If
htmlTxt = htmlTxt & "</html>"
fnConvert2HTML = htmlTxt
End Function

Function fnGetCol(strCol As String) As String
Dim rVal, gVal, bVal As String
strCol = Right("000000" & Hex(strCol), 6)
bVal = Left(strCol, 2)
gVal = Mid(strCol, 3, 2)
rVal = Right(strCol, 2)
fnGetCol = rVal & gVal & bVal
End Function
Và đây là file tải về để bạn tham khảo,
 
Sửa lần cuối:

Nguyễn Minh Đạt

Thành viên mới
Cảm ơn Ngày Mới vì sự giúp đỡ nhiệt tình, nhưng đoạn code có nhiều code mới quá, mình khó hiểu để áp dụng cho file của mình ak ^ ^. cảm ơn rất nhiều.
 

Ngày Mới

Thành viên
@Nguyễn Minh Đạt Bạn chỉ cần thay đổi nội dung mail là sử dụng được rồi. Phần phía dưới liên quan nhiều đến HTML, dùng để chuyển các định dạng từ ô Excel thành mã HTML chèn vào Mail.
Mã:
'//DAY LA O CHUA NOI DUNG CUA MAIL
    toMail = "thv@gmail.com"
    ccMail = ""
    bccMail = ""
    SubjectMail = "Day la email Test"
    Set rng = ActiveSheet.Range("A1").SpecialCells(xlCellTypeVisible)
 
Top