Gửi email tự động bằng Excel.

[vietnam123]

Mình tìm được đoạn mã này khá hay, đã test thành công với Outlook và Gmail. Rất tiện cho việc gửi data khi xử lý xong.
Mail a different file(s) to each person in a range Index (Only working when you use Excel-Outlook 2000 -2007)
Ron de Bruin ( Last update 28 Oct 2006)

Make a list in Sheets("Sheet1") withIn

column A : Names of the peopleIn
column B : E-mail addressesIn
column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)

​

The Macro will loop through each row in Sheet1 and if there is a E-mail address and file names that exist in that row it will create a mail with this information and send it.

Sub Send_Files()
'Working in 2000-2007
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range, FileCell As Range, rng As Range
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
    'Enter the file names in the C:Z column in each row
    Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
    If cell.Value Like "?*@?*.?*" And Application.WorksheetFunction.CountA(rng) > 0 Then
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = cell.Value
            .Subject = "Testfile"
            .Body = "Hi " & cell.Offset(0, -1).Value
            For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                If Trim(FileCell) <> "" Then
                    If Dir(FileCell.Value) <> "" Then
                        .Attachments.Add FileCell.Value
                    End If
                End If
            Next FileCell
            .Send
            'Or use Display
        End With
        Set OutMail = Nothing
    End If
Next cell
Set OutApp = Nothing
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With
End Sub

Xem thêm ở đây http://www.rondebruin.nl/sendmail.htm

 

[thesun303]

Các bác giúp em xem cái file này cái. File em đính kèm đây


cái code của nó thế này, em ko biết đính kèm file lên thế nào, các bác thông cảm nhé, Em muốn gửi vào tất cả các mail trong ảnh mà ko phải ấn chữ ALLOW, Bác pro nào viết code nốt cho em được ko ạ! Em cảm ơn các bác!

Sub SendMail()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim Addresslist As Scripting.Dictionary
Application.ScreenUpdating = False
Set Addresslist = New Scripting.Dictionary
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon

For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.Row, "J").Value) = "yes" Then
On Error Resume Next
Addresslist.Add cell.Value, cell.Value
If Err.Number = 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = cell.Value
.Subject = "Phieu luong: " & Cells(cell.Row, "A").Value
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Xin vui long xem chi tiet bang luong nhu ben duoi:" & _
vbNewLine & vbNewLine & _
"+ He So Chuc Danh: " & Cells(cell.Row, "C").Value & _
vbNewLine & _
"+ So ngay cong: " & Cells(cell.Row, "D").Value & _
vbNewLine & _
"+ Luong CD: " & Cells(cell.Row, "E").Value & _
vbNewLine & _
"+ Phu cap DT: " & Cells(cell.Row, "F").Value & _
vbNewLine & _
"+ Phu cap doan the: " & Cells(cell.Row, "G").Value & _
vbNewLine & _
"+ Tru BHXH, BHYT: " & Cells(cell.Row, "H").Value & _
vbNewLine & _
"+ Luong CK: " & Cells(cell.Row, "I").Value & _
vbNewLine & vbNewLine & _
"Cam on"
.Send 'Or use Display
End With
Set OutMail = Nothing
End If
On Error GoTo 0
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

C

 

[MNThao]

Có bác nào biết làm thế nào để lựa chọn đc acc để gửi đi ko? Outlook của e đang có 2 account, dùng cách này mỗi khi gửi e lại phải đổi account mặc định và khi gửi xong thì lại chuyển lại, cũng hơi hơi bí tí các bác ạ.
Em đã thử gán From trong đoạn lệnh gửi đi nhưng nó báo lỗi các bác ạ.

 

[vu_tuan_manh_linh]

Mình có viết đoạn code này có thể send mail mà k cần Outlook,
nhưng code đang bị lỗi như sau
- chỉ gưi được 1-10 mail
-mỗi vòng lại tăng số file đính kèm

Đã nghiên cứu code của bạn, khá hay đấy. Mỗi vòng tăng file đính kèm vì Set Flds ngoài vòng lặp for. Tôi sửa lại bằng cách đặt iMsg đầu vòng lặp for, cuối vòng lặp for thì giải phóng biến này. Đặt Flds trong vòng lặp for. Tuy giải quyết được việc tăng số file trong mỗi mail gửi, nhưng thời gian thao tác sẽ tăng lên đáng kể.

 

[haiuyen]

Dear cả nhà mình

Mình có 1 file đặt phòng khách sạn nhưng khi gửi thì mail k hiện chữ ký mình đã set.
Vì thế mình tìm được đoạn code để có thể hiện được cả chữ ký nhưng mình k biết phải kết hợp 2 code này như thế nào.
Ngoài ra mình muốn chuyển font chữ thành Times New Roman nhưng cũng chưa biết phải làm thế nào.
Nhờ mọi người giúp mình nhé.
Cảm ơn cả nhà nhiều
Đoạn code mình tìm đc đây à:
Sub Mail_Outlook_With_Signature_Html_1()
' Working in Office 2000-2013
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String

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

strbody = "p style='font-family:calibri;font-size:16.5'" & "Dear " & Range("D74") & "," (HTML tags not included)

On Error Resume Next

With OutMail
.Display
.To = Range("H74")
.CC = ""
.BCC = ""
.Subject = ""
.HTMLBody = strbody & .HTMLBody
.Display
End With

On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

 

[fia090480]

Mình tìm được đoạn mã này khá hay, đã test thành công với Outlook và Gmail. Rất tiện cho việc gửi data khi xử lý xong.
Mail a different file(s) to each person in a range Index (Only working when you use Excel-Outlook 2000 -2007)
Ron de Bruin ( Last update 28 Oct 2006)

Make a list in Sheets("Sheet1") withIn

column A : Names of the peopleIn
column B : E-mail addressesIn
column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)

​

The Macro will loop through each row in Sheet1 and if there is a E-mail address and file names that exist in that row it will create a mail with this information and send it.

Sub Send_Files()
'Working in 2000-2007
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range, FileCell As Range, rng As Range
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
    'Enter the file names in the C:Z column in each row
    Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
    If cell.Value Like "?*@?*.?*" And Application.WorksheetFunction.CountA(rng) > 0 Then
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = cell.Value
            .Subject = "Testfile"
            .Body = "Hi " & cell.Offset(0, -1).Value
            For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                If Trim(FileCell) <> "" Then
                    If Dir(FileCell.Value) <> "" Then
                        .Attachments.Add FileCell.Value
                    End If
                End If
            Next FileCell
            .Send
            'Or use Display
        End With
        Set OutMail = Nothing
    End If
Next cell
Set OutApp = Nothing
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With
End Sub

Xem thêm ở đây http://www.rondebruin.nl/sendmail.htm

bạn mình nó lỗi này thì làm sao bạn, mong bạn chỉ giúp
run time error 429
activex component can't create object

 

[tueyennhi]

Cho em hỏi đoạn code này là cho vào outlook hay excel vậy?
Và dòng này em không hiểu
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
Theo em nghĩ ý nó là đặt đường dẫn cho file đính kèm mail, nhưng C:Z là sao? Tại sao không phải là tại C thì điền đường dẫn mà là C:Z



Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range

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

Set sh = Sheets("Sheet1")

Set OutApp = CreateObject("Outlook.Application")

For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")

If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)

With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value

For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell

.Send 'Or use .Display
End With

Set OutMail = Nothing
End If
Next cell

Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

 

[Sil_90]

Mình tìm được đoạn mã này khá hay, đã test thành công với Outlook và Gmail. Rất tiện cho việc gửi data khi xử lý xong.
Mail a different file(s) to each person in a range Index (Only working when you use Excel-Outlook 2000 -2007)
Ron de Bruin ( Last update 28 Oct 2006)

Make a list in Sheets("Sheet1") withIn

column A : Names of the peopleIn ​

column B : E-mail addressesIn ​

column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)​

​

​

The Macro will loop through each row in Sheet1 and if there is a E-mail address and file names that exist in that row it will create a mail with this information and send it.

Sub Send_Files()
'Working in 2000-2007
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range, FileCell As Range, rng As Range
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
    'Enter the file names in the C:Z column in each row
    Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
    If cell.Value Like "?*@?*.?*" And Application.WorksheetFunction.CountA(rng) > 0 Then
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = cell.Value
            .Subject = "Testfile"
            .Body = "Hi " & cell.Offset(0, -1).Value
            For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                If Trim(FileCell) <> "" Then
                    If Dir(FileCell.Value) <> "" Then
                        .Attachments.Add FileCell.Value
                    End If
                End If
            Next FileCell
            .Send
            'Or use Display
        End With
        Set OutMail = Nothing
    End If
Next cell
Set OutApp = Nothing
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With
End Sub

Xem thêm ở đây http://www.rondebruin.nl/sendmail.htm

Hi Aduit,
cho mình hỏi phần Body:
mình muốn gửi nội dung email là
I Would like to send the updated Alt change & thêm phần nội dung ở cột G của sheet (1),
vậy thì mình có thể viết code như thế nào? bạn có thể giúp mình không?
br/Huyen Ngo

 

[netuser36]

mình có 2 sheet, 1 seet chứa thông tin địa chỉ email,..., 1 sheet chứa nội dung mail; nhờ các bạn cho mình code để gủi hàng loạt mail, không có đính kèm. xin cảm ơn.

 

[anh1234]

Em thực hiện đoạn mã bị lỗi. Bác nào sửa giúp em với ạ
Runtime '-2147417851(80010105)'
method "Subject" of object"-Mailitem'Failed

em dùng office 2010




Sub Send_Files()

Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range

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

Set sh = Sheets("Sheet1")

Set OutApp = CreateObject("Outlook.Application")

For Each cell In sh.Columns("C").Cells.SpecialCells(xlCellTypeConstants)
'thay cot C là cot chua dia chi mail

'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("D1:H1")

If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)

With OutMail
.to = cell.Value
.Subject = cell.Offset(0, -2) >>>>Lỗi

.Body = "hi" & cell.Offset(0, -1).Value

For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell

.Display
End With

Set OutMail = Nothing
End If
Next cell

Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub