Vấn đề gửi email từ Excel: Đính kèm nhiều file khác nhau, Sao chép dữ liệu từ bảng biểu vào mail, Thêm chữ ký mặc định

Liên hệ QC

randaubienghoc

Thành viên mới
Tham gia
28/1/13
Bài viết
25
Được thích
1
Thân chào các anh/ chị trên diễn đàn,

Do chỉ có chút ít hiểu biết về VBA, nên em mong muốn nhờ anh/ chị giúp đỡ sửa code để giải quyết 3 vấn đề tồn đọng khi gửi email Outlook dựa vào các thông tin từ file Excel:
1. Đính kèm nhiều file theo đường dẫn trong Excel (Theo tiêu chí cùng mã khách hàng (Customer Code) thì gom gửi chung 1 mail và đính kèm các file tương ứng trong cột dữ liệu chứa đường link tới file, bỏ qua các dòng có trạng thái Status "Y").
2. Sao chép và dán vùng dữ liệu từ Excel cột I tới O (gom các mail khác nhau theo tiêu chí mã khách hàng (Customer Code) và giữ nguyên định dạng, không lấy vùng dữ liệu ẩn, tương tự như dùng phím tắt Ctrl + V để dán) vào thân mail, bỏ qua các dòng có trạng thái Status "Y").
3. Chèn chữ ký mặc định của Outlook vào cuối mail (giữ nguyên định dạng).

Em đính kèm file macrothư mục file ví dụ cần đính kèm vào mail. Rất hy vọng nhận được hỗ trợ từ quý anh/ chị trên diễn đàn.

Em xin cảm ơn ạ.

pic 1.png
pic.png
Mã:
Sub Send_Mails()
Dim sh As Worksheet
Set sh = ThisWorkbook.ActiveSheet

Dim i As Integer

Dim OA As Object
Dim msg As Object

Set OA = CreateObject("outlook.application")

Dim last_row As Integer
last_row = Application.CountA(sh.Range("A:A"))

For i = 2 To last_row
Set msg = OA.createitem(0)
msg.To = sh.Range("A" & i).Value
msg.cc = sh.Range("B" & i).Value
msg.Subject = sh.Range("C" & i).Value
msg.body = sh.Range("D" & i).Value

If sh.Range("E" & i).Value <> "" Then
    msg.attachments.Add sh.Range("E" & i).Value
End If


msg.display

sh.Range("F" & i).Value = "Sent"

Next i

MsgBox "All the mails have been sent successfully"


End Sub
 

File đính kèm

  • EMAIL TEST.xlsm
    1.7 MB · Đọc: 9
  • Drive C.rar
    1,012 KB · Đọc: 7
Thân chào các anh/ chị trên diễn đàn,

Do chỉ có chút ít hiểu biết về VBA, nên em mong muốn nhờ anh/ chị giúp đỡ sửa code để giải quyết 3 vấn đề tồn đọng khi gửi email Outlook dựa vào các thông tin từ file Excel:
1. Đính kèm nhiều file theo đường dẫn trong Excel (Theo tiêu chí cùng mã khách hàng (Customer Code) thì gom gửi chung 1 mail và đính kèm các file tương ứng trong cột dữ liệu chứa đường link tới file, bỏ qua các dòng có trạng thái Status "Y").
2. Sao chép và dán vùng dữ liệu từ Excel cột I tới O (gom các mail khác nhau theo tiêu chí mã khách hàng (Customer Code) và giữ nguyên định dạng, không lấy vùng dữ liệu ẩn, tương tự như dùng phím tắt Ctrl + V để dán) vào thân mail, bỏ qua các dòng có trạng thái Status "Y").
3. Chèn chữ ký mặc định của Outlook vào cuối mail (giữ nguyên định dạng).

Em đính kèm file macrothư mục file ví dụ cần đính kèm vào mail. Rất hy vọng nhận được hỗ trợ từ quý anh/ chị trên diễn đàn.

Em xin cảm ơn ạ.

View attachment 240872
View attachment 240873
Mã:
Sub Send_Mails()
Dim sh As Worksheet
Set sh = ThisWorkbook.ActiveSheet

Dim i As Integer

Dim OA As Object
Dim msg As Object

Set OA = CreateObject("outlook.application")

Dim last_row As Integer
last_row = Application.CountA(sh.Range("A:A"))

For i = 2 To last_row
Set msg = OA.createitem(0)
msg.To = sh.Range("A" & i).Value
msg.cc = sh.Range("B" & i).Value
msg.Subject = sh.Range("C" & i).Value
msg.body = sh.Range("D" & i).Value

If sh.Range("E" & i).Value <> "" Then
    msg.attachments.Add sh.Range("E" & i).Value
End If


msg.display

sh.Range("F" & i).Value = "Sent"

Next i

MsgBox "All the mails have been sent successfully"


End Sub
thay msg.display bằng msg.send thi mới gởi dc.
các phần yêu cầu thì bạn làm từng cái một như code tôi thấy là tạm "biết" là OK, bạn chạy debug để kiểm tra code khi chạy là ổn thôi
 
Upvote 0
3. Chèn chữ ký mặc định của Outlook vào cuối mail (giữ nguyên định dạng).
  1. Đăng nhập vào Outlook.com và chọnCài đặt
    Thiết đặt
    > Xem tất cả cài đặt Outlook trên đầu trang.
  2. Chọn thư >soạn và trả lời.
  3. Bên dưới mục Chữ ký email, nhập chữ ký của bạn, rồi sử dụng các tùy chọn định dạng có sẵn để thay đổi diện mạo của chữ ký.
    Lưu ý: Mỗi tài khoản chỉ có một chữ ký.
    • Nếu bạn muốn chữ ký của mình xuất hiện ở cuối tất cả thư email mới mà bạn soạn, hãy chọn hộp kiểm Tự động thêm chữ ký của tôi vào thư mới mà tôi soạn.
 
Upvote 0
Hi cả nhà, em đã tìm ra được giải pháp cho vấn đề 1 & 2 ạ, còn vấn đề về chữ ký thì chưa được.
Em chia sẻ file đính kèm ạ.
Mã:
Option Explicit

Sub Email_filter()
'Excel Macro : Filter and Paste Unique Values to New Sheets and new Email
'This code writes to Range BB and then deletes that data
'It creates new worksheets that are then deleted As well
'Any row with a Sent and without an N in the F column will not be sent
'Note, I had to remove the two tables assigned in EMAIL worksheet for _
this solution to work

Application.ScreenUpdating = False
Dim x, y As Range
Dim rng, rngF As Range
Dim last, i, z, lr As Long
Dim sht As String

'specify sheet name in which the data is stored
sht = "EMAIL"

'change filter column in the following code
last = Sheets(sht).Cells(Rows.Count, "A").End(xlUp).Row
Set rng = Sheets(sht).Range("A1:R" & last)
Set rngF = Sheets(sht).Range("F1:F" & last)
i = 1
Sheets(sht).Range("A1:A" & last).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("BB1"), Unique:=True

    For Each x In Range([BB2], Cells(Rows.Count, "BB").End(xlUp))
        i = i + 1
            With rng
                .AutoFilter 'Used autofilter to control what rows sent in email
                .AutoFilter Field:=6, Criteria1:=""
                .AutoFilter Field:=1, Criteria1:=x.Value
                .AutoFilter Field:=17, Criteria1:="N"
                If .SpecialCells(xlCellTypeVisible).Count > 18 Then
                    'MsgBox .SpecialCells(xlCellTypeVisible).Count ''for troubeshooting
                    .SpecialCells(xlCellTypeVisible).Copy
                    Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
                    ActiveSheet.Paste
                    lr = .Cells(Rows.Count, "A").End(xlUp).Row
                    'MsgBox lr 'for troubeshooting
                    Columns("A:H").EntireColumn.Hidden = True
                    Columns("L:M").EntireColumn.Hidden = True
                    Columns("P:R").EntireColumn.Hidden = True
                        'Call code below
                        Send_newemail
                    Columns("A:H").EntireColumn.Hidden = False
                    Columns("L:M").EntireColumn.Hidden = False
                    Columns("P:R").EntireColumn.Hidden = False
                '   Code Removes new sheet that was created
                    Application.DisplayAlerts = False
                    Sheets(x.Text).Delete
                    Application.DisplayAlerts = True
                    Sheets(sht).Range("F" & lr).Value = "Sent"
                Else
                End If
            End With
    Next x
    ' Turn off filter
    Sheets(sht).AutoFilterMode = False
    'This code assigns Sent to the Status column
    For z = 1 To last
            If Sheets(sht).Range("Q" & z).Value = "N" Then
                Sheets(sht).Range("F" & z) = "Sent"
            End If
    Next z
    ' Remove data from column BB
    Range([BB2], Cells(Rows.Count, "BB").End(xlUp)) = ""
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With

End Sub


Sub Send_newemail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim rng As Range
    Dim lr, a As Integer
    Dim sht As String

    sht = "EMAIL"
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
  
    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection, Remove once autofilter working
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    lr = Cells(Rows.Count, "I").End(xlUp).Row
    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 OutMail
        .To = Range("A2").Value
        .CC = Range("B2").Value
        .Subject = Range("C2").Value
        .HTMLBody = Range("D2").Value & vbNewLine & RangetoHTML(rng) & vbNewLine
        .Attachments.Add Range("E2").Value
        If lr >= 3 Then 'To include Multiple attachments
            For a = 1 To (lr - 2)
            .Attachments.Add Range("E" & (a + 2)).Value
            Next a
        End If
        
        .Display ' Place apostrophe in front of .display to stop _
            drafts being made
        '.Send ' Remove apostrophe in front to automatically send the email
   End With
   With Sheets(sht)
        
   End With
   Set OutMail = Nothing
   Set OutApp = Nothing
    
End Sub

Function RangetoHTML(rng As Range)
'by Ron de Bruin
    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
 

File đính kèm

  • EMAILBulkTest.xlsm
    38.9 KB · Đọc: 25
Upvote 0
Thử 1 giải pháp đơn giản: dùng 1 phần nội dung cuối mail làm chữ ký. Nội dung này được thiết lập sẵn ở 1 sheet, trong 1 cell nào đó. Nối nội dung chính của mail với giá trị của cell "chữ ký" này.
 
Upvote 0
Thử 1 giải pháp đơn giản: dùng 1 phần nội dung cuối mail làm chữ ký. Nội dung này được thiết lập sẵn ở 1 sheet, trong 1 cell nào đó. Nối nội dung chính của mail với giá trị của cell "chữ ký" này.
Dạ, em hiểu ý anh nhưng vấn đề gặp phải là chữ ký có format kiểu chữ, font chữ rồi có cả logo đi kèm. Nếu để trong 1 cell thì không đáp ứng được yêu cầu ạ :((
 
Upvote 0
Dạ, em hiểu ý anh nhưng vấn đề gặp phải là chữ ký có format kiểu chữ, font chữ rồi có cả logo đi kèm. Nếu để trong 1 cell thì không đáp ứng được yêu cầu ạ :((
Bạn tham khảo code dưới đây cho vấn đề chữ ký trong outlook nhé
Mã:
Sub chukymail()
Dim OutApp As Object, OutMail As Object, wdDoc As Object

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

With OutMail
    .To = "vidu@gmail.com"
    .cc = ""
    .BCC = ""
    .Subject = "testmail"
    '.Attachments.Add
    .display
    Set wdDoc = .GetInspector.WordEditor
    wdDoc.Range(0, 0) = "Dear Mr A" & Chr(10) & Chr(10) & "Ghi những gì bạn muốn nói vào đây....."
    '.send
End With
End Sub
 
Upvote 0
Hi cả nhà, em đã tìm ra được giải pháp cho vấn đề 1 & 2 ạ, còn vấn đề về chữ ký thì chưa được.
Em chia sẻ file đính kèm ạ.
Tôi không cài Outlook vì không bao giờ dùng nó. Nhưng bạn thử sửa như sau.
Mã:
 With OutMail
        .To = Range("A2").Value
        .CC = Range("B2").Value
        .Subject = Range("C2").Value
        .Display
        .HTMLBody = Range("D2").Value & vbNewLine & RangetoHTML(rng) & vbNewLine & .HTMLBody
       ...
End With
Tức sửa code cũ
Mã:
.HTMLBody = Range("D2").Value & vbNewLine & RangetoHTML(rng) & vbNewLine
thành
Mã:
.Display
.HTMLBody = Range("D2").Value & vbNewLine & RangetoHTML(rng) & vbNewLine & .HTMLBody
 
Upvote 0
Dạ, em hiểu ý anh nhưng vấn đề gặp phải là chữ ký có format kiểu chữ, font chữ rồi có cả logo đi kèm. Nếu để trong 1 cell thì không đáp ứng được yêu cầu ạ :((
Vấn đề chứ ký này chắc có mỗi cách là bạn viết code HTLM.Hoặc bạn gán chữ ký ở file cell rồi copy ảnh vào trong mail.
 
Upvote 0
Tôi không cài Outlook vì không bao giờ dùng nó. Nhưng bạn thử sửa như sau.
Mã:
With OutMail
        .To = Range("A2").Value
        .CC = Range("B2").Value
        .Subject = Range("C2").Value
        .Display
        .HTMLBody = Range("D2").Value & vbNewLine & RangetoHTML(rng) & vbNewLine & .HTMLBody
       ...
End With
Tức sửa code cũ
Mã:
.HTMLBody = Range("D2").Value & vbNewLine & RangetoHTML(rng) & vbNewLine
thành
Mã:
.Display
.HTMLBody = Range("D2").Value & vbNewLine & RangetoHTML(rng) & vbNewLine & .HTMLBody
Em thử với đoạn code dưới đây thì nó không nhận ký tự "chr(10" (nghĩa là không xuống dòng được, anh có cách nào khắc phục không ạ?
Mã:
 .HTMLBody = "Dear Mr A" & Chr(10) & Chr(10) & "Ghi nh?ng gì b?n mu?n nói vào dây....." & .HTMLBody
 
Upvote 0
Vấn đề chứ ký này chắc có mỗi cách là bạn viết code HTLM.
Thì người ta dùng HTMLBody chứ có dùng Body đâu.
Hoặc bạn gán chữ ký ở file cell rồi copy ảnh vào trong mail.
Thế nếu ở mỗi thời điểm trong công việc, giao lưu, người ta phải dùng 1 chữ ký khác cho tất cả mọi email gửi trong thời kỳ đó thì sao? Họ sẽ vào Outlook sửa chữ ký. Và mỗi lần gửi từ Excel dùng Outlook thì lại phải thiết kế chữ ký trong cell Excel y hệt như trong Outlook?


Theo lô-gíc của tôi thì ở thời điểm Display nội dung thư phải được tạo. Nó giống như muốn khoe một con búp bê thì trước tiên phải tạo ra con búp bê đó. Vậy thì trong Outlook phải thiết lập sao cho chữ ký luôn luôn được chèn vào email một cách tự động. Ở thời điểm Display thì nội dung HTMLBody được xác định. Nội dung đó không có gì ngoài chữ ký được chèn tự động. Vậy thì ở thời điểm
Mã:
.HTMLBody = "ngày mai em đi" & vbNewLine & .HTMLBody
thì .HTMLBody = "ngày mai em đi" & vbNewLine & .HTMLBody = "ngày mai em đi" & vbNewLine & <chữ ký được chèn tự động> =

"ngày mai em đi"
Chữ ký được chèn tự động


Nếu chỉ dùng Body thì dĩ nhiên chữ ký rõ ràng sẽ không có định dang, hình ảnh gì cả. Lúc đó thì:
1. Thiết lập chèn chữ ký tự động vào mỗi thư.
2.
Mã:
.Display
.Body = "Ngày mai em đi" & vbNewLine & .Body
 
Upvote 0
Em thử với đoạn code dưới đây thì nó không nhận ký tự "chr(10" (nghĩa là không xuống dòng được, anh có cách nào khắc phục không ạ?
Mã:
 .HTMLBody = "Dear Mr A" & Chr(10) & Chr(10) & "Ghi nh?ng gì b?n mu?n nói vào dây....." & .HTMLBody
Thế tại sao bạn không muốn dùng vbNewLine hay vbCrLf, hoặc Chr(13) & Chr(10)?
Có những người copy ở đâu đó và dán vào vd. notepad thì thấy các dòng cứ dính vào nhau. Bởi ở nguồn người ta chỉ dùng ký tự có điểm mã = 10. Với Excel thế là đủ, nhưng ở nhiều "nơi" không đủ.
 
Upvote 0
Thì người ta dùng HTMLBody chứ có dùng Body đâu.

Thế nếu ở mỗi thời điểm trong công việc, giao lưu, người ta phải dùng 1 chữ ký khác cho tất cả mọi email gửi trong thời kỳ đó thì sao? Họ sẽ vào Outlook sửa chữ ký. Và mỗi lần gửi từ Excel dùng Outlook thì lại phải thiết kế chữ ký trong cell Excel y hệt như trong Outlook?


Theo lô-gíc của tôi thì ở thời điểm Display nội dung thư phải được tạo. Nó giống như muốn khoe một con búp bê thì trước tiên phải tạo ra con búp bê đó. Vậy thì trong Outlook phải thiết lập sao cho chữ ký luôn luôn được chèn vào email một cách tự động. Ở thời điểm Display thì nội dung HTMLBody được xác định. Nội dung đó không có gì ngoài chữ ký được chèn tự động. Vậy thì ở thời điểm
Mã:
.HTMLBody = "ngày mai em đi" & vbNewLine & .HTMLBody
thì .HTMLBody = "ngày mai em đi" & vbNewLine & .HTMLBody = "ngày mai em đi" & vbNewLine & <chữ ký được chèn tự động> =

"ngày mai em đi"
Chữ ký được chèn tự động


Nếu chỉ dùng Body thì dĩ nhiên chữ ký rõ ràng sẽ không có định dang, hình ảnh gì cả. Lúc đó thì:
1. Thiết lập chèn chữ ký tự động vào mỗi thư.
2.
Mã:
.Display
.Body = "Ngày mai em đi" & vbNewLine & .Body
Vâng em cảm ơn.
 
Upvote 0
Thế tại sao bạn không muốn dùng vbNewLine hay vbCrLf, hoặc Chr(13) & Chr(10)?
Có những người copy ở đâu đó và dán vào vd. notepad thì thấy các dòng cứ dính vào nhau. Bởi ở nguồn người ta chỉ dùng ký tự có điểm mã = 10. Với Excel thế là đủ, nhưng ở nhiều "nơi" không đủ.
Em hiểu rồi, cảm ơn anh đã cho em kiến thức bổ ích này ạ.
 
Upvote 0
Em thử với đoạn code dưới đây thì nó không nhận ký tự "chr(10" (nghĩa là không xuống dòng được, anh có cách nào khắc phục không ạ?
Mã:
 .HTMLBody = "Dear Mr A" & Chr(10) & Chr(10) & "Ghi nh?ng gì b?n mu?n nói vào dây....." & .HTMLBody
Ồ em không ngờ đơn giản vậy, chỉ cần thêm ".HTMLBoDy" vào như anh nói là được, em cảm ơn ạ :D
 
Upvote 0
Web KT
Back
Top Bottom