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