BeGüM

Visual Basic ile Email Göndermek

Bu programda 1 form kullanacağız ve formumuzun üzerinde 5 adet textbox olacak ve bunlar yukarıdan aşağıya sırasıyla şu şekilde adlandırılacak: txtserverdomain, txtfromemail, txttoemail, txtsubject, txtmessage. Neyin ne olduğunu karıştırmamak için metin kutularının karşısına 5 adet label ekleyerek caption değerlerini şu şekilde değiştirin (tekrar yukarıdan aşağıya ve sırayla: Sunucu adresi, Gönderen, Kime, Konu, Mesaj. Son olarak iki adet command button ekleyin ve birinin üzerindeki metni "Gönder" diğerininkini "Çıkış" olarak değiştirin. Üzerinde Gönder yazan command buttonun ismini cmdSend olarak diğerininkini ise cmdExit olarak değiştirin. Son olarak form üzerine bir adette Microsoft Winsock kontrolü ekleyin ve bunuda "w" olarak adlandırın. Form üzerindeki metin kutularını, label leri ve command button ları gözünüze hoş görünecek sekilde form üzerinde yerleştirin. İşin zor kısmı bitti.

Şimdi aşağıdaki kodu alarak değiştirmeden formunuzun kod penceresine yapıştırın. Daha sonra nerede ne yaptığımızı okuyun..
Option Explicit
Private Response As String

Sub SendEmail(ServerDomain As String, FromEmail As String, ToEmail As String, Subject As String, Body As String)

w.LocalPort = 0

If w.State <> sckClosed Then w.Close

w.Protocol = sckTCPProtocol
w.RemoteHost = ServerDomain
w.RemotePort = 25
w.Connect

WaitForResponse ("220")

w.SendData "HELO " & ServerDomain & vbCrLf
WaitForResponse ("250")

w.SendData "MAIL FROM: <" & FromEmail & ">" & vbCrLf
WaitForResponse ("250") 'wait for response

w.SendData "RCPT TO: <" & ToEmail & ">" & vbCrLf
WaitForResponse ("250") 'wait for response

w.SendData ("data" & vbCrLf)

WaitForResponse ("354")
w.SendData "From: " & FromEmail & vbCrLf
w.SendData "X-Mailer: BASTON SMTP Mailer" & vbCrLf
w.SendData "To: " & ToEmail & vbCrLf
w.SendData "Subject: " & Subject & vbCrLf

w.SendData Body & vbCrLf

w.SendData "." & vbCrLf
WaitForResponse ("250")

w.SendData "quit" & vbCrLf
WaitForResponse ("221")

w.Close
MsgBox "Mesajınız başarıyla gönderildi.", vbExclamation, "Mesajını Gönderildi."
End Sub
Sub WaitForResponse(ResponseCode As String)
Dim Reply As Integer
Dim Start As Single
Dim Tmr As Single
Start = Timer
While Len(Response) = 0
Tmr = Start - Timer
DoEvents
If Tmr > 10 Then
MsgBox "Hata:" + vbCrLf + "İşlem zamanaşımına uğradı!", vbExclamation, "İşlem Başarısız"
Exit Sub
End If
Wend
While Left(Response, 3) <> ResponseCode
DoEvents
If Tmr > 10 Then
MsgBox "Hata:" + vbCrLf + "Geçersiz bir yanıt alındı: " + Response + vbCrLf + "Expected code: " + ResponseCode, vbExclamation, "İşlem Başarısız."
Exit Sub
End If
Wend
Response = ""
End Sub
Private Sub cmdExit_Click()
Unload Me
End
End Sub
Private Sub cmdSend_Click()
SendEmail txtServerDomain, txtFromEmail, txtToEmail, txtSubject, txtMessage
End Sub
Private Sub w_DataArrival(ByVal bytesTotal As Long)
w.GetData Response
End Sub

03 nolu satırda email gönderme işlemini gerçekleştirecek Sub'ı kodlamaya başlıyoruz. Gördüğünüz gibi email gönderme işleminde bazı parametreler kullanıyoruz ve bu satırda kullanacağımız parametrelerin kullanacağı veri türlerini tanımlıyoruz. Bunlar: ServerDomain, FromEmail, ToEmail, Subject ve Body.

06 nolu satırda Winsock nesnesine yerel port olarak 0'ı gösteriyoruz. Bunu yapmazsak programın her çalıştırılışında 1 email gönderebiliriz.

08 nolu portta eğer winsock açık ise, kapatıyoruz.
10. satırda programa TCP/IP protokolünü kullanacağımızı belirtiyoruz.
11. satırda kullanacağımız mail sunucusunun adresini belirtiyoruz.
12. satırda mail sunucusuna bağlanmak istediğimiz bağlantı noktasını belirliyoruz. smtp sunucuları varsayılan olarak 25 numaralı portu kullandıklarından bizde 25 numaralı portu kullanmak istediğimizi belirtiyoruz. Ancak bu portu değiştirmeniz gerekebilir. Örneğin bizim networkümüzdeki mail sunucusu farklı bir port kullandığından bu programı kendi mail sunucumuzu kullanarak mail yollamak için kullanmak istediğimde port numarasını bizim mail sunucumuzun kullandığı portla değiştirmem gerekiyor.
13. satırda karşı bilgisayarla bağlantı kuruyoruz.

Port numaraları değişebilsede asla değişmeyecek bazı şeyler vardır. Pek güçlü bir cümle olmasa da anlatmak istediğim; biz mail sunucumuzun konfigurasyonu esnasında kullanacağı portu belirleyebiliriz ancak smtp protokolünün standart olarak kullandığı mesaj kodlarını değiştiremeyiz. Gördüğünüz gibi programımız 15. satırda karşı bilgisayardan bağlantımızın onaylandığına dair bir mesaj bekliyoruz ve bu mesajın kodu 220.
Programımız 220 nolu mesajı alana kadar bekleyecek, bu mesajın karşı bilgisayardan gelmemesi halinde işlemimiz Time Out olacaktır. Karşı taraftan 220 nolu mesaj geldi mi? Devam edelim o zaman..

17. satırda winsock nesnesi ile sunucuya HELO mesajı gönderiyoruz ve mesajımıza karşılık 250 numaralı mesajı bekliyoruz.
Aynı şekilde buradada programımız 250 nolu mesajı alana kadar bekleyecektir.

20. satırda maili gönderenin adresini sunucuya iletiyoruz ve işlemimize karşılık bir yanıt bekliyoruz.

23. satırda mailin kime gittiğini bildiriyoruz.

26. satırda sunucuya başlık "header" ve mesaj bilgilerini iletmeye başlayacağımızı bildiriyoruz ve 354 nolu mesajı bekliyoruz.

29. satırda maili gönderenin email adresini,
30. satırda maili gönderen yazılıma ait bilgileri (bu bilgiyi kendi programınızın ismiyle değiştirin. Tabii baston diye bir email yazılımı hazırlıyorsanız böylede kalabilir),
31. satırda mailin kime gittiğini,
32. satırda mailin başlığını
34. satırda txtMessage adlı text kutusundaki mesajı, yani mail metnini gönderiyoruz.
36. satırda veri/başlıkları sonlandırıyoruz ve bir sonraki satırda 250 nolu mesajın sunucudan gelmesini bekliyoruz.

39. satırda sunucuya quit mesajı gönderiyor ve sunucuya bağlantıyı kapatma isteğimizi bildiriyoruz.
40. satırda sunucudan 221 kodlu mesajı yani sunucunun oturumumuzu kapattığına dair mesajı bekliyoruz.
42. satırda winsock u kapatıyoruz.

Eğer işlemlerin uygulanması esnasında bir sorunla karşılaşılmışsa program bir hata mesajı verecektir. Böyle bir durumda programın hata mesajından sonra kapanmaması için hata tuzaklama kısmını hazırlamanız gerekiyor. Eğer bir hata ile karşılaşılmamış ve herşey yolunda gitmişse kullanıcıya mailin gönderildiğini bildiriyoruz.

Şimdi (sıralama biraz ters olsa da) maili gönderme işlemi esnasında kullandığımız WaitForResponse sub ını hazırlıyoruz.
Kullanacağımız değişkenleri tanımlıyoruz.
49. satırda bir timer başlatıyoruz ve başlangıç değerini start adlı değişkenimize değer olarak atıyoruz.
51. satırda işlemin başlamasından beri geçen zamanı tesbit ediyoruz.
53.satırda sunucunun bizi yanıtlamaması halinde işlemi zamanaşımına uğradığı için kesiyoruz.
57. satırdan itibaren sunucudan geçersiz bir mesaj almamız halinde programın uygulayacağı işlemleri kodluyoruz.
69. satırda programı sonlandırmak için gerekli kodu yazıyoruz.
73. satırda ise mail göndermek için gerekli komut ve parametrelerini yazıyoruz.

75. satırda (yine hatalı sıralama) mail gönderme işlemi esnasında sunucudan gelen yanıtları almak için kullanacağımız sub'ı kodluyoruz.

E-MAIL ALMAK
Bu kod sayesinde winsock üzerinden email alabiliriz. Örneğin, kendimize bir e-mail istemci programlayabiliriz.

Option Explicit

Dim Result$, Mail$()
Dim TOut As Boolean

Const TimeOut = 10
Const Port% = 110

Const Host$ = "www.hotmail.com" 'Server adi
Const Account$ = "ali" ' Kullanici adi
Const Password$ = "veli" 'Sifre

Private Sub Form_Load()
Timer1.Enabled = False
End Sub

Private Sub List1_Click()
Text1.Text = Mail(List1.ListIndex + 1)
End Sub

Private Sub Timer1_Timer()
TOut = True
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Winsock1.GetData Result
End Sub

Private Function Response() As Boolean
TOut = False
Result = ""
Timer1.Interval = TimeOut * 1000
Timer1.Enabled = True

Do While Len(Result) = 0
DoEvents
If TOut Then Exit Do
Loop
Response = TOut
End Function

Private Sub Command1_Click()
Dim No&, X&, Bytes&, Dat$, Corr%, RecBytes&

If Winsock1.State = sckClosed Then
List1.Clear
Text1.Text = ""

'### Server a baglanti kurup üye girisi
Label1.Caption = "Host Araniyor"
Winsock1.LocalPort = 0
Winsock1.Connect Host, Port
If Response Then GoTo ERRSub

Label1.Caption = "Hesap Araniyor"
Winsock1.SendData "user " & Account & vbCrLf
If Response Then GoTo ERRSub

Label1.Caption = "Sifre Gönderiliyor"
Winsock1.SendData "pass " & Password & vbCrLf
If Response Then GoTo ERRSub

'### Email sayisini ve büyüklügünü sor
Label1.Caption = "Posta Kutusu denetimi"
Winsock1.SendData "stat" & vbCrLf
If Response Then GoTo ERRSub

Call StatData(Result, No, Bytes)
If No > 0 Then
ReDim Mail(1 To No)
ProgressBar1.Value = 0
ProgressBar1.Max = Bytes

Dat = CStr(No) & " Email"
If No > 1 Then Dat = Dat & "s"
Dat = Dat & " mit " & CStr(Bytes) & " Bytes"
Label2.Caption = Dat

For X = 1 To No
'### Mail Büyüklügünü Sorgula
Label1.Caption = "Mesaj" & CStr(X) & " inceleniyor"
Winsock1.SendData "list " & CStr(X) & vbCrLf
If Response Then GoTo ERRSub

Call StatData(Result, No, Bytes)
List1.AddItem CStr(X) & ". Email " & CStr(Bytes)

'### Mail i indir
Winsock1.SendData "retr " & CStr(X) & vbCrLf
Label1.Caption = "Mesaj" & CStr(X) & " cagir"
Corr = 13 + Len(CStr(Bytes))

Do While Len(Mail(X)) < Bytes + Corr - 1
If Response Then GoTo ERRSub
Mail(X) = Mail(X) & Result
ProgressBar1.Value = Abs(RecBytes + Len(Mail(X)) - Corr - 1)
Loop

RecBytes = RecBytes + Bytes - 1
Mail(X) = Mid$(Mail(X), Corr + 1, Len(Mail(X)))
Mail(X) = Left$(Mail(X), Len(Mail(X)) - 2)

If Check1.Value = vbChecked Then
'### Mail zum Löschen markieren
Winsock1.SendData "dele " & CStr(X) & vbCrLf
Label1.Caption = "Mesaj" & CStr(X) & " sec"
If Response Then GoTo ERRSub
End If

Next X
ProgressBar1.Value = 0
ElseIf No = 0 Then
Label2.Caption = "Email Yok"
Else
Label2.Caption = "Hata"
End If

If Check1.Value = vbChecked Then
Label1.Caption = "Baglantiyi kopar ve mailleri sil"
Else
Label1.Caption = "Baglanti Koparma"
End If

'### Üye Cikisi ve olaylarin silinmesi
Winsock1.SendData "quit" & vbCrLf
If Response Then GoTo ERRSub

Winsock1.Close
Label1.Caption = ""
End If
Exit Sub

ERRSub:
MsgBox ("Transfer Hatasi")
Winsock1.Close
Label1.Caption = ""
End Sub

Private Sub StatData(Data$, ByRef No&, ByRef Bytes&)
Dim Dat$, X&
X = InStr(1, Data, "+OK")
If X <> 0 Then
Data = Mid$(Data, X, Len(Data))
Dat = Trim$(Mid$(Data, 4, Len(Data)))
X = InStr(1, Dat, " ")
If X <> 0 Then
No = Val(Left$(Dat, X))
Bytes = Val(Mid$(Dat, X + 1, Len(Dat)))
Else
No = -1
End If
End If
End Sub

Tarih: Sat May 20, 2006 11:38 pm Mesaj konusu:


E-MAIL GÖNDERMEK
Winsock kontrolu sayesinde e-mail göndermek mümkündür. Geriye dönen deger durum hakkinda bilgi verir.

Option Explicit

Dim Mailing As Boolean
Dim Result$, Sec%, TimeOut%

Const Server$ = "www.netyardim.net"
Const Gonderen$ = "M.Selçuk Batal"
Const Email$ = "webmaster@netyardim.net"
Const Domain$ = "www.netyardim.net"

Private Sub Form_Load()
TimeOut = 20
Text1.Text = Server
Text2.Text = Gonderen
Text3.Text = Email
Text8.Text = TimeOut
ProgressBar1.Min = 0
ProgressBar1.Value = 0
ProgressBar1.Max = TimeOut * 5

Text1.SelStart = 0
Text1.SelLength = Len(Text1.Text)
End Sub

Private Sub Command1_Click()
If Mailing = False Then
If SendMail(Text1.Text, Text2.Text, Text3.Text, Text4.Text, _
Text5.Text, Text6.Text, Text7.Text) Then
MsgBox ("Email Basariyla Gönderildi")
Else
MsgBox ("Hata Olustu")
End If
Else
MsgBox ("Son Email Gönderiliyor!")
End If
End Sub

Private Sub Text8_Change()
TimeOut = Val(Text8.Text)
End Sub

Private Sub Timer1_Timer()
Sec = Sec + 1
ProgressBar1.Value = Sec - 1
DoEvents
End Sub

Private Function Response(RCode$) As Boolean
Sec = 0
Timer1.Interval = 200
Timer1.Enabled = True
Response = True

Do While Left$(Result, 3) <> RCode
DoEvents
If Sec > TimeOut * 5 Then
If Len(Result) Then
ShowStatus ("SMTP Error! Yanlis Dönen Deger")
Else
ShowStatus ("SMTP Error! Time out")
End If
Response = False
Exit Do
End If
Loop

Result = ""
ProgressBar1.Value = 0
Timer1.Enabled = False
End Function

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Winsock1.GetData Result
End Sub

Private Sub ShowStatus(ByVal Text$)
Label7.Caption = Text
Label7.:-):-):-):-):-):-):-)
End Sub

Private Function SendMail(SMTP$, FromName$, FromMail$, ToName$, _
ToMail$, Subj$, Body$) As Boolean
Dim MAIL$, outTO$, outFR$
If Mailing = True Then Exit Function
Mailing = True
MousePointer = vbHourglass

If Winsock1.State = sckClosed Then
On Error GoTo ERRORMail
Winsock1.LocalPort = 0
outFR = "mail from: " & FromMail & vbCrLf
outTO = "rcpt to: " & ToMail & vbCrLf & "data" & vbCrLf

MAIL = MAIL & "From: " & FromName & " <" & FromMail & ">"
MAIL = MAIL & vbCrLf & "Date: " & Format(Date, "Ddd")
MAIL = MAIL & ", " & Format(Date, "dd Mmm YYYY") & " "
MAIL = MAIL & Format(Time, "hh:mm:ss") & " +0100" & vbCrLf
MAIL = MAIL & "X-Mailer: Visual Basic Mailing Tester"
MAIL = MAIL & vbCrLf & "To: " & ToName & " <" & ToMail & ">"
MAIL = MAIL & vbCrLf & "Subject: " & Subj & vbCrLf
MAIL = MAIL & vbCrLf & Body & vbCrLf & vbCrLf & "." & vbCrLf

'### Baglanti Kur
ShowStatus ("Baglan...")
Winsock1.Protocol = sckTCPProtocol
Winsock1.RemoteHost = SMTP
Winsock1.RemotePort = 25
Winsock1.Connect
If Not Response("220") Then GoTo ERRORMail

'### Baglanildi
ShowStatus ("Baglanti Kuruldu")
Winsock1.SendData ("HELO " & Domain & vbCrLf)
If Not Response("250") Then GoTo ERRORMail

'### Mail Gönder
ShowStatus ("Mail Gönder")
Winsock1.SendData (outFR)
If Not Response("250") Then GoTo ERRORMail
Winsock1.SendData (outTO)
If Not Response("354") Then GoTo ERRORMail
Winsock1.SendData (MAIL)
If Not Response("250") Then GoTo ERRORMail

'### Baglanti Sonlandir
ShowStatus ("Sonlandir")
Winsock1.SendData ("quit" & vbCrLf)
If Not Response("221") Then GoTo ERRORMail
ShowStatus ("Mail Gönderildi!")
SendMail = True
End If

ERRORMail:
Mailing = False
Winsock1.Close
MousePointer = vbDefault
Exit Function
End Function
kara-kral



Kayıt: 14 Aug 2005
Mesajlar: 1343
Nerden: İstanbul

Component Kullanarak E-mail (+dosya) Göndermek
Aemail.dll ile kolaylıkla mail gönderebiliriz. Öncelikle mail yollayabilmemiz için bilgisayarımızda bir e-mail servera yada pop desteği veren bir e-maila sahip olmamız gerekmektedir.

Aemail.dll ile kolaylıkla mail gönderebiliriz. Öncelikle mail yollayabilmemiz için bilgisayarımızda bir e-mail servera yada pop desteği veren bir e-maila sahip olmamız gerekmektedir. (Bunun için ücretsiz olarak [Linkleri üyelerimiz görebilir.Üyeyseniz Mailinizi OnaylayınBurayı tıklayarak üyemiz olabilirsiniz.] adresinden mail adresi alabilirsiniz).
Fazla uzatmadan gerekli componentler: 11 tane textbox , checkbox(check1), Durum (label) ,buton (command1) ve text başlıkları için label lar.

Program Kodları



Public HTA As AEMAILLib.SmtpMail 'mail için

'saat için
Dim lpSystemTime As SYSTEMTIME
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private Declare Function SetSystemTime Lib "kernel32" (lpSystemTime As SYSTEMTIME) As Long


Dim dak, sa, yil, ay, gun As Byte


Private Sub Yolla()

HTA.Clear
Text11.Text = HTA.ExpirationDate 'son kull tarihi
HTA.AccountName = Text1.Text '"HDE.Software@HoTPoP.com"
HTA.AccountPassword = Text2.Text '"*******"
HTA.HostName = Text3.Text '"smtp.HoTPoP.com"
HTA.FromAddress = Text4.Text '"HDE.Software@HoTPoP.com"
HTA.FromName = Text5.Text '"H.D.E. Spyware"
HTA.AddTo Text6.Text, "" '"hde.contact@gmail.com", ""
HTA.Subject = Text7.Text
HTA.Body = Text9.Text
HTA.BodyType = 1
HTA.AddAttachment Text8.Text '("c:\excel.xls")
HTA.Priority = 1 '1 ile 5 arası
HTA.Send 'Maili Yollar
Durum = "HaTa KoDu: " & HTA.LastError 'Hata

End Sub


Private Sub TgeriAl()

dak = Minute(Time)
sa = Hour(Time)
yil = Year(Date)
ay = Month(Date)
gun = Day(Date)

If sa < 3 Then
lpSystemTime.wHour = sa + 21
lpSystemTime.wDay = gun - 1
Else
lpSystemTime.wHour = sa - 3
lpSystemTime.wDay = gun
End If
lpSystemTime.wMinute = dak
lpSystemTime.wSecond = 0
lpSystemTime.wMilliseconds = 0
lpSystemTime.wMonth = ay
lpSystemTime.wYear = 2004

SetSystemTime lpSystemTime

'yıl 2004 oldu

End Sub
Private Sub TDuzelt()



If sa < 3 Then
lpSystemTime.wHour = sa + 21
lpSystemTime.wDay = gun - 1
Else
lpSystemTime.wHour = sa - 3
lpSystemTime.wDay = gun
End If


lpSystemTime.wMinute = dak
lpSystemTime.wSecond = 55

lpSystemTime.wMonth = ay
lpSystemTime.wYear = yil

SetSystemTime lpSystemTime 'tarih eskiye döndü
End Sub

Private Sub Command1_Click()

If Check1.Value = 1 Then
TgeriAl
Yolla
TDuzelt
Else
Yolla
End If

End Sub

Private Sub Form_Load()

Set HTA = CreateObject("ActivXperts.SmtpMail")
Text10.Text = HTA.ExpirationDate

End Sub

__________________