Visual Basic Kodları

Visual Basic Kodları

Konu Görünümü | Doğrusal Görünüm

Visual Basic Kodları

Yazar Mesaj

Derbent
Administrator

Üye Bilgileri
Mesaj Sayısı : 1,971
Üye no : 2
Durum :

Rep BiLgisi

Rep Derecesi : 21
Rep Ver :

Mesaj: #1

Visual Basic Kodlarğ

Basliksiz Formu Hareket Ettirme

Kod:

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 SubINTERNET BAGLANTI BILGILERINI ÖGRENMEK

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.

Kod:

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 AdapterBytesRecvd"]

SBytes = ReadBytes("Dial-Up AdapterBytesXmit"]

CSpeed = ReadBytes("Dial-Up AdapterConnectSpeed"]

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, "PerfStatsStatData", 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 AdapterBytesRecvd"]

s1 = ReadBytes("Dial-Up AdapterBytesXmit"]

SUM = 0

CNT = 1

End Sub

INTERNET BAGLANTI DURUMUNU OGRENMEK

Bu kod sayesinde internete bagli olup olmadigimiz ögrenilebilir

Kod:

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 BAGLANTISI OLUSTURMAK - KESMEK

Bu kod sayesinde internete bagli olup olmadigimiz ögrenilebilir.

Kod:

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 SubFormu Yakip Söndürme

Private Sub Timer1_Timer(]

If Me.Visible = True Then

Me.Visible = False

Else

Me.Visible = True

End If

End Sub

Private Sub Command1_Click(]

Timer1.Interval = 1000

End Sub

BACIMIN ÖRTÜSÜ BATMAKTADIR REZİLİN GÖZÜNE, TÜKÜRSEM BİLLAHİ ACIRIM TÜKRÜĞE
M.AKİF ERSOY

(Bu Mesaj 26-04-2008 12:31 AM değiştirilmiştir. Değiştiren : Derbent.)

26-04-2008 12:28 AM

« Önceki | Sonraki »

Bu Konudaki Mesajlar

Visual Basic Kodlarğ - Derbent - 26-04-2008 12:28 AM

RE: Visual Basic Kodlarğ - Derbent - 26-04-2008, 12:31 AM

RE: Visual Basic Kodlarğ - Derbent - 26-04-2008, 12:35 AM

RE: Visual Basic Kodlarğ - karanfil - 09-05-2008, 03:35 PM

RE: Visual Basic Kodlarğ - bazdaran - 04-02-2009, 11:48 AM

RE: Visual Basic Kodları - sheqer_beyza - 29-01-2010, 11:20 AM

RE: Visual Basic Kodları - Derbent - 29-01-2010, 01:12 PM

Benzeyen Konular
Konu:		Yazar	Cevaplar:	Görüntüleyenler:	Son Mesaj
	Visual Basicte menü hazırlama	Derbent	0	502	03-03-2008 08:49 PM Son Mesaj: Derbent
	Visual Basic Nedir?	Derbent	0	330	03-03-2008 08:42 PM Son Mesaj: Derbent
	Visual Basic Professionel Gorsel Anlatım	Derbent	0	562	03-03-2008 12:49 PM Son Mesaj: Derbent

Yazdırılabilir Bir Sürümü Görüntüle
Bu Konuyu Bir Arkadaşına Gönder
Bu Konuya Abone Ol |

Derecelendir

0 Oylar - 0 Yüzde
1
2
3
4
5

Forum Atla:

İletişim - Anasayfa - Yukarıya dön - İçeriğe Dön - Hafifleştirilmiş Sürüm - RSS Beslemesi

Kayıt Olabilmek İçin Kutucukların İşaretini Kaldırmayın Hızlı Kayıt Ol
Kullanıcı Adı	Şifre	Şifre Tekrar	Email	Email Tekrar