Visual Basic Dersleri-1 Microsoft firması tarafından geliştirilen Visual Basic, atası olan QBASIC derleyicisinin geliştirilmiş ve Windows ortamına uyarlanmış olan sürümü olarak adlandırılabilir. Windows ortamına uyarlandığı için de Nesneye Yönelimli bir dildir. VBX kontrollerini destekleyen ilk dillerden biridir. VBasic'de, 1.0 sürümünden 6.0 sürümüne kadar bir çok yenilik ve değişiklik olmuştur. Bunlardan biri de, arayüzünün güçlü ve etkili bir görünüm kazanmasıdır. Visual Basic, devamlı geliştiği bu süre sonunda yüksek hızlı uygulamalar, OLE serverlar, ActiveX kontrolleri ve daha bir çok şey geliştirilebilecek hale gelmiştir. Microsoft Windows için program geliştiren programcıların yüzde yirmibeşi Visual Basic'i tercih etmektedirler. Visual Basic'i en popüler programlama dillerinden biri yapan en önemli nedenlerden biri de büyük olasılıkla kolay olmasıdır. Visual Basic de program yazmak için çok fazla teknik bilgiye sahip olmak gerekmez. Sadece kontrolleri form üzerine yerleştirmek ve kodu yazmak yeterli. Kısaca Visual Basic, programcıyı, programın kullanıcıya yansıyan şekli için kod yazmak zorunda bırakmayan bir dildir. Zamanla Microsoft dışındaki bazı şirketler tarafından benzer programlama dilleri geliştirildi. Muhtemelen bunların en popüleri Borland Delphi'dir. STRING İŞLEMLERİ StrComp: String Karsilastirma StrComp (String1, String2, ) String1 : Karsilastirilacak ilk String String2 : Karsilastirilacak ikinci String Sart : 0 ise büyük harf kücük harf ayrimi yapar 1 ise yapmaz Geri Dönen deger 0 ise stringler esittir. Negatif ise String2 Pozitif ise String1 büyüktür. Büyüklük alfabetik siraya göre belirlenir. StrConv: Stringi Verilen Moda cevirir. StrConv String : cevirilecek metin Mod : vbLowerCase = Kücük harfe cevrilir vbUpperCase = Büyük harfe cevrilir vbProperCase = Ilk harf büyük digerleri kücük VbFromUnicode = Unicode'dan cevrilir vbUnicode = Unicode'a cevrilir vbHiragana = Hiragana vbKatakana = Katakana vbNarrow = Dar vbWide = Genis Option Compare Binary: General Declaration kismina yazilirsa stringler büyük-kücük ayrimi yapilarak karsilastirilir. Option Compare Text: General Declaration kismina yazilirsa stringler büyük-kücük ayrimi yapilmadan karsilastirilir. Ucase : Girilen stringi büyük harfe cevirir Ucase 'dönen deger ARABA LCase : Girilen stringi kücük harfe cevirir LCase 'dönen deger araba LTrim : String'in solundaki bosluklari kaldirir LTrim 'dönen deger "Kalem " RTrim : String'in sagindaki bosluklari kaldirir RTrim 'dönen deger " Kalem" Trim : String'in iki tarafindaki bosluklari kaldirir Trim 'dönen deger "Kalem" Len : String'in karakter sayisini verir. Bosluklar dahil Len 'dönen deger 10 Right : String'in sag tarafindan x sayisi kadar karakter verir Right("Bilgisayar",5) 'dönen deger "sayar" Left : String'in sol tarafindan x sayisi kadar karakter verir Left("Bilgisayar",5) 'dönen deger "Bilgi" Mid : String'in bastan uzunluk kadar karakteri verir. uzunluk verilmesse metnin sonuna kadar. Mid("Bilgisayar",4,4) ' dönen deger "gisa" Mid("Bilgisayar",4) ' dönen deger "gisayar" Instr : String'in icinde verilen karakteri arar. Bulunursa bastan kacinci karakter oldugu geri döner. Dim ad as String ad = "Bilgisayar" y = Instr ' dönen deger 4 String : Verilen kod dan x sayisi kadar üretir. String(5, x) 'dönen deger "xxxxx" Space : Verilen degerde bosluk olusturur. Space(5) RSet: RSet komutu ile yapilan atama sagdan yapilir x = "Bilgisayar" RSet x = "Kalem" ' dönen deger x = " Kalem" Asc : Verilen Harfin ascii kodunu geri verir. Chr : Verilen ascii kodunun karakter karsiligini verir Str : Verilen sayiyi stringe cevirir Val : Verilen string'i sayiya cevirir Hex : Verilen dezimal sayiyi hexadezimal sayiya cevirir. Oct : Verilen dezimal sayiyi Octal sayiya cevirir Like Operatörü: String karsilastirma. Mesela bir kelimenin bir string icinde olup olmadigini bulmak. Dim Test1 Test1 = "aBBBa" Like "a a" ' dönen deger True. Test1 = "F" Like " " ' True. Test1 = "F" Like " " ' False. Test1 = "a2a" Like "a#a" ' True. Test1 = "aM5b" Like "a # " ' True. Test1 = "BAT123khg" Like "B?T " ' True. Test1 = "CAT123khg" Like "B?T " ' False. OVAL FORM OLUŞTURMAK Bu kod sayesinde formumuzu oval bir sekilde olusturabiliriz. Option Explicit Private Declare Function CreateEllipticRgn Lib "gdi32" _ (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As _ Long, ByVal Y2 As Long) As Long Private Declare Function SetWindowRgn Lib "user32" As Long Private Declare Function ReleaseCapture Lib "user32" _ As Long Private Declare Function SendMessage Lib "user32"Alias _ "SendMessageA" As Long Private Const HTCAPTION = 2 Private Const WM_NCLBUTTONDOWN = &HA1 Private Sub Form_Load Me. Picture = LoadPicture Call CreateReg End Sub Private Sub Command1_Click Unload Me End Sub Private Sub Form_MouseDown If y / Screen. TwipsPerPixelY < 25 Then Call ReleaseCapture Call SendMessage(Me. hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&) End If End Sub Private Sub CreateReg Dim x&, y&, dx&, dy&, Result& With Me dx = . Width / Screen. TwipsPerPixelX dy = . Height / Screen. TwipsPerPixelY Result = CreateEllipticRgn(y + 1, x + 1, dx - 1, dy - 1) Call SetWindowRgn(. hwnd, Result, 1&) End With End Sub FORM EFEKTLERİ Formlari efek vererek acip kapatmak.. Option Explicit Private Declare Function SetRect Lib "User32" (lpRect _ As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal _ X2 As Long, ByVal Y2 As Long) As Long Private Declare Function DrawAnimatedRects Lib "User32" _ As Long Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Const IDANI_OPEN = &H1 Const IDANI_CLOSE = &H2 Const IDANI_CAPTION = &H3 Dim TPP% Private Sub Form_Load Dim R1 As RECT, R2 As RECT TPP = Screen. TwipsPerPixelX Call SetRect(R1, Screen. Width / TPP, Screen. Height / TPP, _ Screen. Width / TPP, Screen. Height / TPP) Call SetRect(R2, 0, 0, Me. Width / TPP, Me. Height / TPP) Call DrawAnimatedRects(Me. hWnd, IDANI_CLOSE Or _ IDANI_CAPTION, R1, R2) Me. Top = 0 Me. Left = 0 End Sub Private Sub Form_Unload Dim R1 As RECT, R2 As RECT Call SetRect(R1, 0, 0, Me. Width / TPP, Me. Height / TPP) Call SetRect(R2, Screen. Width / TPP, Screen. Height / TPP, _ Screen. Width / TPP, Screen. Height / TPP) Call DrawAnimatedRects(Me. hWnd, IDANI_OPEN Or _ IDANI_CAPTION, R1, R2) End Sub AĞ ÜZERİNDEN MESAJ GÖNDERMEK Bu örnek sayesinde ag ortaminda bilgisayarlar arasi mail ve mesaj gönderilebilir. Ayni zamanda bir server programi da durumu ve olaylari göstermekedir. Option Explicit Dim ID% Private Function WSend If Winsock . State = 7 Then Winsock . SendData Text Dim t As Long t = Timer Do While t + 0.5 > Timer DoEvents Loop End If End Function Private Sub Form_Load If Winsock(0). State <> 0 Then Winsock(0). Close 'Kullanilacak Port Winsock(0). LocalPort = 10567 'Dinle Winsock(0). Listen End Sub Private Sub Winsock_ConnectionRequest 'Aktif Kullaniciyi tanimla Dim i% START: For i = 1 To User. ListItems. Count User. ListItems. Item . SubItems(1) = Winsock(User. ListItems. Item . State If User. ListItems. Item . SubItems(1) <> 7 Then Winsock(User. ListItems. Item . Close Unload Winsock(User. ListItems. Item User. ListItems. Remove i GoTo START End If Next i 'Baglan If Index = 0 Then For i = 2 To User. ListItems. Count If User. ListItems > User. ListItems(i - 1) + 1 Then Load Winsock(User. ListItems - 1) Winsock(User. ListItems - 1). LocalPort = 10567 Winsock(User. ListItems - 1). Accept requestID Exit Sub End If Next i If User. ListItems. Count > 0 Then If User. ListItems(1) >= 2 Then Load Winsock(User. ListItems(1) - 1) Winsock(User. ListItems(1) - 1). LocalPort = 10567 Winsock(User. ListItems(1) - 1). Accept requestID Exit Sub End If Load Winsock(User. ListItems. Count + 1) Winsock(User. ListItems. Count + 1). LocalPort = 10567 Winsock(User. ListItems. Count + 1). Accept requestID Exit Sub End If Load Winsock(1) Winsock(1). LocalPort = 0 Winsock(1). Accept requestID End If End Sub Private Sub Winsock_DataArrival 'Aktif kullaniciyi tanimla Dim i% START:

ellerine sağlık. güzel paylaşım. +karma

hocam hiçbişey anlamadım yaa bunda htmldeki gibi şunu yazarsan şu olur bunu yazarsan bu olur die açıklamak mümkün değil mi? bana ne önerirsin?

eyw. Japon Kardes. Robotic

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 Else MsgBox End If Else MsgBox 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 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 Then ShowStatus Else ShowStatus End If Response = False Exit Do End If Loop Result = "" ProgressBar1. Value = 0 Timer1. Enabled = False End Function Private Sub Winsock1_DataArrival Winsock1. GetData Result End Sub Private Sub ShowStatus Label7. Caption = Text Label7. Refresh End Sub Private Function SendMail 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 MAIL = MAIL & ", " & Format & " " MAIL = MAIL & Format & " +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 Winsock1. Protocol = sckTCPProtocol Winsock1. RemoteHost = SMTP Winsock1. RemotePort = 25 Winsock1. Connect If Not Response("220") Then GoTo ERRORMail '### Baglanildi ShowStatus Winsock1. SendData If Not Response("250") Then GoTo ERRORMail '### Mail Gönder ShowStatus Winsock1. SendData If Not Response("250") Then GoTo ERRORMail Winsock1. SendData If Not Response("354") Then GoTo ERRORMail Winsock1. SendData If Not Response("250") Then GoTo ERRORMail '### Baglanti Sonlandir ShowStatus Winsock1. SendData If Not Response("221") Then GoTo ERRORMail ShowStatus 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" As Long Private Declare Function RegCloseKey Lib "advapi32. dll" As Long Private Declare Function RegQueryValueEx Lib "advapi32. dll"Alias _ "RegQueryValueExA" 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 SBytes = ReadBytes CSpeed = ReadBytes 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 = / (Timer1. Interval / 1000) CNT = CNT + 1 Else Q = 0 End If SUM = SUM + Q QQ = SUM / CNT Label6. Caption = " " & Q LBytes = EBytes End Sub Private Function ReadBytes 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 s1 = ReadBytes SUM = 0 CNT = 1 End Sub

SES BALANS AYARLARI Wav dosyalarini calarken bunlarin ses balans ayarlariyla oynayabiliriz. Private Type lVolType v As Long End Type Private Type VolType lv As Integer rv As Integer End Type Private Declare Function waveOutGetVolume Lib "winmm. dll" _ As Long Private Declare Function waveOutSetVolume Lib "winmm. dll" _ _ As Long 'WAV dosyasi Cal Private Declare Function mciSendString Lib "winmm. dll"Alias _ "mciSendStringA" As Long Private Sub Command3_Click Dim i As Long, RS As String, cb As Long, W$ RS = Space$(128) i = mciSendString("stop sound", RS, 128, cb) i = mciSendString("close sound", RS, 128, cb) 'Cal RS = Space$(128) W$ = "test. wav" 'Calinacak Wav dosyasi i = mciSendString("open waveaudio!" & W$ & " alias sound", _ RS, 128, cb) If i Then MsgBox "Hata - Verilen Dosya Bulnamadi." i = mciSendString("play sound", RS, 128, cb) VScroll1. SetFocus End Sub Private Sub Form_Load HScroll1. Value = 0 VScroll1. Value = 2 Form1. Show VScroll1. SetFocus End Sub Private Sub Timer1_Timer Dim id As Long, v As Long, i As Long id = -1 If VScroll1. Value = 1 And HScroll1. Value = -2 Then _ i = waveOutSetVolume(id, 0) If VScroll1. Value = 1 And HScroll1. Value = -1 Then _ i = waveOutSetVolume(id, 0) If VScroll1. Value = 1 And HScroll1. Value = 0 Then _ i = waveOutSetVolume(id, 0) If VScroll1. Value = 1 And HScroll1. Value = 1 Then _ i = waveOutSetVolume(id, 0) If VScroll1. Value = 1 And HScroll1. Value = 2 Then _ i = waveOutSetVolume(id, 0) If VScroll1. Value = 2 And HScroll1. Value = -2 Then _ i = waveOutSetVolume(id, 10280) If VScroll1. Value = 2 And HScroll1. Value = -1 Then _ i = waveOutSetVolume(id, 379004968) If VScroll1. Value = 2 And HScroll1. Value = 0 Then _ i = waveOutSetVolume(id, 673720360) If VScroll1. Value = 2 And HScroll1. Value = 1 Then _ i = waveOutSetVolume(id, 673714578) If VScroll1. Value = 2 And HScroll1. Value = 2 Then _ i = waveOutSetVolume(id, 673710080) If VScroll1. Value = 3 And HScroll1. Value = -2 Then _ i = waveOutSetVolume(id, 20560) If VScroll1. Value = 3 And HScroll1. Value = -1 Then _ i = waveOutSetVolume(id, 757944400) If VScroll1. Value = 3 And HScroll1. Value = 0 Then _ i = waveOutSetVolume(id, 1347440720) If VScroll1. Value = 3 And HScroll1. Value = 1 Then _ i = waveOutSetVolume(id, 1347429155) If VScroll1. Value = 3 And HScroll1. Value = 2 Then _ i = waveOutSetVolume(id, 1347420160) If VScroll1. Value = 4 And HScroll1. Value = -2 Then _ i = waveOutSetVolume(id, 31868) If VScroll1. Value = 4 And HScroll1. Value = -1 Then _ i = waveOutSetVolume(id, 1174830204) If VScroll1. Value = 4 And HScroll1. Value = 0 Then _ i = waveOutSetVolume(id, 2088533116) If VScroll1. Value = 4 And HScroll1. Value = 1 Then _ i = waveOutSetVolume(id, 2088515191) If VScroll1. Value = 4 And HScroll1. Value = 2 Then _ i = waveOutSetVolume(id, 2088501248) If VScroll1. Value = 5 And HScroll1. Value = -2 Then _ i = waveOutSetVolume(id, 42919) If VScroll1. Value = 5 And HScroll1. Value = -1 Then _ i = waveOutSetVolume(id, 1582213031) If VScroll1. Value = 5 And HScroll1. Value = 0 Then _ i = waveOutSetVolume(id, -1482184793) If VScroll1. Value = 5 And HScroll1. Value = 1 Then _ i = waveOutSetVolume(id, -1482208934) If VScroll1. Value = 5 And HScroll1. Value = 2 Then _ i = waveOutSetVolume(id, -1482227712) If VScroll1. Value = 6 And HScroll1. Value = -2 Then _ i = waveOutSetVolume(id, 54227) If VScroll1. Value = 6 And HScroll1. Value = -1 Then _ i = waveOutSetVolume(id, 1554895827) If VScroll1. Value = 6 And HScroll1. Value = 0 Then _ i = waveOutSetVolume(id, -741092397) If VScroll1. Value = 6 And HScroll1. Value = 1 Then _ i = waveOutSetVolume(id, -741122899) If VScroll1. Value = 6 And HScroll1. Value = 2 Then _ i = waveOutSetVolume(id, -741146624) If VScroll1. Value = 7 And HScroll1. Value = -2 Then _ i = waveOutSetVolume(id, 65535) If VScroll1. Value = 7 And HScroll1. Value = -1 Then _ i = waveOutSetVolume(id, -1878982657) If VScroll1. Value = 7 And HScroll1. Value = 0 Then _ i = waveOutSetVolume(id, -1) If VScroll1. Value = 7 And HScroll1. Value = 1 Then _ i = waveOutSetVolume(id, -36865) If VScroll1. Value = 7 And HScroll1. Value = 2 Then _ i = waveOutSetVolume(id, -65536) End Sub SİSTEMDEKİ YAZICILARI OKUMAK Sistemde kurulu olan bütün yazicilarin listesini cikarabiliriz. Option Explicit Private Sub Form_Load Dim X%, AA$ For X = 0 To Printers. Count - 1 AA = Printers . DeviceName AA = AA & Space$(35 - Len & Printers . Port List1. AddItem AA If Printer. DeviceName = Printers . DeviceName Then Label1. Caption = "Varsayilan Yazici: " & AA End If Next X End Sub WINDOWS NE ZAMANDAN BERİ ÇALIŞIYOR? Windows'un ne zaman acildigini ögrenmek icin gerekli kod. Option Explicit Private Declare Function GetTickCount Lib "kernel32" As Long Private Sub Timer1_Timer Dim H As Single, M As Single, S As Single, MS As Single Dim strH$, strM$, strS$, strMS$ MS = GetTickCount MS = MS / 1000 H = Int(MS / 3600) MS = MS - H 3600 M = Int(MS / 60) MS = MS - M 60 S = Int MS = Int 10) strH = CStr strM = Format(CStr , "#

For i = 1 To User. ListItems. Count User. ListItems. Item . SubItems(1) = Winsock(User. ListItems. Item . State If User. ListItems. Item . SubItems(1) <> 7 Then Winsock(User. ListItems. Item . Close Unload Winsock(User. ListItems. Item User. ListItems. Remove i GoTo START End If Next i 'Mesaj al Dim Message$ Winsock . GetData Message Call SetList(Mid(Message, 1, 1) & Index & Mid(Message, 2, Len If Mid(Message, 1, 1) = 4 Then Exit Sub 'Mesaji paylastir If Mid(Message, 1, 1) = 1 Then Dim MFrom$, MTo$, MText$, ok% MFrom = Mid(Message, 2, InStr(1, Message, "%") - 2) MTo = Mid(Message, InStr(1, Message, "%") + 1, InStr(1, Message, "$") - InStr(1, Message, "%") - 1) MText = Mid(Message, InStr(1, Message, "$") + 1, Len ok = 0 For i = 1 To User. ListItems. Count If LCase(User. ListItems . SubItems(2)) = LCase Or LCase = "alle"Then If LCase(User. ListItems . SubItems(2)) <> LCase Then WSend User. ListItems. Item , MText SetList "3%" & User. ListItems . SubItems(2) & "$" & MText ok = 1 Exit Sub End If End If Next i 'Kullanici belli degil If ok = 0 Then WSend Index, "Kullanici aktif degil" SetList "3%" & MFrom & "$" & "Kullanici aktif degil" End If End If End Sub Function SetList Dim litem As ListItem Select Case CInt(Mid(Message, 1, 1)) Case 1, 4: ID = ID + 1 If LMessage. ListItems. Count > 13 Then LMessage. ListItems. Remove 1 Set litem = LMessage. ListItems. Add litem. SubItems(1) = Mid(Message, 3, InStr(1, Message, "%") - 3) litem. SubItems(2) = Mid(Message, InStr(1, Message, "%") + 1, InStr(1, Message, "$") - InStr(1, Message, "%") - 1) litem. SubItems(3) = "<- " & Mid(Message, InStr(1, Message, "$") + 1, Len Case 2: Set litem = User. ListItems. Add(, , Mid(Message, 2, 1)) litem. SubItems(1) = Winsock(CInt(Mid( Message, 2, 1))). State litem. SubItems(2) = Mid(Message, 3, Len Case 3: If LMessage. ListItems. Count > 13 Then LMessage. ListItems. Remove 1 Set litem = LMessage. ListItems. Add litem. SubItems(1) = Mid(Message, 3, InStr(1, Message, "$") - 3) litem. SubItems(2) = "MailServer" litem. SubItems(3) = "<- " & Mid(Message, InStr(1, Message, "$") + 1, Len End Select End Function BAŞLIKSIZ FORMU HAREKET ETTİRMEK Visual Basic de basligi olmayan bir formu Fare ile hareket ettiremeyiz. Iste Buna Api ile bir cözüm Option Explicit Private Declare Function ReleaseCapture Lib "user32" As Long Private Declare Function SendMessage Lib "user32"Alias _ "SendMessageA" As Long Private Const HTCAPTION = 2 Private Const WM_NCLBUTTONDOWN = &HA1 Private Const WM_SYSCOMMAND = &H112 Private Sub label1_MouseDown Call ReleaseCapture SendMessage Me. hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0& End Sub Private Sub Command1_Click Unload Me End Sub CTRL+ALT+DEL TUŞLARINI İPTAL ETMEK Bu Kod sayesinde Windows da Ctrl-Alt-Del tuslari iptal edilir. Option Explicit Private Declare Function SystemParametersInfo Lib _ "User32"Alias "SystemParametersInfoA" _ As Long Private Sub Command1_Click Dim Sonuc& Sonuc= SystemParametersInfo(97, True, "1", 0) Label1. Caption = " + + iptal edildi" End Sub Private Sub Command2_Click Dim Sonuc& Sonuc = SystemParametersInfo(97, False, "1", 0) Label1. Caption = " + + aktif" End Sub Private Sub Form_Load Call Command2_Click End Sub DOSYA TRANSFERİ Bu Kod sayesinde winsock kontrolü üzerinden dosya transferi yapabiliriz. Büyük boyuttaki dosyalari gönderebilmemiz icin bunlari kücük parcalara bölüp göndermemiz gerekiyor. Gönderildigi yerde yeniden birlestirilmesi gerekiyor. Ayrica bi kanaldan bir dosya gönderirken diger bir kanaldan bir dosya alabiliriz. Bu durumda port degistirmemiz gerekiyor. ' Kod Form1 Option Explicit Const ResponseTimeOut = 20 '20 Saniye Const PaketSize = 2048 Dim Start& Dim OkFlag As Boolean Dim TimeOut As Boolean Dim Connected As Boolean Private Sub Form_Load Timer1. Enabled =a False Timer1. Interval = 400 Winsock1. LocalPort = CInt(Text1. Text) Winsock1. Listen Label2. Caption = "Bagli degil" Label3. Caption = App. Path & "\deneme. bmp" If Dir$(Label3. Caption) <> ""Then Label4. Caption = Int((FileLen(Label3. Caption) / 1024) 10) _ / 10 & " kB" End If End Sub Private Sub Form_Unload Unload Form2 End Sub Private Sub Command1_Click Call SendFile(Label3. Caption) End Sub Private Sub Drive1_Change Dir1. Path = Drive1. Drive End Sub Private Sub Dir1_Change File1. Path = Dir1. Path End Sub Private Sub File1_Click Dim AA$, BB$ AA = File1. Path If Right$(AA, 1) <> "\"And Right$(AA, 1) <> "/"Then AA = AA & "\" End If Label3. Caption = AA & File1. FileName Label4. Caption = Int((FileLen(Label3. Caption) / 1024) 10) _ / 10 & " kB" End Sub Private Sub Timer1_Timer If Timer - Start > ResponseTimeOut Then TimeOut = True OkFlag = False End If End Sub Private Sub Winsock1_ConnectionRequest If Winsock1. State <> sckClosed Then Winsock1. Close Winsock1. Accept requestID Winsock1. SendData 77 Label2. Caption = "Baglanti Hazir" Connected = True End Sub Private Sub Winsock1_DataArrival Dim Data As Byte Winsock1. GetData Data, vbString If Data(0) = 77 Then OkFlag = False End If End Sub Private Sub SendFile Dim Data As Byte Dim l&, AA$, BB$, x&, FN%, TM As Single On Error Resume Next If Not Connected Then MsgBox Exit Sub End If Call Disable l = FileLen AA = Hex Do While Len < 8 AA = "0" & AA Loop BB = LastPath BB = BB & Space$(257 - Len AA = "New Data|" & AA & BB ReDim Data(0 To Len - 1) For x = 1 To Len Data(x - 1) = Asc(Mid$(AA, x, 1)) Next x Winsock1. SendData Data If WaitForResponse Then FN = FreeFile Open FileName For Binary As #FN ReDim Data(1 To PaketSize) As Byte Label2. Caption = "Veri Gönder" Label2. Refresh l = LOF TM = Timer For x = 1 To l \ PaketSize Get #FN, , Data Winsock1. SendData Data Call ProgressBar(x PaketSize, 0, l) Label5. Caption = Int(x PaketSize / 1024 / _ 10) / 10 & " kB/Sec" Label5. Refresh If Not WaitForResponse Then MsgBox Call ProgressBar(0, 0, l) Label2. Caption = "Baglanti Hazir" Call Enable Exit Sub End If Next x If l Mod PaketSize <> 0 Then ReDim Data(1 To l Mod PaketSize) As Byte Get #FN, , Data Winsock1. SendData Data Call ProgressBar(l, 0, l) Label5. Caption = Int(x PaketSize / 1024 / _ 10) / 10 & " kB/Sec" Label5. Refresh If Not WaitForResponse Then MsgBox Call ProgressBar(0, 0, l) Label2. Caption = "Baglanti Hazir" Call Enable Exit Sub End If End If Close FN Label2. Caption = "Baglanti Hazir" Call ProgressBar(0, 0, l) Else Label2. Caption = "Timeout" MsgBox End If Call Enable End Sub Private Function WaitForResponse As Boolean OkFlag = True TimeOut = False Start = Timer Timer1. Enabled = True Do While OkFlag DoEvents Loop If Not TimeOut Then WaitForResponse = True Timer1. Enabled = False End Function Private Sub ProgressBar Dim Fx& Static LastX If Prg < Min Or Prg > Max Or Max <= Min Then Exit Sub Prg = Int(100 / With Picture1 If Prg > 0 Then If Prg <> LastX Then Picture1. Cls Fx = (Picture1. ScaleWidth - 2) / 100 Prg Picture1. Line (0, 0)-(Fx + 1, Picture1. ScaleHeight _ - 1), &H8000000D, BF. CurrentX = Fx + 3. CurrentY = 0 Picture1. Print Trim$(CStr & " %") LastX = Prg End If Else Picture1. Cls End If End With End Sub Private Function LastPath As String Dim AA$, BB$, x& For x = Len To 1 Step -1 AA = Mid$(Path, x, 1) If AA = "/"Or AA = "\"Then Exit For Else BB = AA & BB End If Next x LastPath = BB End Function Private Sub Disable Text1. Enabled = False Command1. Enabled = False File1. Enabled = False Dir1. Enabled = False Drive1. Enabled = False MousePointer = vbHourglass End Sub Private Sub Enable Text1. Enabled = True Command1. Enabled = True File1. Enabled = True Dir1. Enabled = True Drive1. Enabled = True MousePointer = vbDefault End Sub ' Kod Form1 Bitis

Bu kod sayesinde internete bagli olup olmadigimiz ögrenilebilir Option Explicit Private Declare Function RasEnumConnections Lib "RasApi32. dll" _ Alias "RasEnumConnectionsA" As Long Private Declare Function RasGetConnectStatus Lib "RasApi32. dll" _ Alias "RasGetConnectStatusA" As Long Const RAS_MaxEntryName = 256 Const RAS_MaxDeviceType = 16 Const RAS_MaxDeviceName = 32 Private Type RASType dwSize As Long hRasCon As Long szEntryName As Byte szDeviceType As Byte szDeviceName As Byte End Type Private Type RASStatusType dwSize As Long RasConnState As Long dwError As Long szDeviceType As Byte szDeviceName As Byte End Type Private Sub Form_Load Timer1. Interval = 200 Timer1. Enabled = True End Sub Private Sub Timer1_Timer DFÜStatus End Sub Private Function DFÜStatus As Boolean Dim RAS(255) As RASType, RASStatus As RASStatusType Dim lg&, lpcon&, Result& RAS(0). dwSize = 412 lg = 256 RAS(0). dwSize Result = RasEnumConnections(RAS(0), lg, lpcon) If lpcon = 0 Then Label1. Caption = "Offline" '### DFÜStatus = False Else RASStatus. dwSize = 160 Result = RasGetConnectStatus(RAS(0). hRasCon, RASStatus) If RASStatus. RasConnState = &H2000 Then Label1. Caption = "Online" '### DFÜStatus = True Else Label1. Caption = "Baglanti Kopuk" '### DFÜStatus = False End If End If End Function INTERNET BAĞLANTISI OLUŞTURMAK - KESMEK Bu kod sayesinde internete bagli olup olmadigimiz ögrenilebilir. Option Explicit Const RAS_MaxDeviceType = 16 Const RAS95_MaxDeviceName = 128 Const RAS95_MaxEntryName = 256 Private Type RASENTRYNAME95 dwSize As Long szEntryName(RAS95_MaxEntryName) As Byte End Type Private Type RASCONN95 dwSize As Long hRasConn As Long szEntryName(RAS95_MaxEntryName) As Byte szDeviceType As Byte szDeviceName(RAS95_MaxDeviceName) As Byte End Type Private Declare Function RasEnumConnections Lib "RasApi32. DLL" _ Alias "RasEnumConnectionsA" As Long Private Declare Function RasEnumEntries Lib "RasApi32. DLL" _ Alias "RasEnumEntriesA" As Long Private Declare Function RasHangUp Lib "RasApi32. DLL" _ Alias "RasHangUpA" As Long Dim DFÜname$, RCon As Long Private Sub HangUp Dim s As Long, l As Long, ln As Long, aa$ ReDim r(255) As RASCONN95 r(0). dwSize = 412 s = 256 r(0). dwSize l = RasEnumConnections(r(0), s, ln) For l = 0 To ln - 1 aa = StrConv(r . szEntryName , vbUnicode) aa = Left$(aa, InStr(aa, Chr$(0)) - 1) If aa = Verbindung Then RCon = r . hRasConn Dim rec As Long rec = RasHangUp End If Next l End Sub Private Sub Command1_Click If List1. ListIndex = -1 Then Exit Sub DFÜname = List1. List(List1. ListIndex) Shell "rundll32. exe rnaui. dll, RnaDial " & DFÜname SendKeys " ", True SendKeys " ", True Me. SetFocus End Sub Private Sub Command2_Click Call HangUp End Sub Private Sub Form_Load Dim s As Long, ln As Long, i%, conname$ Dim r(255) As RASENTRYNAME95 r(0). dwSize = 264 s = 256 r(0). dwSize Call RasEnumEntries(vbNullString, vbNullString, r(0), s, ln) For i = 0 To ln - 1 conname = StrConv(r . szEntryName , vbUnicode) List1. AddItem Left$(conname, InStr - 1) Next i If List1. ListCount <> 0 Then List1. ListIndex = 0 End Sub FARE GÖSTERGESİNİ GİZLEMEK Bu kod sayesinde farenizin göstergesini gizleyebilirsiniz. Option Explicit Private Declare Function ShowCursor Lib "user32" As Long Private Sub Form_Load Timer1. Enabled = False Timer1. Interval = 3000 End Sub Private Sub Command1_Click Timer1. Enabled = True ShowCursor (0) End Sub Private Sub Timer1_Timer Timer1. Enabled = False ShowCursor (1) End Sub

SERVER'A PING GÖNDERMEK Bu kod sayesinde bir Server 'a Ping gönderebiliriz. ' Anfang Code Module1 Option Explicit Private Declare Function IcmpCreateFile Lib "icmp. dll" _ As Long Private Declare Function IcmpCloseHandle Lib "icmp. dll" As Long Private Declare Function IcmpSendEcho Lib "icmp. dll" As Long Private Declare Function WSAGetLastError Lib "wsock32. dll" _ As Long Private Declare Function WSAStartup Lib "wsock32. dll" As Long Private Declare Function WSACleanUp Lib "wsock32. dll"Alias _ "WSACleanup" As Long Private Declare Function GetHostName Lib "wsock32. dll"Alias _ "gethostname" As Long Private Declare Function GetHostByName Lib "wsock32. dll"Alias _ "gethostbyname" As Long Private Declare Sub CopyMemory Lib "kernel32"Alias _ "RtlMoveMemory" Private Declare Function htonl Lib "wsock32. dll" As Long Private Declare Function htons Lib "wsock32. dll" As Integer Private Declare Function inet_addr Lib "wsock32. dll" As Long Private Declare Function inet_ntoa Lib "wsock32. dll" As Long Private Declare Function ntohl Lib "wsock32. dll" As Long Private Declare Function ntohs Lib "wsock32. dll" As Integer Private Type ICMP_OPTIONS Ttl As Byte Tos As Byte Flags As Byte OptionsSize As Byte OptionsData As Long End Type Public Type ICMP_ECHO_REPLY Address As Long Status As Long RoundTripTime As Long DataSize As Integer Reserved As Integer DataPointer As Long Options As ICMP_OPTIONS Data As String 250 End Type Private Type hostent hName As Long hAliases As Long hAddrType As Integer hLen As Integer hAddrList As Long End Type Const MAX_WSADescription = 256 Const MAX_WSASYSStatus = 128 Const MAXGETHOSTSTRUCT = 1024 Private Type WSAData wVersion As Integer wHighVersion As Integer szDescription(0 To MAX_WSADescription) As Byte szSystemStatus(0 To MAX_WSASYSStatus) As Byte wMaxSockets As Integer wMaxUDPDG As Integer dwVendorInfo As Long End Type Private Type hostent_async h_name As Long h_aliases As Long h_addrtype As Integer h_length As Integer h_addr_list As Long h_asyncbuffer As Byte End Type Const IP_STATUS_BASE = 11000 Const IP_SUCCESS = 0 Const IP_BUF_TOO_SMALL = (11000 + 1) Const IP_DEST_NET_UNREACHABLE = (11000 + 2) Const IP_DEST_HOST_UNREACHABLE = (11000 + 3) Const IP_DEST_PROT_UNREACHABLE = (11000 + 4) Const IP_DEST_PORT_UNREACHABLE = (11000 + 5) Const IP_NO_RESOURCES = (11000 + 6) Const IP_BAD_OPTION = (11000 + 7) Const IP_HW_ERROR = (11000 + Cool Const IP_PACKET_TOO_BIG = (11000 + 9) Const IP_REQ_TIMED_OUT = (11000 + 10) Const IP_BAD_REQ = (11000 + 11) Const IP_BAD_ROUTE = (11000 + 12) Const IP_TTL_EXPIRED_TRANSIT = (11000 + 13) Const IP_TTL_EXPIRED_REASSEM = (11000 + 14) Const IP_PARAM_PROBLEM = (11000 + 15) Const IP_SOURCE_QUENCH = (11000 + 16) Const IP_OPTION_TOO_BIG = (11000 + 17) Const IP_BAD_DESTINATION = (11000 + 1Cool Const IP_ADDR_DELETED = (11000 + 19) Const IP_SPEC_MTU_CHANGE = (11000 + 20) Const IP_MTU_CHANGE = (11000 + 21) Const IP_UNLOAD = (11000 + 22) Const IP_ADDR_ADDED = (11000 + 23) Const IP_GENERAL_FAILURE = (11000 + 50) Const MAX_IP_STATUS = 11000 + 50 Const IP_PENDING = (11000 + 255) Const PING_TIMEOUT = 200 Const WS_VERSION_REQD = &H101 Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF& Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF& Const MIN_SOCKETS_REQD = 1 Const SOCKET_ERROR = -1 Const INADDR_NONE = &HFFFFFFFF 'Degiskenler ' Public Const hostent_size = 16 Public PointerToPointer, IPLong As Long Dim hostent_async As hostent_async Dim ICMPOPT As ICMP_OPTIONS Public Function GetHost As Long Dim ListAddress As Long Dim ListAddr As Long Dim LH&, phe& Dim Start As Boolean Dim heDestHost As hostent Dim addrList&, repIP& Start = SocketsInitialize If Start = False Then GetHost = 0 MsgBox Exit Function End If LH = inet_addr repIP = LH If LH = INADDR_NONE Then phe = GetHostByName If phe <> 0 Then CopyMemory heDestHost, ByVal phe, hostent_size CopyMemory addrList, ByVal heDestHost. hAddrList, 4 CopyMemory repIP, ByVal addrList, heDestHost. hLen Else Call MsgBox GetHost = INADDR_NONE Exit Function End If End If Form1. Text4. Text = CStr GetHost = repIP End Function Public Function GetStatusCode As String Dim Msg As String Select Case Status Case IP_SUCCESS: Msg = "ip success" Case IP_BUF_TOO_SMALL: Msg = "ip buf too_small" Case IP_DEST_NET_UNREACHABLE: Msg = "ip dest net unreachable" Case IP_DEST_HOST_UNREACHABLE: Msg = "ip dest host unreachable" Case IP_DEST_PROT_UNREACHABLE: Msg = "ip dest prot unreachable" Case IP_DEST_PORT_UNREACHABLE: Msg = "ip dest port unreachable" Case IP_NO_RESOURCES: Msg = "ip no resources" Case IP_BAD_OPTION: Msg = "ip bad option" Case IP_HW_ERROR: Msg = "ip hw_error" Case IP_PACKET_TOO_BIG: Msg = "ip packet too_big" Case IP_REQ_TIMED_OUT: Msg = "ip req timed out" Case IP_BAD_REQ: Msg = "ip bad req" Case IP_BAD_ROUTE: Msg = "ip bad route" Case IP_TTL_EXPIRED_TRANSIT: Msg = "ip ttl expired transit" Case IP_TTL_EXPIRED_REASSEM: Msg = "ip ttl expired reassem" Case IP_PARAM_PROBLEM: Msg = "ip param_problem" Case IP_SOURCE_QUENCH: Msg = "ip source quench" Case IP_OPTION_TOO_BIG: Msg = "ip option too_big" Case IP_BAD_DESTINATION: Msg = "ip bad destination" Case IP_ADDR_DELETED: Msg = "ip addr deleted" Case IP_SPEC_MTU_CHANGE: Msg = "ip spec mtu change" Case IP_MTU_CHANGE: Msg = "ip mtu_change" Case IP_UNLOAD: Msg = "ip unload" Case IP_ADDR_ADDED: Msg = "ip addr added" Case IP_GENERAL_FAILURE: Msg = "ip general failure" Case IP_PENDING: Msg = "ip pending" Case PING_TIMEOUT: Msg = "ping timeout" Case Else: Msg = "unknown msg returned" End Select GetStatusCode = CStr & " " End Function Private Function HiByte HiByte = wParam \ &H100 And &HFF& End Function Private Function LoByte LoByte = wParam And &HFF& End Function Public Function Ping As Long Dim hPort As Long Dim dwAddress As Long Dim sDataToSend As String Dim iOpt As Long Dim a sDataToSend = Trim$(Form1. Text3. Text) dwAddress = GetHost hPort = IcmpCreateFile If IcmpSendEcho(hPort, dwAddress, sDataToSend, Len , _ 0, ECHO, Len , PING_TIMEOUT) Then Ping = ECHO. RoundTripTime Else: Ping = ECHO. Status -1 End If Call IcmpCloseHandle a = SocketsCleanup End Function Private Function AddressStringToLong As Long Dim i As Integer Dim parts(1 To 4) As String i = 0 While InStr > 0 i = i + 1 parts = Mid(Tmp, 1, InStr - 1) Tmp = Mid(Tmp, InStr + 1) Wend i = i + 1 parts = Tmp If i <> 4 Then AddressStringToLong = 0 Exit Function End If AddressStringToLong = Val("&H" & Right("00" & Hex(parts(4)), 2) & _ Right("00" & Hex(parts(3)), 2) & _ Right("00" & Hex(parts(2)), 2) & _ Right("00" & Hex(parts(1)), 2)) End Function Private Function SocketsCleanup As Boolean Dim X As Long X = WSACleanUp If X <> 0 Then Call MsgBox("Windows Sockets error " & Trim$(Str$ & _ " occurred in Cleanup.", vbExclamation) SocketsCleanup = False Else SocketsCleanup = True End If End Function Private Function SocketsInitialize As Boolean Dim WSAD As WSAData Dim X As Integer Dim szLoByte As String, szHiByte As String, szBuf As String X = WSAStartup If X <> 0 Then Call MsgBox("Windows Sockets for 32 bit Windows " & _ "environments is not successfully responding.") SocketsInitialize = False Exit Function End If SocketsInitialize = True End Function ' Kod Module1 Sonu ' Kod Form1 Option Explicit Private Sub Command1_Click Dim ECHO As ICMP_ECHO_REPLY Dim pos As Integer 'Ping Fonksiyonunu cagir Call Ping(Trim$(Text2. Text), ECHO) 'Sonucu Göster Text1(0) = GetStatusCode Text1(1) = ECHO. Address Text1(2) = ECHO. RoundTripTime & " ms" Text1(3) = ECHO. DataSize & " bytes" If Left$(ECHO. Data, 1) <> Chr$(0) Then pos = InStr(ECHO. Data, Chr$(0)) Text1(4) = Left$(ECHO. Data, pos - 1) End If Text1(5) = ECHO. DataPointer End Sub

' Kod Form2 Baslangic Option Explicit Const ResponseTimeOut = 20 '20 Saniye Dim Start& Dim OkFlag As Boolean Dim TimeOut As Boolean Dim Connected As Boolean Dim Awaiting As Boolean Private Sub Form_Load Timer1. Enabled = False Timer1. Interval = 400 Drive1. Drive = "c:" Dir1. Path = "c:" With Form1. Show. Top = Screen. Height / 2. Left = / 2 End With With Me. Left = Form1. Left. Top = Form1. Top - . Height End With End Sub Private Sub Form_Unload Unload Form1 End Sub Private Sub Command1_Click On Error Resume Next Winsock1. Connect Text2. Text, CInt(Text1. Text) Awaiting = True If WaitForResponse Then Label1. Caption = "Baglanti Hazir" Command1. Enabled = False Else MsgBox Winsock1. Close End If Awaiting = False End Sub Private Sub Drive1_Change Dir1. Path = Drive1. Drive End Sub Private Sub Dir1_Change Dim AA$ AA = Dir1. Path If Right$(AA, 1) <> "\"And Right$(AA, 1) <> "/"Then AA = AA & "\" End If Label8. Caption = AA File1. Path = Dir1. Path End Sub Private Sub Timer1_Timer If Timer - Start > ResponseTimeOut Then TimeOut = True OkFlag = False End If End Sub Private Sub Winsock1_DataArrival Dim Data As Byte Dim AA$, BB$, x&, d As Single Static Rec As Boolean Static TotalLen& Static IsLen& Static FN% Static TM As Single Winsock1. GetData Data, vbString If Awaiting Then If Data(0) = 77 Then OkFlag = False Else If UBound = 273 And Not Rec Then For x = 0 To UBound AA = AA & Chr$(Data Next x If Left$(AA, 9) = "New Data|"Then TotalLen = CLng("&H" & Mid$(AA, 10, Cool) If TotalLen <> 0 Then BB = Trim$(Mid$(AA, 1Cool) Label1. Caption = "Empfange die Datei " & Chr$(34) & _ BB & Chr$(34) Label4. Caption = Int((TotalLen / 1024) 10) / 10 & _ " kB" Call Dir1_Change Label8. Caption = Label8. Caption & BB TM = Timer Call Disable Else TotalLen = 0 End If End If If TotalLen <> 0 Then Winsock1. SendData 77 Rec = True FN = FreeFile IsLen = 0 If Dir$(Label8. Caption) <> ""Then Kill Label8. Caption End If Open Label8. Caption For Binary As #FN End If ElseIf Rec Then Put #FN, , Data IsLen = IsLen + UBound + 1 d = If d <> 0 Then Label3. Caption = Int(IsLen / 1024 / _ d 10) / 10 & " kB/Sec" Call ProgressBar(IsLen, 0, TotalLen) If IsLen = TotalLen Then Close FN MsgBox Call ProgressBar(0, 0, TotalLen) Rec = False Call Enable TotalLen = 0 File1. Refresh BB = LastPath(Label8. Caption) If File1. ListCount > 0 Then For x = 0 To File1. ListCount - 1 If File1. List = BB Then File1. ListIndex = x Exit For End If Next x Label1. Caption = "Baglanti Hazir" End If End If Winsock1. SendData 77 End If End If End Sub Private Sub ProgressBar Dim Fx& Static LastX If Prg < Min Or Prg > Max Or Max <= Min Then Exit Sub Prg = Int(100 / With Picture1 If Prg > 0 Then If Prg <> LastX Then Picture1. Cls Fx = (Picture1. ScaleWidth - 2) / 100 Prg Picture1. Line (0, 0)-(Fx + 1, Picture1. ScaleHeight _ - 1), &H8000000D, BF. CurrentX = Fx + 3. CurrentY = 0 Picture1. Print Trim$(CStr & " %") LastX = Prg End If Else Picture1. Cls End If End With End Sub Private Function WaitForResponse As Boolean OkFlag = True TimeOut = False Start = Timer Timer1. Enabled = True Do While OkFlag DoEvents Loop If Not TimeOut Then WaitForResponse = True Timer1. Enabled = False End Function Private Function LastPath As String Dim AA$, BB$, x& For x = Len To 1 Step -1 AA = Mid$(Path, x, 1) If AA = "/"Or AA = "\"Then Exit For Else BB = AA & BB End If Next x LastPath = BB End Function Private Sub Disable Text1. Enabled = False Text2. Enabled = False Dir1. Enabled = False Drive1. Enabled = False MousePointer = vbHourglass End Sub Private Sub Enable Text1. Enabled = True Text2. Enabled = True Dir1. Enabled = True Drive1. Enabled = True MousePointer = vbDefault End Sub 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 Winsock1. GetData Result End Sub Private Function Response As Boolean TOut = False Result = "" Timer1. Interval = TimeOut 1000 Timer1. Enabled = True Do While Len = 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 If No > 0 Then ReDim Mail(1 To No) ProgressBar1. Value = 0 ProgressBar1. Max = Bytes Dat = CStr & " Email" If No > 1 Then Dat = Dat & "s" Dat = Dat & " mit " & CStr & " Bytes" Label2. Caption = Dat For X = 1 To No '### Mail Büyüklügünü Sorgula Label1. Caption = "Mesaj" & CStr & " inceleniyor" Winsock1. SendData "list " & CStr & vbCrLf If Response Then GoTo ERRSub Call StatData List1. AddItem CStr & ". Email " & CStr '### Mail i indir Winsock1. SendData "retr " & CStr & vbCrLf Label1. Caption = "Mesaj" & CStr & " cagir" Corr = 13 + Len(CStr Do While Len(Mail < Bytes + Corr - 1 If Response Then GoTo ERRSub Mail = Mail & Result ProgressBar1. Value = Abs(RecBytes + Len(Mail - Corr - 1) Loop RecBytes = RecBytes + Bytes - 1 Mail = Mid$(Mail , Corr + 1, Len(Mail Mail = Left$(Mail , Len(Mail - 2) If Check1. Value = vbChecked Then '### Mail zum Löschen markieren Winsock1. SendData "dele " & CStr & vbCrLf Label1. Caption = "Mesaj" & CStr & " 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