3D Charting support in email

[haianh89]

Because I just found out VBA, I have found and matched the type of the internet is quite good but also want to add two 3D pie charts, as attached.

Thanks to the support people for the attached file.

Thanks guys so much.

Sub GuiMail_NHDT_27062018()    Dim objOutlook, objOutlookMsg, cn, rst As Object    Dim arr As Variant    Dim str1, str2, str3 As String    Dim I As Integer    Set objOutlook = CreateObject("Outlook.Application")    Set objOutlookMsg = objOutlook.CreateItem(0)    Set cn = CreateObject("ADODB.Connection")    Set rst = CreateObject("ADODB.Recordset")    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 12.0"    rst.Open ("select * from [DATA 1$]"), cn    arr = rst.GetRows()    rst.Close    For I = Sheet4.[c1] To Sheet4.[d1]        rst.Open ("select [PHI GROSS],[CHI PHI],[PHI NET],[PHI NET LUY KE],[% KH PHI NET 2018] from [Data 1$] where MADV='" & arr(1, I) & "'"), cn, 3        If rst.RecordCount > 0 Then            str1 = rst.GetString(, , "</td><td>", "</tr>")        Else            str1 = ""        End If        rst.Close        rst.Open ("select [Nhan xet 1] from [Data 1$] where MaDv='" & arr(1, I) & "'"), cn        If rst.RecordCount > 0 Then            str2 = rst.GetString(, , "</td><td>", "</tr>")        Else            str2 = ""        End If        rst.Close        rst.Open ("select [Nhan xet 2] from [Data 1$] where MaDv='" & arr(1, I) & "'"), cn        If rst.RecordCount > 0 Then            str3 = rst.GetString(, , "</td><td>", "</tr>")        Else            str3 = ""        End If        If Len(str2) > 0 Then                Set objOutlookMsg = objOutlook.CreateItem(0)        With objOutlookMsg            .To = arr(3, I)            .CC = Sheet4.Range("b3").Value            .Subject = Sheet4.[b5] & arr(4, I)            .HTMLBody = "<strong>" & Sheet4.[a6] & "</strong><br><br>" & Sheet4.[A7] & "<br>" & Sheet4.[A8] & _                            " <br><table border='1'><th>PHÍ GROSS </th><th>CHI PHÍ</th><th>PHÍ NET</th><th>PHÍ NET LUY KE 2018</th><th>% KH PHI NET 2018</th>  <tr>" & _                            str1 & "</table><br>" & Sheet4.[A12] & "</strong><br> " & _                            "</strong><br>&nbsp&nbsp&nbsp&nbsp<font face='Wingdings'>Ø</font>  " & str2 & _                            "<br>&nbsp&nbsp&nbsp&nbsp<font face='Wingdings'>Ø</font>  " & _                            Sheet4.[A15] & "</strong><br><br><br><br><br><br>" & _                            "<strong>" & Sheet4.[A19] & "</strong><br><br>" & _                            "</strong><br>&nbsp&nbsp&nbsp&nbsp<font face='Wingdings'>Ø</font>  " & str3 & _                            "<br>&nbsp&nbsp&nbsp&nbsp<font face='Wingdings'>Ø</font>  " & _                            Sheet4.[A22] & "<br><br>" & _                            Sheet4.[A23] & "<br>" & _                            Sheet4.[A25] & "<br>" & _                            "<strong>" & Sheet4.[A26] & "</strong><br><br>" & _                           Sheet4.[A28] & "<br>"                                            .display  'Or use Send                          'De email gui di luôn (không hien thi len) doi display => send                    End With
        End If        rst.Close    Next End Sub

 

[haianh89]

send back the code

Sub GuiMail_NHDT_27062018()    Dim objOutlook, objOutlookMsg, cn, rst As Object
    Dim arr As Variant
    Dim str1, str2, str3 As String
    Dim I As Integer
    Set objOutlook = CreateObject("Outlook.Application")
    Set objOutlookMsg = objOutlook.CreateItem(0)
    Set cn = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset")
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 12.0"
    rst.Open ("select * from [DATA 1$]"), cn
    arr = rst.GetRows()
    rst.Close
    For I = Sheet4.[c1] To Sheet4.[d1]
        rst.Open ("select [PHI GROSS],[CHI PHI],[PHI NET],[PHI NET LUY KE],[% KH PHI NET 2018] from [Data 1$] where MADV='" & arr(1, I) & "'"), cn, 3
        If rst.RecordCount > 0 Then
            str1 = rst.GetString(, , "</td><td>", "</tr>")
        Else
            str1 = ""
        End If
        rst.Close
        rst.Open ("select [Nhan xet 1] from [Data 1$] where MaDv='" & arr(1, I) & "'"), cn
        If rst.RecordCount > 0 Then
            str2 = rst.GetString(, , "</td><td>", "</tr>")
        Else
            str2 = ""
        End If
        rst.Close
        rst.Open ("select [Nhan xet 2] from [Data 1$] where MaDv='" & arr(1, I) & "'"), cn
        If rst.RecordCount > 0 Then
            str3 = rst.GetString(, , "</td><td>", "</tr>")
        Else
            str3 = ""
        End If
        If Len(str2) > 0 Then
        
        Set objOutlookMsg = objOutlook.CreateItem(0)
        With objOutlookMsg
            .To = arr(3, I)
            .CC = Sheet4.Range("b3").Value
            .Subject = Sheet4.[b5] & arr(4, I)
            .HTMLBody = "<strong>" & Sheet4.[a6] & "</strong><br><br>" & Sheet4.[A7] & "<br>" & Sheet4.[A8] & _
                            " <br><table border='1'><th>PHÍ GROSS </th><th>CHI PHÍ</th><th>PHÍ NET</th><th>PHÍ NET LUY KE 2018</th><th>% KH PHI NET 2018</th>  <tr>" & _
                            str1 & "</table><br>" & Sheet4.[A12] & "</strong><br> " & _
                            "</strong><br>&nbsp&nbsp&nbsp&nbsp<font face='Wingdings'>Ø</font>  " & str2 & _
                            "<br>&nbsp&nbsp&nbsp&nbsp<font face='Wingdings'>Ø</font>  " & _
                            Sheet4.[A15] & "</strong><br><br><br><br><br><br>" & _
                            "<strong>" & Sheet4.[A19] & "</strong><br><br>" & _
                            "</strong><br>&nbsp&nbsp&nbsp&nbsp<font face='Wingdings'>Ø</font>  " & str3 & _
                            "<br>&nbsp&nbsp&nbsp&nbsp<font face='Wingdings'>Ø</font>  " & _
                            Sheet4.[A22] & "<br><br>" & _
                            Sheet4.[A23] & "<br>" & _
                            Sheet4.[A25] & "<br>" & _
                            "<strong>" & Sheet4.[A26] & "</strong><br><br>" & _
                           Sheet4.[A28] & "<br>"
                            
                .display  'Or use Send                          'De email gui di luôn (không hien thi len) doi display => send
        
            End With


        End If
        rst.Close
    Next
 
End Sub