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$ = "[email protected]"
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.Refresh
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

INTERNET BAĞLANTI BİLGİLERİNİ ÖĞRENMEK
Internet üzerinden alinan ve gönderilen byte miktarlari Registry icine kaydedilir. Yanliz Bu kod Windows NT altinda calismiyor. Ek olarak transfer hizini ve baglanti hizini da ögrenebiliyoruz.

Option Explicit

Private Declare Function RegOpenKeyEx Lib "advapi32.dll"Alias _
"RegOpenKeyExA" (ByVal hKey As Long, ByVal _
lpSubKey As String, ByVal ulOptions As Long, ByVal _
samDesired As Long, phkResult As Long) As Long

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal _
hKey As Long) As Long

Private Declare Function RegQueryValueEx Lib "advapi32.dll"Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName _
As String, ByVal lpReserved As Long, lpType As Long, _
lpData As Any, lpcbData As Any) As Long

Const HKEY_DYN_DATA = &H80000006
Const KEY_READ = &H19
Const ERROR_SUCCESS = 0&

Dim s1&, e1&, LBytes&, CNT&, Q&, QQ&, SUM&

Private Sub Command1_Click()
Reset
End Sub

Private Sub Form_Load()
Reset
LBytes = e1
Timer1.Enabled = True
Timer1.Interval = 100
End Sub

Private Sub Timer1_Timer()
Dim EBytes&, SBytes&, CSpeed&
EBytes = ReadBytes("Dial-Up Adapter\BytesRecvd")
SBytes = ReadBytes("Dial-Up Adapter\BytesXmit")
CSpeed = ReadBytes("Dial-Up Adapter\ConnectSpeed")

If EBytes > -1 Then Label1.Caption = EBytes - e1
If SBytes > -1 Then Label2.Caption = SBytes - s1

If SBytes > -1 And EBytes <> e1 Then
Label5.Caption = CSpeed
End If
If LBytes < EBytes Then
Q = (EBytes - LBytes) / (Timer1.Interval / 1000)
CNT = CNT + 1
Else
Q = 0
End If
SUM = SUM + Q
QQ = SUM / CNT
Label6.Caption = "[ " & QQ & " ] " & Q
LBytes = EBytes
End Sub

Private Function ReadBytes(Entry$) As Long
Dim hKey&, L&, X&, DW&
X = RegOpenKeyEx(HKEY_DYN_DATA, "PerfStats\StatData", 0, _
KEY_READ, hKey)
If X <> ERROR_SUCCESS Then Exit Function
X = RegQueryValueEx(hKey, Entry, 0&, DW, ByVal 0&, L)
If X <> ERROR_SUCCESS Then Exit Function
X = RegQueryValueEx(hKey, Entry, 0&, DW, ReadBytes, L)
If X <> ERROR_SUCCESS Then Exit Function
RegCloseKey hKey
End Function

Private Sub Reset()
e1 = ReadBytes("Dial-Up Adapter\BytesRecvd")
s1 = ReadBytes("Dial-Up Adapter\BytesXmit")
SUM = 0
CNT = 1
End Sub