Visual Basic Dersleri

**KaRa_KRaL** · 20-05-2006 23:24

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, [Sart])

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,Mod)

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(String): Girilen stringi büyük harfe cevirir

Ucase(araba) 'dönen deger ARABA

LCase(String): Girilen stringi kücük harfe cevirir

LCase(ARABA) 'dönen deger araba

LTrim(String): String'in solundaki bosluklari kaldirir

LTrim(" Kalem ") 'dönen deger "Kalem "

RTrim(String): String'in sagindaki bosluklari kaldirir

RTrim(" Kalem ") 'dönen deger " Kalem"

Trim(String): String'in iki tarafindaki bosluklari kaldirir

Trim(" Kalem ") 'dönen deger "Kalem"

Len(String): String'in karakter sayisini verir. Bosluklar dahil

Len("Bilgisayar") 'dönen deger 10

Right(String,x): String'in sag tarafindan x sayisi kadar karakter verir

Right("Bilgisayar",5) 'dönen deger "sayar"

Left(String,x): String'in sol tarafindan x sayisi kadar karakter verir

Left("Bilgisayar",5) 'dönen deger "Bilgi"

Mid(String, bas, [uzunluk]): 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([bas],String,Aranan,Ayrim): String'in icinde verilen karakteri arar. Bulunursa bastan kacinci karakter oldugu geri döner.

Dim ad as String
ad = "Bilgisayar"
y = Instr(ad,"g") ' dönen deger 4

String(x,karakter): Verilen kod dan x sayisi kadar üretir.

String(5,x) 'dönen deger "xxxxx"

Space(x): 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(Harf): Verilen Harfin ascii kodunu geri verir.

Chr(ascii): Verilen ascii kodunun karakter karsiligini verir

Str(sayi): Verilen sayiyi stringe cevirir

Val(String): Verilen string'i sayiya cevirir

Hex(sayi): Verilen dezimal sayiyi hexadezimal sayiya cevirir.

Oct(sayi): 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 "[A-Z]" ' True.
Test1 = "F" Like "[!A-Z]" ' False.
Test1 = "a2a" Like "a#a" ' True.
Test1 = "aM5b" Like "a[L-P]#[!c-e]" ' 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" (ByVal _
hwnd As Long, ByVal hRgn As Long, ByVal bRedraw _
As Long) As Long

Private Declare Function ReleaseCapture Lib "user32" () _
As Long

Private Declare Function SendMessage Lib "user32"Alias _
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As _
Long, ByVal wParam As Long, lParam As Any) As Long

Private Const HTCAPTION = 2
Private Const WM_NCLBUTTONDOWN = &HA1
Private Sub Form_Load()
Me.Picture = LoadPicture(App.Path & "\Back.gif")
Call CreateReg
End Sub

Private Sub Command1_Click()
Unload Me
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, _
x As Single, y As Single)

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" _
(ByVal hWnd As Long, ByVal idAni As Long, lprcFrom _
As RECT, lprcTo As RECT) 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(Cancel As Integer)
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(i%, Text$)
If Winsock(i).State = 7 Then
Winsock(i).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(Index As Integer, ByVal requestID As Long)
'Aktif Kullaniciyi tanimla
Dim i%
START:

For i = 1 To User.ListItems.Count
User.ListItems.Item(i).SubItems(1) = Winsock(User.ListItems.Item(i)).State

If User.ListItems.Item(i).SubItems(1) <> 7 Then
Winsock(User.ListItems.Item(i)).Close
Unload Winsock(User.ListItems.Item(i))
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(i) > User.ListItems(i - 1) + 1 Then
Load Winsock(User.ListItems(i) - 1)
Winsock(User.ListItems(i) - 1).LocalPort = 10567
Winsock(User.ListItems(i) - 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(Index As Integer, ByVal bytesTotal As Long)
'Aktif kullaniciyi tanimla
Dim i%
START:

For i = 1 To User.ListItems.Count
User.ListItems.Item(i).SubItems(1) = Winsock(User.ListItems.Item(i)).State

If User.ListItems.Item(i).SubItems(1) <> 7 Then
Winsock(User.ListItems.Item(i)).Close
Unload Winsock(User.ListItems.Item(i))
User.ListItems.Remove i
GoTo START
End If
Next i

'Mesaj al
Dim Message$

Winsock(Index).GetData Message
Call SetList(Mid(Message, 1, 1) & Index & Mid(Message, 2, Len(Message)))
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(Message))
ok = 0

For i = 1 To User.ListItems.Count
If LCase(User.ListItems(i).SubItems(2)) = LCase(MTo) Or LCase(MTo) = "alle"Then

If LCase(User.ListItems(i).SubItems(2)) <> LCase(MFrom) Then
WSend User.ListItems.Item(i), MText
SetList "3%" & User.ListItems(i).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(Message$)
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(, , ID)
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(Message))
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(Message))

Case 3: If LMessage.ListItems.Count > 13 Then LMessage.ListItems.Remove 1
Set litem = LMessage.ListItems.Add(, , ID)
litem.SubItems(1) = Mid(Message, 3, InStr(1, Message, "$") - 3)

litem.SubItems(2) = "MailServer"
litem.SubItems(3) = "<- " & Mid(Message, InStr(1, Message, "$") + 1, Len(Message))
End Select
End Function

**KaRa_KRaL** · 20-05-2006 23:29

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" (ByVal hwnd As Long, ByVal wMsg _
As Long, ByVal wParam As Long, lParam As Any) As Long

Private Const HTCAPTION = 2
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const WM_SYSCOMMAND = &H112

Private Sub label1_MouseDown(Button As Integer, Shift As _
Integer, X As Single, Y As Single)

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" _
(ByVal uAction As Long, ByVal uParam As _
Long, ByVal lpvParam As Any, ByVal fuWinIni _
As Long) As Long

Private Sub Command1_Click()
Dim Sonuc&
Sonuc= SystemParametersInfo(97, True, "1", 0)
Label1.Caption = "[Ctrl] + [Alt] + [Del] iptal edildi"
End Sub

Private Sub Command2_Click()
Dim Sonuc&
Sonuc = SystemParametersInfo(97, False, "1", 0)
Label1.Caption = "[Ctrl] + [Alt] + [Del] 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(Cancel As Integer)
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(ByVal requestID As Long)
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(ByVal bytesTotal As Long)
Dim Data() As Byte

Winsock1.GetData Data, vbString
If Data(0) = 77 Then
OkFlag = False
End If
End Sub

Private Sub SendFile(FileName$)
Dim Data() As Byte
Dim l&, AA$, BB$, x&, FN%, TM As Single

On Error Resume Next

If Not Connected Then
MsgBox ("Istemciye Baganti Kurulamiyor!")
Exit Sub
End If

Call Disable
l = FileLen(FileName)
AA = Hex(l)
Do While Len(AA) < 8
AA = "0" & AA
Loop

BB = LastPath(FileName)
BB = BB & Space$(257 - Len(BB))
AA = "New Data|" & AA & BB
ReDim Data(0 To Len(AA) - 1)
For x = 1 To Len(AA)
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(FN)
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 / (Timer - TM) * _
10) / 10 & " kB/Sec"

Label5.Refresh
If Not WaitForResponse Then
MsgBox ("Transfer Hatasi")
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 / (Timer - TM) * _
10) / 10 & " kB/Sec"

Label5.Refresh
If Not WaitForResponse Then
MsgBox ("Transfer Hatasi")
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 ("Baglanti Kurulamadi!")
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(ByVal Prg&, ByVal Min&, ByVal Max&)
Dim Fx&
Static LastX
If Prg < Min Or Prg > Max Or Max <= Min Then Exit Sub
Prg = Int(100 / (Max - Min) * (Prg - Min))
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(Prg) & " %")
LastX = Prg
End If
Else
Picture1.Cls
End If
End With
End Sub

Private Function LastPath(ByVal Path$) As String
Dim AA$, BB$, x&
For x = Len(Path) 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--------------------------

'-------------------- 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 = (Screen.Width - .Width) / 2
End With

With Me
.Left = Form1.Left
.Top = Form1.Top - .Height
End With
End Sub

Private Sub Form_Unload(Cancel As Integer)
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 ("Sunucuya baglanti Kurulamadi")
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(ByVal bytesTotal As Long)
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(Data) = 273 And Not Rec Then
For x = 0 To UBound(Data)
AA = AA & Chr$(Data(x))
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(Data) + 1

d = (Timer - TM)
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 ("Transfer Basariyla Tamamlandi!")
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(x) = 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(ByVal Prg&, ByVal Min&, ByVal Max&)
Dim Fx&
Static LastX
If Prg < Min Or Prg > Max Or Max <= Min Then Exit Sub
Prg = Int(100 / (Max - Min) * (Prg - Min))
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(Prg) & " %")
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(ByVal Path$) As String
Dim AA$, BB$, x&
For x = Len(Path) 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

**KaRa_KRaL** · 20-05-2006 23:32

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

**KaRa_KRaL** · 20-05-2006 23:38

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.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

**KaRa_KRaL** · 20-05-2006 23:39

Bu kod sayesinde internete bagli olup olmadigimiz ögrenilebilir

Option Explicit

Private Declare Function RasEnumConnections Lib "RasApi32.dll" _
Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As _
Long, lpcConnections As Long) As Long

Private Declare Function RasGetConnectStatus Lib "RasApi32.dll" _
Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, _
lpStatus As Any) As Long

Const RAS_MaxEntryName = 256
Const RAS_MaxDeviceType = 16
Const RAS_MaxDeviceName = 32

Private Type RASType
dwSize As Long
hRasCon As Long
szEntryName(RAS_MaxEntryName) As Byte
szDeviceType(RAS_MaxDeviceType) As Byte
szDeviceName(RAS_MaxDeviceName) As Byte
End Type

Private Type RASStatusType
dwSize As Long
RasConnState As Long
dwError As Long
szDeviceType(RAS_MaxDeviceType) As Byte
szDeviceName(RAS_MaxDeviceName) 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(RAS_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type

Private Declare Function RasEnumConnections Lib "RasApi32.DLL" _
Alias "RasEnumConnectionsA" (lprasconn As Any, lpcb As _
Long, lpcConnections As Long) As Long

Private Declare Function RasEnumEntries Lib "RasApi32.DLL" _
Alias "RasEnumEntriesA" (ByVal reserved$, ByVal _
lpszPhonebook$, lprasentryname As Any, lpcb As Long, _
lpcEntries As Long) As Long

Private Declare Function RasHangUp Lib "RasApi32.DLL" _
Alias "RasHangUpA" (ByVal hRasConn As Long) As Long

Dim DFÜname$, RCon As Long

Private Sub HangUp(ByVal Verbindung$)
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(l).szEntryName(), vbUnicode)
aa = Left$(aa, InStr(aa, Chr$(0)) - 1)
If aa = Verbindung Then
RCon = r(l).hRasConn
Dim rec As Long
rec = RasHangUp(RCon)
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 "{ENTER}", True
SendKeys "{ENTER}", True
Me.SetFocus
End Sub

Private Sub Command2_Click()
Call HangUp(DFÜname)
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(i).szEntryName(), vbUnicode)
List1.AddItem Left$(conname, InStr(conname, vbNullChar) - 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" (ByVal _
bShow As Long) 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

**KaRa_KRaL** · 20-05-2006 23:40

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" (ByVal _
IcmpHandle As Long) As Long

Private Declare Function IcmpSendEcho Lib "icmp.dll" (ByVal _
IcmpHandle As Long, ByVal DestinationAddress As Long, _
ByVal RequestData As String, ByVal RequestSize As _
Integer, ByVal RequestOptions As Long, ReplyBuffer As _
ICMP_ECHO_REPLY, ByVal ReplySize As Long, ByVal _
TimeOut As Long) As Long

Private Declare Function WSAGetLastError Lib "wsock32.dll" () _
As Long

Private Declare Function WSAStartup Lib "wsock32.dll" (ByVal _
wVersionRequired As Long, lpWSAData As WSAData) As Long

Private Declare Function WSACleanUp Lib "wsock32.dll"Alias _
"WSACleanup" () As Long

Private Declare Function GetHostName Lib "wsock32.dll"Alias _
"gethostname" (ByVal szHost As String, ByVal dwHostLen _
As Long) As Long

Private Declare Function GetHostByName Lib "wsock32.dll"Alias _
"gethostbyname" (ByVal szHost As String) As Long

Private Declare Sub CopyMemory Lib "kernel32"Alias _
"RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As _
Long, ByVal cbCopy As Long)

Private Declare Function htonl Lib "wsock32.dll" (ByVal hostlong _
As Long) As Long

Private Declare Function htons Lib "wsock32.dll" (ByVal hostshort _
As Long) As Integer

Private Declare Function inet_addr Lib "wsock32.dll" (ByVal cp _
As String) As Long

Private Declare Function inet_ntoa Lib "wsock32.dll" (ByVal inn _
As Long) As Long

Private Declare Function ntohl Lib "wsock32.dll" (ByVal netlong _
As Long) As Long

Private Declare Function ntohs Lib "wsock32.dll" (ByVal netshort _
As Long) 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(MAXGETHOSTSTRUCT) 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(ByVal Host$) 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 ("Socket Hatasi!")
Exit Function
End If

LH = inet_addr(Host$)
repIP = LH
If LH = INADDR_NONE Then
phe = GetHostByName(Host$)
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("GetHostByName yanlis deger gönderdi!")
GetHost = INADDR_NONE
Exit Function
End If
End If
Form1.Text4.Text = CStr(repIP)
GetHost = repIP
End Function

Public Function GetStatusCode(Status As Long) 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(Status) & " [ " & Msg & " ]"
End Function
Private Function HiByte(ByVal wParam As Integer)
HiByte = wParam \ &H100 And &HFF&
End Function

Private Function LoByte(ByVal wParam As Integer)
LoByte = wParam And &HFF&
End Function

Public Function Ping(szAddress As String, _
ECHO As ICMP_ECHO_REPLY) 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(szAddress)

hPort = IcmpCreateFile()

If IcmpSendEcho(hPort, dwAddress, sDataToSend, Len(sDataToSend), _
0, ECHO, Len(ECHO), PING_TIMEOUT) Then

Ping = ECHO.RoundTripTime
Else: Ping = ECHO.Status * -1
End If

Call IcmpCloseHandle(hPort)
a = SocketsCleanup
End Function

Private Function AddressStringToLong(ByVal Tmp As String) As Long
Dim i As Integer
Dim parts(1 To 4) As String

i = 0
While InStr(Tmp, ".") > 0
i = i + 1
parts(i) = Mid(Tmp, 1, InStr(Tmp, ".") - 1)
Tmp = Mid(Tmp, InStr(Tmp, ".") + 1)
Wend

i = i + 1
parts(i) = 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$(X)) & _
" 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(WS_VERSION_REQD, WSAD)
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(ECHO.Status)
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

**KaRa_KRaL** · 20-05-2006 23:42

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" _
(ByVal uDeviceID As Long, lpdwVolume As Long) As Long

Private Declare Function waveOutSetVolume Lib "winmm.dll" _
(ByVal uDeviceID As Long, ByVal dwVolume As Long) _
As Long

'WAV dosyasi Cal
Private Declare Function mciSendString Lib "winmm.dll"Alias _
"mciSendStringA" (ByVal lpstrCommand As String, ByVal _
lpstrReturnString As String, ByVal uReturnLength As _
Long, ByVal hwndCallback As Long) 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(X).DeviceName
AA = AA & Space$(35 - Len(AA)) & Printers(X).Port
List1.AddItem AA

If Printer.DeviceName = Printers(X).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)
MS = Int((MS - S) * 10)

strH = CStr(H)
strM = Format(CStr(M), "##00")
strS = Format(CStr(S), "##00")
strMS = CStr(MS)
Label1.Caption = strH & ":" & strM & ":" & strS & ":" & strMS
End Sub

alıntıdır...

**blaster** · 21-05-2006 01:03

Kara kral bu kadar kodu yazdığına göre vb konusunda ustasındır.Bana bir iki ödevimde yardım edebilirmisin.

**purple86** · 05-11-2006 04:16

kara kral gerçekten vbde ustasın bu yüzden senden bişi rica edicektim bana ya da forma daha kolay vb örnekleri koyabilir misin yeni öğreniyorum vbyi bu kodlar benim için çok zor yardım edersen çok sevinirim