Cod: Selectaţi tot
Option Explicit
Sub sendmail()
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim Flds As Variant
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = ActiveSheet.Cells(2, "I").Text
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = ActiveSheet.Cells(3, "I").Text
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
.Update
End With
With iMsg
Set .Configuration = iConf
.To = ActiveSheet.Cells(5, "B").Text
.From = ActiveSheet.Cells(4, "B").Text
.Subject = ActiveSheet.Cells(3, "B").Text
.TextBody = ActiveSheet.Cells(6, "B").Text
'.AddAttachment "c:/temp/readme.txt"
.Send
End With
Set iMsg = Nothing
Set iConf = Nothing
End Sub
1: Nu conteaza ce program de email este instalat (utilizeaza doar serverul SMTP).
2: Nu conteaza nici versiunea de office (97…2013)
3:Se poate trimite un range sau un sheet in email body, (unele programe de email nu pot face asta)
.TextBody = "file://NumePC/NumeFolder/TestFile.xls"
Daca numele fisierului contine spatii ("Test File.xls"), acestea trebuie inlocuite cu %20 :
.TextBody = "file://NumePC/NumeFolder/Test%20File.xls"
4: Se pot trimite orice tip de fisiere (Word, PDF, PowerPoint, TXT )
5: la trimitere, nu apar avertizari de securitate, ceea ce e un avantaj la trimiterea unui numar mai mare de mesaje.
Exemplul e creat pentru utilizarea serverului SMTP Google : "smtp.gmail.com", dar se poate introduce adresa serverului propriu, daca exista