Gửi email tính lương cho từng người

Liên hệ QC
Z

zine

Thành viên mới
Tham gia
21/8/07
Bài viết
27
Được thích
13
Hi các anh chị
Em có bảng tính lương cho tất cả CBCNV trong công ty
Bây giờ em muốn sau khi tính lương, gửi cách tính lương chi tiết của từng người cho người đó qua email.(thông tin lương của người nào, chỉ người đó biết)
Em gửi kèm file, mọi người có cách gì giúp em nhé, đa tạ.
 

File đính kèm

  • Gui email tu dong theo danh sach.xlsx
    13.2 KB · Đọc: 2,820
Sắp xếp theo thời gian sắp xếp theo bầu chọn
tueyennhi đã viết:
Thực ra không phải copy tay mà mình dùng đoạn code để lấy ID theo phòng ban, theo nhóm.
Code này chạy trên máy khác cũng office như mình thì bình thường, đính kèm ảnh ngon lành. Sang máy mình thì lại không có, cài lại office cũng vẫn vậy. Bạn chỉ mình cách nào khác mà đính kèm được ảnh là mình có thể giải quyết bài toán của mình. Hiện tại mình cũng cần gấp không có thời gian giải thích chi tiết thêm chỉ cần file thực thi chèn ảnh và gửi tự động là tốt rồi. Mong bạn có thể giúp mình tháo gỡ vấn đề chính này.
Nhấp chuột vào đây để mở rộng...
Mã: 
Option Explicit

' Chèn anh truc tiep vao mail
Sub SendMail2()
Dim OutApp As Object, OutMail As Object, objFSO As Object, oChart As Object
Dim Tu As Long, Den As Long, i As Long
Dim strPath As String, strFilePic As String
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    strPath = ThisWorkbook.Path
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    strFilePic = strPath & "PicPayment.jpg"
    
    With Sheets("Print")
        Tu = .Range("AG2")
        Den = .Range("AH2")
        For i = Tu To Den Step 2
            .Range("AH5") = i
        'Xoa Attached file hien huu neu có
            If objFSO.FileExists(strFilePic) Then objFSO.DeleteFile strFilePic
        'Tao file (Pic) chi tiet luong voi tên file kem duong dan: strFilePic
            Set oChart = .Shapes.AddChart(xlColumnClustered, .Range("A1:AB68").Width, Height:=.Range("A1:AB68").Height).Chart
            .Range("A1:AB68").CopyPicture xlScreen, xlPicture
            oChart.Parent.Activate
            oChart.Paste
            oChart.Export Filename:=strFilePic, FilterName:="jpg"
            oChart.Parent.Delete
            
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = Sheets("Print").Range("X10").Value
                .Subject = "Phi" & ChrW(7871) & "u l" & ChrW(432) & ChrW(417) & "ng: " & Sheets("Print").Range("H2").Value
                .Attachments.Add strFilePic, 1, 0
                .HTMLBody = "Xin chào " & "<B>" & Sheets("Print").Range("K4") & "</B>" & _
                "<BR><BR>Phòng Nhân s" & ChrW(7921) & " xin g" & ChrW(7917) & "i l" & ChrW(7841) & "i b" & ChrW(7843) & "ng chi ti" & ChrW(7871) & "t l" & ChrW(432) & ChrW(417) & "ng " & ChrW(273) & "ã tr" & ChrW(7843) & " (tính sai) và b" & ChrW(7843) & "ng chi ti" & ChrW(7871) & "t l" & ChrW(432) & ChrW(417) & "ng tính l" & ChrW(7841) & "i (tính " & ChrW(273) & "úng)." & _
                                "<BR><BR><B>Xin c" & ChrW(7843) & "m " & ChrW(417) & "n,</B><BR><BR>" & _
                                "<img src=""cid:PicPayment.jpg"" height=520 width=750>" & _
                                "<BR><BR><B>Phòng Nhân s" & ChrW(7921) & "!</B>"
                .Display
                SendKeys "({DOWN})", True
                SendKeys "({DOWN})", True
                SendKeys "({DOWN})", True
                SendKeys "^({v})", True
                .Send
            End With
            Set OutMail = Nothing
            Set oChart = Nothing
        Next i
    End With
    Set OutApp = Nothing
    Set objFSO = Nothing
    Set oChart = Nothing
End Sub
thay code gởi mail của bạn bằng code trên
 
Upvote 0
thnghiachau đã viết:
Mã: 
Option Explicit

' Chèn anh truc tiep vao mail
Sub SendMail2()
Dim OutApp As Object, OutMail As Object, objFSO As Object, oChart As Object
Dim Tu As Long, Den As Long, i As Long
Dim strPath As String, strFilePic As String
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
   
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    strPath = ThisWorkbook.Path
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    strFilePic = strPath & "PicPayment.jpg"
   
    With Sheets("Print")
        Tu = .Range("AG2")
        Den = .Range("AH2")
        For i = Tu To Den Step 2
            .Range("AH5") = i
        'Xoa Attached file hien huu neu có
            If objFSO.FileExists(strFilePic) Then objFSO.DeleteFile strFilePic
        'Tao file (Pic) chi tiet luong voi tên file kem duong dan: strFilePic
            Set oChart = .Shapes.AddChart(xlColumnClustered, .Range("A1:AB68").Width, Height:=.Range("A1:AB68").Height).Chart
            .Range("A1:AB68").CopyPicture xlScreen, xlPicture
            oChart.Parent.Activate
            oChart.Paste
            oChart.Export Filename:=strFilePic, FilterName:="jpg"
            oChart.Parent.Delete
           
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = Sheets("Print").Range("X10").Value
                .Subject = "Phi" & ChrW(7871) & "u l" & ChrW(432) & ChrW(417) & "ng: " & Sheets("Print").Range("H2").Value
                .Attachments.Add strFilePic, 1, 0
                .HTMLBody = "Xin chào " & "<B>" & Sheets("Print").Range("K4") & "</B>" & _
                "<BR><BR>Phòng Nhân s" & ChrW(7921) & " xin g" & ChrW(7917) & "i l" & ChrW(7841) & "i b" & ChrW(7843) & "ng chi ti" & ChrW(7871) & "t l" & ChrW(432) & ChrW(417) & "ng " & ChrW(273) & "ã tr" & ChrW(7843) & " (tính sai) và b" & ChrW(7843) & "ng chi ti" & ChrW(7871) & "t l" & ChrW(432) & ChrW(417) & "ng tính l" & ChrW(7841) & "i (tính " & ChrW(273) & "úng)." & _
                                "<BR><BR><B>Xin c" & ChrW(7843) & "m " & ChrW(417) & "n,</B><BR><BR>" & _
                                "<img src=""cid:PicPayment.jpg"" height=520 width=750>" & _
                                "<BR><BR><B>Phòng Nhân s" & ChrW(7921) & "!</B>"
                .Display
                SendKeys "({DOWN})", True
                SendKeys "({DOWN})", True
                SendKeys "({DOWN})", True
                SendKeys "^({v})", True
                .Send
            End With
            Set OutMail = Nothing
            Set oChart = Nothing
        Next i
    End With
    Set OutApp = Nothing
    Set objFSO = Nothing
    Set oChart = Nothing
End Sub
thay code gởi mail của bạn bằng code trên
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn, để mình thử nhé.
Bài đã được tự động gộp:

thnghiachau đã viết:
Mã: 
Option Explicit

' Chèn anh truc tiep vao mail
Sub SendMail2()
Dim OutApp As Object, OutMail As Object, objFSO As Object, oChart As Object
Dim Tu As Long, Den As Long, i As Long
Dim strPath As String, strFilePic As String
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
   
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    strPath = ThisWorkbook.Path
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    strFilePic = strPath & "PicPayment.jpg"
   
    With Sheets("Print")
        Tu = .Range("AG2")
        Den = .Range("AH2")
        For i = Tu To Den Step 2
            .Range("AH5") = i
        'Xoa Attached file hien huu neu có
            If objFSO.FileExists(strFilePic) Then objFSO.DeleteFile strFilePic
        'Tao file (Pic) chi tiet luong voi tên file kem duong dan: strFilePic
            Set oChart = .Shapes.AddChart(xlColumnClustered, .Range("A1:AB68").Width, Height:=.Range("A1:AB68").Height).Chart
            .Range("A1:AB68").CopyPicture xlScreen, xlPicture
            oChart.Parent.Activate
            oChart.Paste
            oChart.Export Filename:=strFilePic, FilterName:="jpg"
            oChart.Parent.Delete
           
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = Sheets("Print").Range("X10").Value
                .Subject = "Phi" & ChrW(7871) & "u l" & ChrW(432) & ChrW(417) & "ng: " & Sheets("Print").Range("H2").Value
                .Attachments.Add strFilePic, 1, 0
                .HTMLBody = "Xin chào " & "<B>" & Sheets("Print").Range("K4") & "</B>" & _
                "<BR><BR>Phòng Nhân s" & ChrW(7921) & " xin g" & ChrW(7917) & "i l" & ChrW(7841) & "i b" & ChrW(7843) & "ng chi ti" & ChrW(7871) & "t l" & ChrW(432) & ChrW(417) & "ng " & ChrW(273) & "ã tr" & ChrW(7843) & " (tính sai) và b" & ChrW(7843) & "ng chi ti" & ChrW(7871) & "t l" & ChrW(432) & ChrW(417) & "ng tính l" & ChrW(7841) & "i (tính " & ChrW(273) & "úng)." & _
                                "<BR><BR><B>Xin c" & ChrW(7843) & "m " & ChrW(417) & "n,</B><BR><BR>" & _
                                "<img src=""cid:PicPayment.jpg"" height=520 width=750>" & _
                                "<BR><BR><B>Phòng Nhân s" & ChrW(7921) & "!</B>"
                .Display
                SendKeys "({DOWN})", True
                SendKeys "({DOWN})", True
                SendKeys "({DOWN})", True
                SendKeys "^({v})", True
                .Send
            End With
            Set OutMail = Nothing
            Set oChart = Nothing
        Next i
    End With
    Set OutApp = Nothing
    Set objFSO = Nothing
    Set oChart = Nothing
End Sub
thay code gởi mail của bạn bằng code trên
Nhấp chuột vào đây để mở rộng...
Bạn ơi ảnh thì chèn vào được rồi nhưng mà không nhìn thấy nội dung
1597301515037.png
 
Upvote 0
tueyennhi đã viết:
Cảm ơn anh, vậy không được rồi. Vì vấn đề nhạy cảm nên em vẫn cần sử dụng form như trước kia dùng.
Nhấp chuột vào đây để mở rộng...
Vậy bạn có thể thử code sau nhé:

Mã: 
Sub SendMail2()
    Dim OutApp As Object
    Dim outMail As Object
    Dim objMailDocument As Object
    Dim Tu As Long, Den As Long, i As Long
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    With Sheets("Print")
        Tu = .Range("M1")
        Den = .Range("O1")
        For i = Tu To Den Step 1
            .Range("M2") = i
            .Range("A1:G4").CopyPicture
            Set outMail = OutApp.CreateItem(0)
            With outMail
                .To = Sheets("Print").Range("G2").Value
                .Subject = "Phi" & ChrW(7871) & "u l" & ChrW(432) & ChrW(417) & "ng: " & Sheets("Print").Range("H2").Value
                .HTMLBody = "Xin chào " & "<B>" & Sheets("Print").Range("K4") & "</B>" & _
                "<BR><BR>Phòng Nhân s" & ChrW(7921) & " xin g" & ChrW(7917) & "i l" & ChrW(7841) & "i b" & ChrW(7843) & "ng chi ti" & ChrW(7871) & "t l" & ChrW(432) & ChrW(417) & "ng " & ChrW(273) & "ã tr" & ChrW(7843) & " và b" & ChrW(7843) & "ng chi ti" & ChrW(7871) & "t l" & ChrW(432) & ChrW(417) & "ng tính l" & ChrW(7841) & "i )." & _
                                "<BR><BR><BR><B>Xin c" & ChrW(7843) & "m " & ChrW(417) & "n,</B><BR>" & _
                               "<BR><B>Phòng Nhân s" & ChrW(7921) & "!</B><br><a href=https://www.giaiphapexcel.com/diendan/threads/g%E1%BB%ADi-email-t%C3%ADnh-l%C6%B0%C6%A1ng-cho-t%E1%BB%ABng-ng%C6%B0%E1%BB%9Di.48211/page-17>Xem thêm tai dây</a><br><strong>Hai Lúa Miên Tây</strong>"
                .Display
                Set objMailDocument = outMail.GetInspector.WordEditor
                objMailDocument.Range(100, 100).Paste
                .send
            End With
            Set outMail = Nothing
        Next i
    End With
    Set OutApp = Nothing
End Sub
 
Upvote 0
tueyennhi đã viết:
Cảm ơn bạn, để mình thử nhé.
Bài đã được tự động gộp:


Bạn ơi ảnh thì chèn vào được rồi nhưng mà không nhìn thấy nội dung
View attachment 243038
Nhấp chuột vào đây để mở rộng...
đó bạn thấy chưa? xử lý hình ảnh không phải là đơn giản, thế tại sao bạn không gởi file Pdf cho dễ dàng hơn??? pdf thì cũng như hình ảnh thôi, chỉ tạo đúng vùng A1:AB68 đó!!!!!!!!!!!!!!!!

Mã: 
Option Explicit

Sub SendMail2()
Dim OutApp As Object, OutMail As Object, objFSO As Object, oChart As Object
Dim Tu As Long, Den As Long, i As Long
Dim strPath As String, strFileAtt As String
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    strPath = ThisWorkbook.Path
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    strFileAtt = strPath & "Payment.Pdf"
    
    With Sheets("Print")
        Tu = .Range("AG2")
        Den = .Range("AH2")
        For i = Tu To Den Step 2
            .Range("AH5") = i
        'Xoa Attached file hien huu neu có
            If objFSO.FileExists(strFileAtt) Then objFSO.DeleteFile strFileAtt
        'Tao file attached (.Pdf) chi tiet luong
            .Range("A1:AB68").ExportAsFixedFormat Type:=xlTypePDF, _
                                                  Filename:=strFileAtt, _
                                                  Quality:=xlQualityStandard, _
                                                  IncludeDocProperties:=True, _
                                                  IgnorePrintAreas:=False, _
                                                  OpenAfterPublish:=False
            
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = Sheets("Print").Range("X10").Value
                .Subject = "Phi" & ChrW(7871) & "u l" & ChrW(432) & ChrW(417) & "ng: " & Sheets("Print").Range("H2").Value
                .Attachments.Add strFileAtt, 1, 0
                .HTMLBody = "Xin chào " & "<B>" & Sheets("Print").Range("K4") & "</B>" & _
                "<BR><BR>Phòng Nhân s" & ChrW(7921) & " xin g" & ChrW(7917) & "i l" & ChrW(7841) & "i b" & ChrW(7843) & "ng chi ti" & ChrW(7871) & "t l" & ChrW(432) & ChrW(417) & "ng " & ChrW(273) & "ã tr" & ChrW(7843) & " (tính sai) và b" & ChrW(7843) & "ng chi ti" & ChrW(7871) & "t l" & ChrW(432) & ChrW(417) & "ng tính l" & ChrW(7841) & "i (tính " & ChrW(273) & "úng)." & _
                                "<BR><BR><B>Xin c" & ChrW(7843) & "m " & ChrW(417) & "n,</B><BR><BR>" & _
                                "<BR><BR><B>Phòng Nhân s" & ChrW(7921) & "!</B>"
                .Display
                SendKeys "({DOWN})", True
                SendKeys "({DOWN})", True
                SendKeys "({DOWN})", True
                SendKeys "^({v})", True
                .Send
            End With
            If objFSO.FileExists(strFileAtt) Then objFSO.DeleteFile strFileAtt
            Set OutMail = Nothing
            Set oChart = Nothing
        Next i
    End With
    Set OutApp = Nothing
    Set objFSO = Nothing
    Set oChart = Nothing
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Hai Lúa Miền Tây đã viết:
Vậy bạn có thể thử code sau nhé:

Mã: 
Sub SendMail2()
    Dim OutApp As Object
    Dim outMail As Object
    Dim objMailDocument As Object
    Dim Tu As Long, Den As Long, i As Long
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    With Sheets("Print")
        Tu = .Range("M1")
        Den = .Range("O1")
        For i = Tu To Den Step 1
            .Range("M2") = i
            .Range("A1:G4").CopyPicture
            Set outMail = OutApp.CreateItem(0)
            With outMail
                .To = Sheets("Print").Range("G2").Value
                .Subject = "Phi" & ChrW(7871) & "u l" & ChrW(432) & ChrW(417) & "ng: " & Sheets("Print").Range("H2").Value
                .HTMLBody = "Xin chào " & "<B>" & Sheets("Print").Range("K4") & "</B>" & _
                "<BR><BR>Phòng Nhân s" & ChrW(7921) & " xin g" & ChrW(7917) & "i l" & ChrW(7841) & "i b" & ChrW(7843) & "ng chi ti" & ChrW(7871) & "t l" & ChrW(432) & ChrW(417) & "ng " & ChrW(273) & "ã tr" & ChrW(7843) & " và b" & ChrW(7843) & "ng chi ti" & ChrW(7871) & "t l" & ChrW(432) & ChrW(417) & "ng tính l" & ChrW(7841) & "i )." & _
                                "<BR><BR><BR><B>Xin c" & ChrW(7843) & "m " & ChrW(417) & "n,</B><BR>" & _
                               "<BR><B>Phòng Nhân s" & ChrW(7921) & "!</B><br><a href=https://www.giaiphapexcel.com/diendan/threads/g%E1%BB%ADi-email-t%C3%ADnh-l%C6%B0%C6%A1ng-cho-t%E1%BB%ABng-ng%C6%B0%E1%BB%9Di.48211/page-17>Xem thêm tai dây</a><br><strong>Hai Lúa Miên Tây</strong>"
                .Display
                Set objMailDocument = outMail.GetInspector.WordEditor
                objMailDocument.Range(100, 100).Paste
                .send
            End With
            Set outMail = Nothing
        Next i
    End With
    Set OutApp = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Ảnh chèn vào rồi mà phân giải thấp không nhìn được rõ nội dung anh ạ. Chắc cũng chỉ đến được như vậy :(. Vì nội dung của em thể hiện trong bài 305 nó là một vùng từ A1 đến AB68
Bài đã được tự động gộp:

thnghiachau đã viết:
đó bạn thấy chưa? xử lý hình ảnh không phải là đơn giản, thế tại sao bạn không gởi file Pdf cho dễ dàng hơn??? pdf thì cũng như hình ảnh thôi, chỉ tạo đúng vùng A1:AB68 đó!!!!!!!!!!!!!!!!

Mã: 
Option Explicit

Sub SendMail2()
Dim OutApp As Object, OutMail As Object, objFSO As Object, oChart As Object
Dim Tu As Long, Den As Long, i As Long
Dim strPath As String, strFileAtt As String
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
  
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    strPath = ThisWorkbook.Path
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    strFileAtt = strPath & "Payment.Pdf"
  
    With Sheets("Print")
        Tu = .Range("AG2")
        Den = .Range("AH2")
        For i = Tu To Den Step 2
            .Range("AH5") = i
        'Xoa Attached file hien huu neu có
            If objFSO.FileExists(strFileAtt) Then objFSO.DeleteFile strFileAtt
        'Tao file attached (.Pdf) chi tiet luong
            .Range("A1:AB68").ExportAsFixedFormat Type:=xlTypePDF, _
                                                  Filename:=strFileAtt, _
                                                  Quality:=xlQualityStandard, _
                                                  IncludeDocProperties:=True, _
                                                  IgnorePrintAreas:=False, _
                                                  OpenAfterPublish:=False
          
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = Sheets("Print").Range("X10").Value
                .Subject = "Phi" & ChrW(7871) & "u l" & ChrW(432) & ChrW(417) & "ng: " & Sheets("Print").Range("H2").Value
                .Attachments.Add strFileAtt, 1, 0
                .HTMLBody = "Xin chào " & "<B>" & Sheets("Print").Range("K4") & "</B>" & _
                "<BR><BR>Phòng Nhân s" & ChrW(7921) & " xin g" & ChrW(7917) & "i l" & ChrW(7841) & "i b" & ChrW(7843) & "ng chi ti" & ChrW(7871) & "t l" & ChrW(432) & ChrW(417) & "ng " & ChrW(273) & "ã tr" & ChrW(7843) & " (tính sai) và b" & ChrW(7843) & "ng chi ti" & ChrW(7871) & "t l" & ChrW(432) & ChrW(417) & "ng tính l" & ChrW(7841) & "i (tính " & ChrW(273) & "úng)." & _
                                "<BR><BR><B>Xin c" & ChrW(7843) & "m " & ChrW(417) & "n,</B><BR><BR>" & _
                                "<BR><BR><B>Phòng Nhân s" & ChrW(7921) & "!</B>"
                .Display
                SendKeys "({DOWN})", True
                SendKeys "({DOWN})", True
                SendKeys "({DOWN})", True
                SendKeys "^({v})", True
                .Send
            End With
            If objFSO.FileExists(strFileAtt) Then objFSO.DeleteFile strFileAtt
            Set OutMail = Nothing
            Set oChart = Nothing
        Next i
    End With
    Set OutApp = Nothing
    Set objFSO = Nothing
    Set oChart = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Nếu chuyển pdf thì mình phải sửa như nào? Căn bản sợ máy CNV không đọc được hoặc có người không biết. Vì vậy mình mới chọn phương án hiện ảnh trực tiếp.
 
Upvote 0
tueyennhi đã viết:
Nếu chuyển pdf thì mình phải sửa như nào? Căn bản sợ máy CNV không đọc được hoặc có người không biết. Vì vậy mình mới chọn phương án hiện ảnh trực tiếp.
Nhấp chuột vào đây để mở rộng...
Nay mà còn sợ có người không đọc được pdf? Các "ông trình duyệt" đã đọc giúp từ lâu rồi.
 
Upvote 0
tueyennhi đã viết:
Ảnh chèn vào rồi mà phân giải thấp không nhìn được rõ nội dung anh ạ. Chắc cũng chỉ đến được như vậy :(. Vì nội dung của em thể hiện trong bài 305 nó là một vùng từ A1 đến AB68
Nhấp chuột vào đây để mở rộng...
Vậy bạn có đồng ý copy nguyên bảng dữ liệu và dán vào Outlook giữ nguyên định dạng gốc bên excel? Chỉ khác chỗ thay ảnh thành bảng dữ liệu.
 
Upvote 0
tueyennhi đã viết:
Đồng ý anh ơi, miễn sao thể hiện hết nội dung và form giữ nguyên anh ạ.
Nhấp chuột vào đây để mở rộng...
Vậy bạn thử code sau nhé:

Mã: 
Option Explicit
Sub SendMail2()
    Dim OutApp As Object
    Dim outMail As Object
    Dim objMailDocument As Object
    Dim Tu As Long, Den As Long, i As Long
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    With Sheets("Print")
        Tu = .Range("M1")
        Den = .Range("O1")
        For i = Tu To Den Step 1
            .Range("M2") = i
            .Range("A1:G4").Copy 'Picture
            Set outMail = OutApp.CreateItem(0)
            With outMail
                .To = Sheets("Print").Range("G2").Value
                .Subject = "Phi" & ChrW(7871) & "u l" & ChrW(432) & ChrW(417) & "ng: " & Sheets("Print").Range("H2").Value
                .HTMLBody = "Xin chào " & "<B>" & Sheets("Print").Range("K4") & "</B>" & _
                "<BR><BR>Phòng Nhân s" & ChrW(7921) & " xin g" & ChrW(7917) & "i l" & ChrW(7841) & "i b" & ChrW(7843) & "ng chi ti" & ChrW(7871) & "t l" & ChrW(432) & ChrW(417) & "ng " & ChrW(273) & "ã tr" & ChrW(7843) & " và b" & ChrW(7843) & "ng chi ti" & ChrW(7871) & "t l" & ChrW(432) & ChrW(417) & "ng tính l" & ChrW(7841) & "i )." & _
                                "<BR><BR><BR><B>Xin c" & ChrW(7843) & "m " & ChrW(417) & "n,</B><BR>" & _
                               "<BR><B>Phòng Nhân s" & ChrW(7921) & "!</B><br><a href=https://www.giaiphapexcel.com/diendan/threads/g%E1%BB%ADi-email-t%C3%ADnh-l%C6%B0%C6%A1ng-cho-t%E1%BB%ABng-ng%C6%B0%E1%BB%9Di.48211/page-17>Xem thêm tai dây</a><br><strong>Hai Lúa Miên Tây</strong>"
                .Display
                Set objMailDocument = outMail.GetInspector.WordEditor
                objMailDocument.Range(100, 100).PasteAndFormat 1
                .send
            End With
            Set outMail = Nothing
        Next i
    End With
    Set OutApp = Nothing
End Sub
 
Upvote 0
tueyennhi đã viết:
Cảm ơn bạn, để mình thử nhé.
Bài đã được tự động gộp:


Bạn ơi ảnh thì chèn vào được rồi nhưng mà không nhìn thấy nội dung
View attachment 243038
Nhấp chuột vào đây để mở rộng...
Tôi đã xử lý cái hình không nhhi2n thấy cho bạn được rồi nè...
Bạn chép code này vào code gởi mail của bạn nha
Mã: 
Option Explicit

' Chèn anh truc tiep vao mail
Sub SendMail2()
Dim OutApp As Object, OutMail As Object, objFSO As Object, oChart As Object
Dim Tu As Long, Den As Long, i As Long
Dim strPath As String, strFilePic As String
Dim dbWidth As Double, dbHeight As Double
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    strPath = ThisWorkbook.Path
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    strFilePic = strPath & "PicPayment.jpg"
    
    With Sheets("Print")
        
        Tu = .Range("AG2")
        Den = .Range("AH2")
        For i = Tu To Den Step 2
            .Range("AH5") = i
            If objFSO.FileExists(strFilePic) Then objFSO.DeleteFile strFilePic
            .Range("A1:AB68").CopyPicture xlScreen, xlPicture
            dbWidth = Round(.Range("A1:AB68").Width, 0)
            dbHeight = Round(.Range("A1:AB68").Height, 0)
            .Range("A1").Select
            Set oChart = .Shapes.AddChart(Width:=dbWidth, Height:=dbHeight).Chart
            oChart.Parent.Activate
            oChart.Paste
            oChart.Export Filename:=strFilePic, FilterName:="jpg"
            oChart.Parent.Delete
            
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = Sheets("Print").Range("X10").Value
                .Subject = "Phi" & ChrW(7871) & "u l" & ChrW(432) & ChrW(417) & "ng: " & Sheets("Print").Range("H2").Value
                .Attachments.Add strFilePic, 1, 0
                .HTMLBody = "Xin chào " & "<B>" & Sheets("Print").Range("K4") & "</B>" & _
                "<BR><BR>Phòng Nhân s" & ChrW(7921) & " xin g" & ChrW(7917) & "i l" & ChrW(7841) & "i b" & ChrW(7843) & "ng chi ti" & ChrW(7871) & "t l" & ChrW(432) & ChrW(417) & "ng " & ChrW(273) & "ã tr" & ChrW(7843) & " (tính sai) và b" & ChrW(7843) & "ng chi ti" & ChrW(7871) & "t l" & ChrW(432) & ChrW(417) & "ng tính l" & ChrW(7841) & "i (tính " & ChrW(273) & "úng)." & _
                                "<BR><BR><B>Xin c" & ChrW(7843) & "m " & ChrW(417) & "n,</B><BR><BR>" & _
                                "<BR><BR><B>Phòng Nhân s" & ChrW(7921) & "!</B>" & _
                                "<img src=""cid:PicPayment.jpg"">"
                .Display
                SendKeys "({DOWN})", True
                SendKeys "({DOWN})", True
                SendKeys "({DOWN})", True
                SendKeys "^({v})", True
                .Send
            End With
            If objFSO.FileExists(strFilePic) Then objFSO.DeleteFile strFilePic
            Set OutMail = Nothing
            Set oChart = Nothing
        Next i
    End With
    Set OutApp = Nothing
    Set objFSO = Nothing
    Set oChart = Nothing
End Sub
 
Upvote 0
Hai Lúa Miền Tây đã viết:
Vậy bạn thử code sau nhé:

Mã: 
Option Explicit
Sub SendMail2()
    Dim OutApp As Object
    Dim outMail As Object
    Dim objMailDocument As Object
    Dim Tu As Long, Den As Long, i As Long
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    With Sheets("Print")
        Tu = .Range("M1")
        Den = .Range("O1")
        For i = Tu To Den Step 1
            .Range("M2") = i
            .Range("A1:G4").Copy 'Picture
            Set outMail = OutApp.CreateItem(0)
            With outMail
                .To = Sheets("Print").Range("G2").Value
                .Subject = "Phi" & ChrW(7871) & "u l" & ChrW(432) & ChrW(417) & "ng: " & Sheets("Print").Range("H2").Value
                .HTMLBody = "Xin chào " & "<B>" & Sheets("Print").Range("K4") & "</B>" & _
                "<BR><BR>Phòng Nhân s" & ChrW(7921) & " xin g" & ChrW(7917) & "i l" & ChrW(7841) & "i b" & ChrW(7843) & "ng chi ti" & ChrW(7871) & "t l" & ChrW(432) & ChrW(417) & "ng " & ChrW(273) & "ã tr" & ChrW(7843) & " và b" & ChrW(7843) & "ng chi ti" & ChrW(7871) & "t l" & ChrW(432) & ChrW(417) & "ng tính l" & ChrW(7841) & "i )." & _
                                "<BR><BR><BR><B>Xin c" & ChrW(7843) & "m " & ChrW(417) & "n,</B><BR>" & _
                               "<BR><B>Phòng Nhân s" & ChrW(7921) & "!</B><br><a href=https://www.giaiphapexcel.com/diendan/threads/g%E1%BB%ADi-email-t%C3%ADnh-l%C6%B0%C6%A1ng-cho-t%E1%BB%ABng-ng%C6%B0%E1%BB%9Di.48211/page-17>Xem thêm tai dây</a><br><strong>Hai Lúa Miên Tây</strong>"
                .Display
                Set objMailDocument = outMail.GetInspector.WordEditor
                objMailDocument.Range(100, 100).PasteAndFormat 1
                .send
            End With
            Set outMail = Nothing
        Next i
    End With
    Set OutApp = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Vẫn vậy anh ạ, các nội dung bé không hiện rõ được.1597306973765.png
 
Upvote 0
thnghiachau đã viết:
Tôi đã xử lý cái hình không nhhi2n thấy cho bạn được rồi nè...
Bạn chép code này vào code gởi mail của bạn nha
Mã: 
Option Explicit

' Chèn anh truc tiep vao mail
Sub SendMail2()
Dim OutApp As Object, OutMail As Object, objFSO As Object, oChart As Object
Dim Tu As Long, Den As Long, i As Long
Dim strPath As String, strFilePic As String
Dim dbWidth As Double, dbHeight As Double
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
   
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    strPath = ThisWorkbook.Path
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    strFilePic = strPath & "PicPayment.jpg"
   
    With Sheets("Print")
       
        Tu = .Range("AG2")
        Den = .Range("AH2")
        For i = Tu To Den Step 2
            .Range("AH5") = i
            If objFSO.FileExists(strFilePic) Then objFSO.DeleteFile strFilePic
            .Range("A1:AB68").CopyPicture xlScreen, xlPicture
            dbWidth = Round(.Range("A1:AB68").Width, 0)
            dbHeight = Round(.Range("A1:AB68").Height, 0)
            .Range("A1").Select
            Set oChart = .Shapes.AddChart(Width:=dbWidth, Height:=dbHeight).Chart
            oChart.Parent.Activate
            oChart.Paste
            oChart.Export Filename:=strFilePic, FilterName:="jpg"
            oChart.Parent.Delete
           
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = Sheets("Print").Range("X10").Value
                .Subject = "Phi" & ChrW(7871) & "u l" & ChrW(432) & ChrW(417) & "ng: " & Sheets("Print").Range("H2").Value
                .Attachments.Add strFilePic, 1, 0
                .HTMLBody = "Xin chào " & "<B>" & Sheets("Print").Range("K4") & "</B>" & _
                "<BR><BR>Phòng Nhân s" & ChrW(7921) & " xin g" & ChrW(7917) & "i l" & ChrW(7841) & "i b" & ChrW(7843) & "ng chi ti" & ChrW(7871) & "t l" & ChrW(432) & ChrW(417) & "ng " & ChrW(273) & "ã tr" & ChrW(7843) & " (tính sai) và b" & ChrW(7843) & "ng chi ti" & ChrW(7871) & "t l" & ChrW(432) & ChrW(417) & "ng tính l" & ChrW(7841) & "i (tính " & ChrW(273) & "úng)." & _
                                "<BR><BR><B>Xin c" & ChrW(7843) & "m " & ChrW(417) & "n,</B><BR><BR>" & _
                                "<BR><BR><B>Phòng Nhân s" & ChrW(7921) & "!</B>" & _
                                "<img src=""cid:PicPayment.jpg"">"
                .Display
                SendKeys "({DOWN})", True
                SendKeys "({DOWN})", True
                SendKeys "({DOWN})", True
                SendKeys "^({v})", True
                .Send
            End With
            If objFSO.FileExists(strFilePic) Then objFSO.DeleteFile strFilePic
            Set OutMail = Nothing
            Set oChart = Nothing
        Next i
    End With
    Set OutApp = Nothing
    Set objFSO = Nothing
    Set oChart = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Ôi ngon rồi bạn ơi. Cảm ơn bạn thnghiachau, cảm ơn anh Hai Lúa Miền Tây!
Bài đã được tự động gộp:

Hai Lúa Miền Tây đã viết:
Lạ nhỉ, Bạn xem lại giúp nó là dạng text hay là dạng ảnh nhé.
Nhấp chuột vào đây để mở rộng...
Dạng ảnh anh ạ.
 
Upvote 0
tueyennhi đã viết:
Nếu chuyển pdf thì mình phải sửa như nào? Căn bản sợ máy CNV không đọc được hoặc có người không biết. Vì vậy mình mới chọn phương án hiện ảnh trực tiếp.
Nhấp chuột vào đây để mở rộng...
Bạn coi lại bài #325 đi, tôi có đưa code cho bạn luôn rùi đó
Nhắc lại: bạn coi bài #331, Tôi cũng đã chỉnh lại việc không nhìn thấy luôn cho bạn rùi, tôi chay thử code và nhận hình OK lắm!!!
 
Upvote 0
Upvote 0
Hai Lúa Miền Tây đã viết:
Vậy bạn có chắc là bạn chạy đúng code trên không, đặc biệt chỗ
.Range("A1:G4").Copy 'Picture
Nhấp chuột vào đây để mở rộng...
Hai Lúa Miền Tây đã viết:
Vậy bạn có chắc là bạn chạy đúng code trên không, đặc biệt chỗ
Phải là
.Range("A1:G4").Copy 'Picture
Chứ không phải
.Range("A1:G4").CopyPicture
Nhấp chuột vào đây để mở rộng...
Em thay bằng vùng thực tế của em là A1:AB68 anh
Hai Lúa Miền Tây đã viết:
Vậy bạn có chắc là bạn chạy đúng code trên không, đặc biệt chỗ
Phải là
.Range("A1:G4").Copy 'Picture
Chứ không phải
.Range("A1:G4").CopyPicture
Nhấp chuột vào đây để mở rộng...
Em xin lỗi em bổ sung thêm mỗi dòng
Set objMailDocument = OutMail.GetInspector.WordEditor
objMailDocument.Range(100, 100).PasteAndFormat 1
Sửa lại bỏ picture thành .Range("A1:AB68").Copy thì cũng ổn rồi anh ạ. Cảm ơn anh nhé!
.
Bài đã được tự động gộp:

thnghiachau đã viết:
Phù phù... hết một buổi chiều bị bạn quay chóng mặt luôn....
Nhưng dù sao làm được thì mừng vì mình mới học được cái hay!!!
Cám ơn bạn nhá....
Nhấp chuột vào đây để mở rộng...
Hiiiiii, trình mình chưa thể hiểu được cái hay hay bạn khám phá. Mình xử lý công việc đã nhé. Cảm ơn rất nhiều!
 
Upvote 0
thnghiachau đã viết:
Tôi đã xử lý cái hình không nhhi2n thấy cho bạn được rồi nè...
Bạn chép code này vào code gởi mail của bạn nha
Mã: 
Option Explicit

' Chèn anh truc tiep vao mail
Sub SendMail2()
Dim OutApp As Object, OutMail As Object, objFSO As Object, oChart As Object
Dim Tu As Long, Den As Long, i As Long
Dim strPath As String, strFilePic As String
Dim dbWidth As Double, dbHeight As Double
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
   
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    strPath = ThisWorkbook.Path
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    strFilePic = strPath & "PicPayment.jpg"
   
    With Sheets("Print")
       
        Tu = .Range("AG2")
        Den = .Range("AH2")
        For i = Tu To Den Step 2
            .Range("AH5") = i
            If objFSO.FileExists(strFilePic) Then objFSO.DeleteFile strFilePic
            .Range("A1:AB68").CopyPicture xlScreen, xlPicture
            dbWidth = Round(.Range("A1:AB68").Width, 0)
            dbHeight = Round(.Range("A1:AB68").Height, 0)
            .Range("A1").Select
            Set oChart = .Shapes.AddChart(Width:=dbWidth, Height:=dbHeight).Chart
            oChart.Parent.Activate
            oChart.Paste
            oChart.Export Filename:=strFilePic, FilterName:="jpg"
            oChart.Parent.Delete
           
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = Sheets("Print").Range("X10").Value
                .Subject = "Phi" & ChrW(7871) & "u l" & ChrW(432) & ChrW(417) & "ng: " & Sheets("Print").Range("H2").Value
                .Attachments.Add strFilePic, 1, 0
                .HTMLBody = "Xin chào " & "<B>" & Sheets("Print").Range("K4") & "</B>" & _
                "<BR><BR>Phòng Nhân s" & ChrW(7921) & " xin g" & ChrW(7917) & "i l" & ChrW(7841) & "i b" & ChrW(7843) & "ng chi ti" & ChrW(7871) & "t l" & ChrW(432) & ChrW(417) & "ng " & ChrW(273) & "ã tr" & ChrW(7843) & " (tính sai) và b" & ChrW(7843) & "ng chi ti" & ChrW(7871) & "t l" & ChrW(432) & ChrW(417) & "ng tính l" & ChrW(7841) & "i (tính " & ChrW(273) & "úng)." & _
                                "<BR><BR><B>Xin c" & ChrW(7843) & "m " & ChrW(417) & "n,</B><BR><BR>" & _
                                "<BR><BR><B>Phòng Nhân s" & ChrW(7921) & "!</B>" & _
                                "<img src=""cid:PicPayment.jpg"">"
                .Display
                SendKeys "({DOWN})", True
                SendKeys "({DOWN})", True
                SendKeys "({DOWN})", True
                SendKeys "^({v})", True
                .Send
            End With
            If objFSO.FileExists(strFilePic) Then objFSO.DeleteFile strFilePic
            Set OutMail = Nothing
            Set oChart = Nothing
        Next i
    End With
    Set OutApp = Nothing
    Set objFSO = Nothing
    Set oChart = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Ahhhh, trong code của tôi bạn xóa các dòng:
.Display
SendKeys "({DOWN})", True
SendKeys "({DOWN})", True
SendKeys "({DOWN})", True
SendKeys "^({v})", True
đi nha,
Nó sẽ không hiện ra cái outlook editor mà nó send mail cho bạn luôn, như thế bạn khỏi mắc công vừa nhấn vừa đơi nó send mail rùi đợi nhấn và send kế tiếp....
Bạn đi uống cafe rùi quay lại thì xong nha!
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

O
Kết hợp hàm value
Trả lời
2
Đọc
60
VetMini
V
LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
2 3 4
Trả lời
71
Đọc
1K
VetMini
V
P
Nhờ các cao nhân cứu giúp em file excel bị lỗi phần mở rộng
Trả lời
1
Đọc
173
PHNGMINH
P
T
  • Question
Cho mình hỏi tại sao file mình chạy Sao lưu lại bị đầy bộ nhớ.
Trả lời
3
Đọc
100
BuiQuangThuan
B
phammaihuong90
Hàm tìm ngày gần nhất đạt được số lượng mục tiêu
Trả lời
4
Đọc
76
phammaihuong90
phammaihuong90
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom