Coba prosedur-prosedur berikut : (copy ke sebuah module standar yang baru)
Pastikan :
1. Terkoneksi internet, jika tidak, akan muncul pesan tidak ada koneksi
2. library cdosys.dll telah teregistrasi (umumnya ada di folder \system32,
lakukan registrasi dengan regsvr32 bila belum teregistrasi)
3. penulisan fullfilename untuk attachments benar dan ada filenya
'kode mulai dari sini
'fungsi winAPI untuk cek koneksi internet
Public Declare Function InternetGetConnectedState Lib "wininet.dll"
(lpdwFlags As Long, ByVal dwReserved As Long) As Boolean
'cek status koneksi
Public Function StatusKoneksiInet() As Long
InternetGetConnectedState StatusKoneksiInet, 0&
End Function
'kirim email pakai CDO library
'jika digunakan di Excel VBA, maka semua inputan bisa diganti dengan nilai
suatu cell
'lakukan loop terhadap To untuk mailmerge
Public Sub CDOMail()
'Dim cdoMsg As CDO.Message 'untuk referensi ke cdosys.dll diset
pada tools -> references
Dim cdoMsg As Object 'untuk referensi ke cdosys.dll tidak
diset pada tools -> references
Dim sSchema As String
If StatusKoneksiInet = 0 Then
MsgBox "Tidak ada koneksi internet"
Exit Sub
End If
'init new email object
'Set cdoMsg = New CDO.Message 'untuk referensi ke
cdosys.dll diset pada tools -> references
Set cdoMsg = CreateObject("cdo.message") 'untuk referensi ke
cdosys.dll tidak diset pada tools -> references
'setting smtp server mulai dari sini
'daftar fields configuration yang bisa digunakan lihat di :
'http://msdn.microsoft.com/en-us/library/ms526318%28v=EXCHG.10%29.aspx
sSchema = "http://schemas.microsoft.com/cdo/configuration/";
cdoMsg.Configuration.Load cdoDefaults
With cdoMsg.Configuration.Fields
.Item(sSchema & "sendusing") = 2 'cdoSendUsingPort
'lihat smtp server, portnya, setting authentic, dan security
'lihat di :
http://www.emailaddressmanager.com/tips/mail-settings.html untuk daftar
server smtp
.Item(sSchema & "smtpserver") = "smtp.googlemail.com" 'contoh smtp
untuk gmail selain smtp.gmail.com
.Item(sSchema & "smtpserverport") = 465 'outgoing gmail -> google
juga bisa di port 587
.Item(sSchema & "smtpauthenticate") = 1
.Item(sSchema & "sendusername") = "username_smtp@server_smtpnya"
.Item(sSchema & "sendpassword") = "passwordnya"
.Item(sSchema & "smtpusessl") = 1
.Update
End With
'set email mulai dari sini
With cdoMsg
'alamat dan subject. Isi dengan vbNullString jika tidak akan
digunakan. Contoh dengan multi account.
.To = "account_to_ke1@domainnya;account_to_ke2@domainnya"
.CC = "account_cc_ke1@domainnya;account_cc_ke2@domainnya"
'vbNullString
.BCC = "account_bcc_ke1@domainnya;account_bcc_ke2@domainnya"
'vbNullString
.From = "username_smtp@server_smtpnya"
.Subject = "testing"
'vbnullstring
'body email
.TextBody = "Tes pakai text body"
'jika akan pakai plain text
'.HTMLBody = "Tes pakai html body"
'jika akan pakai html text
'attachments disusun disini. non aktifkan bila tidak ada attachments
'.AddAttachment "drive:\folder\file1.ext"
'.AddAttachment "drive:\folder\file2.ext"
'.AddAttachment "drive:\folder\file3.ext"
'kirim
.Send
End With
End Sub
'kode selesai disini
Regards.
Kid.
2011/9/3 Slamet <slametha...@gmail.com>
> **
>
>
> Dear all
>
> Saya temukan code berikut ini, dan email sukses terkirim.
> akan tetapi saya ingin mengirimkan email ini bersama lampiran file nya..
> ada yang tau gimana caranya (mungkin gak yaa.. soalnya dikatakan bahwa
> thunderbird tdk memiliki object model? penasaran.com)
> mohon info dong....
>
> sebelum dan sesudahnya terima kasih yaa
>
> ''http://www.ozgrid.com/forum/showthread.php?t=66702&page=1
>
> Private Declare Function ShellExecute Lib "Shell32.dll" _
> Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
> ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory
> As String, _
> ByVal nShowCmd As Long) As Long
> Sub SEND_Excel_Calls()
>
> Dim msg As String, URL As String
> Dim Recipient As String, Subj As String
> Dim Recipientcc As String, Recipientbcc As String
>
> Dim cell As Range
> Recipient = Sheets("Info_1").Range("A1").Value
> Recipient = Sheets("Info_1").Range("A2").Value
>
> Recipientcc = Sheets("Info_1").Range("A3").Value
> Recipientbcc = Sheets("Info_1").Range("A4").Value
>
> Subj = Sheets("Info_1").Range("A5").Value
>
> For Each cell In Sheets("Info_1").Range("A7:A30") ' ADJUST TO SUIT
> msg = msg & vbNewLine & cell
> Next cell
> msg = WorksheetFunction.Substitute(msg, vbNewLine, "%0D%0A")
> msg = WorksheetFunction.Substitute(msg, vbLf, "%0D%0A")
> URL = "mailto:"; & Recipient & "?cc=" & Recipientcc & "&bcc=" &
> Recipientbcc _
> & "&subject=" & Subj & "&body=" & msg
> ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString,
> vbNormalFocus
>
> Application.Wait (Now + TimeValue("0:00:03"))
> Application.SendKeys "%s"
>
> End Sub
>
>
>
