Nhờ hỗ trợ vẽ biểu đồ đính kèm email (1 người xem)

[haianh89]

Vẽ biểu đồ 3D trong email

Do trước đây nhờ bác HLMT hỗ trợ, mình đã chế ra chương trình chậy khá ổn nhưng còn muốn bổ sung hai biểu đồ dạng tròn 3D, như hình đính kèm.

Nhờ các mọi người hỗ trợ giùm theo file đính kèm.

Cảm ơn mọi người nhiều.

Mã hiện tại đã có:

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 [Phi 1],[Phi 2],[Phi 3] 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 1] from [Data 1$] where MaDv='" & arr(1, I) & "'"), cn
        If rst.RecordCount > 0 Then
            str3 = rst.GetString(, , "</td><td>", "</tr>")
        Else
            str3 = ""
        End If
        rst.Close
        rst.Open ("select [Nhan xet 2] from [Data 1$] where MaDv='" & arr(1, I) & "'"), cn
        If rst.RecordCount > 0 Then
            str4 = rst.GetString(, , "</td><td>", "</tr>")
        Else
            str4 = ""
        End If
        rst.Close
        rst.Open ("select [Chi phi 1],[Chi phi 2],[Chi phi 3],[Chi phi 4] from [Data 1$] where MaDv='" & arr(1, I) & "'"), cn
        If rst.RecordCount > 0 Then
            str5 = rst.GetString(, , "</td><td>", "</tr>")
        Else
            str5 = ""
        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>  " & str3 & _
                            "<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>  " & str4 & _
                            "<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

 

[befaint]

#5

 

[haianh89]

#5

là sẽ được trả lời trong thứ 5 ak