Sayfa 1/2 12 SonSon
13 sonuçtan 1 ile 12 arası
  1. #1
    Uzman Array KaRa_KRaL - ait Kullanıcı Resmi (Avatar)
    Üyelik tarihi
    Aug 2005
    Yer
    Desktop
    Mesajlar
    2.130
    İtibar Gücü
    15

    Visual Basic Dersleri

    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

  2. #2
    Uzman Array KaRa_KRaL - ait Kullanıcı Resmi (Avatar)
    Üyelik tarihi
    Aug 2005
    Yer
    Desktop
    Mesajlar
    2.130
    İtibar Gücü
    15
    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

  3. #3
    Uzman Array KaRa_KRaL - ait Kullanıcı Resmi (Avatar)
    Üyelik tarihi
    Aug 2005
    Yer
    Desktop
    Mesajlar
    2.130
    İtibar Gücü
    15
    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

  4. #4
    Uzman Array KaRa_KRaL - ait Kullanıcı Resmi (Avatar)
    Üyelik tarihi
    Aug 2005
    Yer
    Desktop
    Mesajlar
    2.130
    İtibar Gücü
    15
    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

  5. #5
    Uzman Array KaRa_KRaL - ait Kullanıcı Resmi (Avatar)
    Üyelik tarihi
    Aug 2005
    Yer
    Desktop
    Mesajlar
    2.130
    İtibar Gücü
    15
    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

  6. #6
    Uzman Array KaRa_KRaL - ait Kullanıcı Resmi (Avatar)
    Üyelik tarihi
    Aug 2005
    Yer
    Desktop
    Mesajlar
    2.130
    İtibar Gücü
    15
    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

  7. #7
    Uzman Array KaRa_KRaL - ait Kullanıcı Resmi (Avatar)
    Üyelik tarihi
    Aug 2005
    Yer
    Desktop
    Mesajlar
    2.130
    İtibar Gücü
    15
    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...

  8. #8
    DM Sever Array
    Üyelik tarihi
    May 2006
    Mesajlar
    218
    İtibar Gücü
    0
    Kara kral bu kadar kodu yazdığına göre vb konusunda ustasındır.Bana bir iki ödevimde yardım edebilirmisin.
    ALIK MALMELRİ SAveTİCLT.ŞT.
    Telon : (02) 9 10 10(Pbx)
    Fas : (0212) 659 102 Aes : İoç Toptlar Siesi 2a N:155 hmutbe İst.

  9. #9
    Acemi Üye Array
    Üyelik tarihi
    Nov 2006
    Mesajlar
    16
    İtibar Gücü
    0
    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

  10. #10
    Uzman Array KaRa_KRaL - ait Kullanıcı Resmi (Avatar)
    Üyelik tarihi
    Aug 2005
    Yer
    Desktop
    Mesajlar
    2.130
    İtibar Gücü
    15
    vb de usta değilim öğrendiklerimi veya gördüğmü dökümanları paylaşıyorum.bulursam eklerim elbet

  11. #11
    Acemi Üye Array shekil_boy - ait Kullanıcı Resmi (Avatar)
    Üyelik tarihi
    Oct 2008
    Mesajlar
    2
    İtibar Gücü
    0
    tsklerrrr emeğine sağlık

  12. #12
    Acemi Üye Array
    Üyelik tarihi
    Oct 2008
    Mesajlar
    13
    İtibar Gücü
    10
    eyvallah

Sayfa 1/2 12 SonSon

Konu Bilgileri

Users Browsing this Thread

Şu an 1 kullanıcı var. (0 üye ve 1 konuk)

Yetkileriniz

  • Konu Acma Yetkiniz Yok
  • Cevap Yazma Yetkiniz Yok
  • Eklenti Yükleme Yetkiniz Yok
  • Mesajınızı Değiştirme Yetkiniz Yok
  •  


Donanım forumu - Byte Hesaplayıcı - Notebook tamir Beşiktaş - beşiktaş bilgisayar servisi - beşiktaş bilgisayar servis - beşiktaş notebook servisi - beşiktaş servis - Beşiktaş Kamera Kurulumu - oyun
 

SEO by vBSEO 3.6.0 RC 2