Listbox'a degisik renklerde item nasil eklenir?
MSFlexGrid control kullanin



Form close butonu nasil çalistirilir?
dim bClose as Boolean
Form'un QueryUnload event'ine ekle:
If bClose = false then cancel = true



Text dosyasina çift tirnak isaretleri olmadan nasil string girisi yapilir?
Write # statement yerine Print # statement kullan
Print # statement stringlerin etrafina çift tirnak koymaz



Bir combo'nun içini diger bir combo'dan aldiklarinizla nasil doldurursunuz?
Sub comboA_click()
comboB.text = comboA.text
End sub

Eger ComboA'daki seçili degerlerin ComboB'ye aktarilmasini istiyorsaniz
Sub comboA_click()
comboB.AddItem comboA.text
end sub




Birden fazla sütun içeren combolar nasil yapilir?
Projenize Microsoft Forms 2.0 control ekleyin, oradaki
combo multi-column destekler.

Combo1.Clear
Combo1.ColumnCount = 2
Combo1.ListWidth = "6 cm" 'Total genislik
Combo1.ColumnWidths = "2 cm;4 cm" 'sütun genisligi
Combo1.AddItem "Ivir zivir"
Combo1.List(0, 1) = "Ivir zivir"



Dikine uzanan label nasil yapilir?
Private Sub Form_Activate()
Dim s As String
Label1.Caption = "Visual Basic 2000"
For i = 1 To Len(Label1)
s = s & Mid$(Label1, i, 1) & vbCrLf
Next
Label1 = s
End Sub
dikkat: Label'i dikine çekmelisiniz



Joker karakterler kullanarak string nasil aranir?

Dim Mystr As String
Mystr = "Hakan"
If Mystr Like "H*" Then
MsgBox "Bulundu"
Else
MsgBox "Bulunamadi"
End If

Text kutusunda olan degisiklik nasil farkedilir?

'Amaç kullaniciyi yaptigi degisiklikler konusunda programi kapatmadan uyarmaktir.

Public Degisti As Boolean 'Bu degisken textbox'ta herhangi bir degisiklik olup olmadigini tutar.
Private Sub Text1_Change()
Degisti= True
End SubPrivate

Sub Form_Unload(Cancel As Boolean)
If Degisti Then
If Msgbox("Degisiklikler kaydedilsin mi?", vbYesNo, "Kayit'") = vbYes Then
'Buraya kaydetme ile ilgili kodlar gelecek
Degisti = False
' Degisti degerini tekrar False yap ki bir sonraki degisiklikte tekrar çalisabilsin. (Bu Önemli!!!!)
'Bunu sadece buradaki If - End If blogu arasina yaz
End If
End If
End Sub



Çalisma aninda Statusbar içerigi nasil degistirilir?
Statusbar1.Panels(1).Text = "Ivir zivir"



Listbox'a bir text dosyasi içerigi nasil yüklenir?
Private Sub Command1_Click()
Dim BulunanKelimeler As String
Open "C:\test.txt" For Input As #1
List1.Clear
While Not EOF(1)
Input #1, StringHold
List1.AddItem BulunanKelimeler
Wend
Close #1
End Sub



Textbox ve Combobox için Undo (geri al) fonksiyonu nasil kullanilir?
'Bir Windows API undo islemi yapar

'asagidaki deklerasyonlari yaz
Declare Function SendMessage Lib "User" (ByVal hWnd As _
Integer, ByVal wMsg As Integer, ByVal wParam As _
Integer, lParam As Any) As Long

'asagidaki degismezleri yaz

Global Const WM_USER = &h400
Global Const EM_UNDO = WM_USER + 23

' Undo Sub 'lara asagidaki kodu yaz
UndoResult = SendMessage(myControl.hWnd, EM_UNDO, 0, 0)

'UndoResult = -1 olursa hata var demektir
'UndoResult sadece bir rakamdir ve hiç bir önemi yoktur. Sadece yer tutmasi için yazilir.
'VB'nin buna benzer gariplikleri vardir. Bir amaci varsa da ben bilmiyorum



Clipboard'dan text nasil kopyalanir?
'Textbox'ta texti isaretle ve isaretlenen yeri clipboard'dan kopyaladiginla degistir:

txtBox.SelText = Clipboard.GetText

'Yada tüm text'i clipboarddan aldiginla degistir.

txtBox.Text = Clipboard.GetText

Clipboard'a text nasil kopyalanir?
'Önce clipboard'u temizle
Clipboard.Clear

'Sonra kopyalanacak alani seç ve clipboard'a kopyala
Clipboard.SetText txtBox.Text, vbCFText



Toolbar'in click olayi nasil kodlanir?

Private Sub Toolbar1_ButtonClick(ByVal Button As Button)

'button clicklerini saptamak için:

Select Case Button.Key
Case Is = "Exit"
If MsgBox("Çikmak istiyor musunuz??", vbQuestion + vbYesNo + _
vbDefaultButton2, "Programdan çikiyorsunuz!") = vbNo Then Exit Sub
Call ExitProgram
Case Is = "Repair"
Call Repairdb
Case Is = "Delete"
Call DeleteRoutine
Case Is = "Edit"
Call EditRoutine
Case Is = "New"
Call NewRoutine
Case Is = "Copy"
Call CopyToClipboard
Case Is = "Help"
Call ShowHelpContents
End Select
End Sub



Cdbl ile Val fonksiyonlari arasindaki fark nedir?
print Val("12345")
12345

print Val("12,345")
12

print CDbl("12,345")
12345

print CDbl("12345")
12345



Dogum gününden kisinin yasi nasil hesaplanir?
'Text'i Date data türüne çevir

Dim Birth as Date
Birth = DateValue(txtDOB)

'Yasi hesapla
Dim Age as Integer
Age = Int(DateDiff("D", Birth, Now) / 365.25)



4 rakamli tarih nasil kontrol edilir?

Public Function ValidDate(MDate)

'Amaç: 4 digitli "yyyy" formatindaki tarihi kontrol etmek; hata var ise kullaniciyi uyarmaktir.
'Input: Texbox'tan string
'Output: True yada False
'Default : False

ValidDate = False

'Eger uzunluk "m/d/yyyy" 'den kisa ise fonkiyondan çik
If Len(MDate) < 8 Then Exit Function

'Geçerli bir tarih türü girilmemisse terket
If IsDate(MDate) = False Then Exit Function

'Sonu "yyyy" ile bitmiyorsa yada baslamiyorsa terket
Dim StartDate As String
Dim EndDate As String

EndDate = Right(MDate, 4)
StartDate = Left(MDate, 4)

If ValidChar(EndDate, "0123456789") = False And _

ValidChar(StartDate, "0123456789") = False Then Exit Function


'Tüm bu testlerden geçilirse True yükle
ValidDate = True
End Function



Hata kontrol bloklari nasil denetlenir?
'error kodunu baslat
On Error GoTo HataKontrol

'Buraya program kodlarini gir. Buradan sonrasi artik hata denetimine açiktir.
'Hata kontrolundan çikmak istersen 0 (sifir) a git
On Error GoTo 0 : Exit Function ' ve fonksiyonu terket

:HataKontrol
Dim strErr As String

'Kullaniciya olusan hata ve tanimini ver
strErr = "Hata olustu: " & Err.Number & " " & Err.Description
MsgBox strErr, vbCritical + vbOK, "Hata!"



Web adresleri nasil açilir?
'Asagidaki kodu bir kontrolun click event'ine yaz
Dim iRet As Long
Dim Cevap As Integer

Cevap = MsgBox("Linklerin Görülmesine İzin Verilmiyor
Linki Görebilmek İçin Üye Ol veya Giriş Yap adresini açmak istiyor musunuz?", vbInformation + vbYesNo, "Linklerin Görülmesine İzin Verilmiyor
Linki Görebilmek İçin Üye Ol veya Giriş Yap")

Select Case Cevap
Case vbYes
iRet = Shell("start.exe Linklerin Görülmesine İzin Verilmiyor
Linki Görebilmek İçin Üye Ol veya Giriş Yap", vbNormal)
Case vbNo
Exit Sub
End Select



10, 100, 1000 gibi rakamlara en yakin sayi nasil yuvarlanir?

'Örnek 100' yuvarla:
Round(RatioBolus * Val(txtDW), 100)

'BAS module'ü içine yaz
Public Function Round(Dose, Factor)
'Amaç: Sayiyi yuvarlamak
'Girdi: Sayi, Factor (10, 100, 1000, etc)
'Çikti: Yuvarlanmis sayi

Dim Temp As Single
Temp = Int(Dose / Factor)
Round = Temp * Factor
End Function



Menüye 13x13 bitmaplar nasil eklenir?

'Bir Picturebox control ekle
'Autosize özelligini 'True' yap unutma: bitmap olacak (Icon degil)
'maximum 13X13 bitmap olmali.

'Asagidaki deklerasyonlari bir Bas modulune ekle:
'Bu örnek VB4 içindir

Private Declare Function VarPtr Lib "VB40032.DLL" (variable As Any) As Long
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long

Const MF_BYPOSITION = &H400&
'form load event içine asagidaki kodu yerlestir

Dim mHandle As Long, lRet As Long, sHandle As Long, sHandle2 As Long
mHandle = GetMenu(hwnd)
sHandle = GetSubMenu(mHandle, 0)
lRet = SetMenuItemBitmaps(sHandle, 0, MF_BYPOSITION, imOpen.Picture, imOpen.Picture)
lRet = SetMenuItemBitmaps(sHandle, 1, MF_BYPOSITION, imSave.Picture, imSave.Picture)
lRet = SetMenuItemBitmaps(sHandle, 3, MF_BYPOSITION, imPrint.Picture, imPrint.Picture)
lRet = SetMenuItemBitmaps(sHandle, 4, MF_BYPOSITION, imPrintSetup.Picture, imPrintSetup.Picture)
sHandle = GetSubMenu(mHandle, 1)
sHandle2 = GetSubMenu(sHandle, 0)
lRet = SetMenuItemBitmaps(sHandle2, 0, MF_BYPOSITION, imCopy.Picture, imCopy.Picture)



Çalisma aninda menü nasil olusturulur?

Dim index As Integer
index = mnuHook.Count
Load mnuHook(index)
mnuHook(index).Caption = "New Menu Entry"
mnuHook(index).Visible = True

'Yeni girdiler mnuHook 'dan sonra olusur. Ancak unutmayin mnuHook halihazirda varolan bir menü elemanidir.

Ekran çözünürlügü nasil bulunur?
Genelde ekran çözünürlügüne göre programlarinizdaki nesneleri resize etmek oldukça kullanisli bir yoldur.

Ekran çözünürlügünü söyle bulursunuz:
Asagidaki kodu form_load'a yazarsaniz her açilista ekran çözünürlügünü kontrol eder.

Genislik = Screen.Width \ Screen.TwipsPerPixelX
Yukseklik = Screen.Height \ Screen.TwipsPerPixelY

Ekran_Cozunurlugu = Genislik & "x" & Yukseklik

Sonuç asagidaki gibi olur:

800x600



Veritabanina nasil daha hizli ulasilir?

Bir recordset içinde daha hizli döngü çalistirmak için bir yol var. Genelde bir çok programci asagidaki kodu kullanir:

Do While Not Records.EOF   'Dosya sonuna kadar döngü baslat
Combo1.AddItem Records![Firma Adi]   'Combo'ya Records recordset'inin [Firma Adi] adli alanini ekle
Records.Movenext 'Bir sonraki kayda git
Loop

Buradaki problem her defasinda veritabaninin bir sonraki kayda gitmek için dosya sonuna ulasip ulasmadigini kontrol etmek zorunda olmasidir. Bu zorunluluk özellikle çok büyük veritabanlarinda büyük performans kayiplarina neden olur. Çözüm ise önce kayit adedini RecordCount ile bulmak ve For ---- Next döngüsü ile kayit okumaktir :

Records.MoveLast ' Recordset'in sonuna giderek kaç adet kayit oldugunu bulmalisiniz. Bu islemin bir kez yapilmasi yeterlidir.
KayitSayisi=Records.RecordCount   'Kayit sayisi bir long degisken içine alindi
Records.MoveFirst 'Ilk kayda gel

For i =1 To KayitSayisi    'Simdi kayitlari EOF telasi olmadan birer birer okuyalim
        Combo1.AddItem Records![Firma Adi]
        Records.MoveNext
Next

Iste size garantili %33'lük performans artisi


 

Gökkusagi renklerinde text nasil olusturulur?

1. Standart EXE projesi baslat
2. Asagidaki kodu Form'un Paint proc'una yaz:

Sub Form_Paint()
Dim I As Integer, X As Integer, Y As Integer
Dim C As String
Cls
For I = 0 To 91
X = CurrentX
Y = CurrentY
C = Chr(I)
Line -(X + TextWidth(C), Y = TextHeight(C)), QBColor(Rnd * 16), BF
CurrentX = X
CurrentY = Y
ForeColor = RGB(Rnd * 256, Rnd * 256, Rnd * 256)
Print "Merhaba Basic Programciligi"
Next
End Sub

3. Projeyi çalistirirsaniz formun degisik renklerde yaziyla kaplandigini görürsünüz.
and watch the form fill with lots of multi-coloured text




Text kutusundaki bosluklar nasil yokedilir?
Kullanicilarin text kutusuna bosluk karakteri girmelerini engellemek için :
Textbox 'un KeyPress olayina asagidaki kodu yaz:

Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 32 Then
    KeyAscii = 0
End If
End Sub




Tek harekette text dosyasi nasil yüklenir?
FileText fonksiyonunu kullanarak istediginiz dosyayi açar ve textbox içine yerlestirirsiniz.
Fonksiyonu Bas modulu içine yaz

Function FileText (filename$) As String
Dim dosya As Integer
dosya = FreeFile
Open filename$ For Input As #dosya
FileText = Input$(LOF( dosya), dosya)
Close # dosya
End Function

Text1.Text = FileText("c:\autoexec.bat") 'Text1 textbox'una tek hamlede autoexec.bat içerigi yüklenir.




Windows Control Panel (Denetim masasi) uzantilari VB ile nasil açilir?

Option Explicit
Private strPanelAdi As String
Private Sub Command1_Click()

strPanelAdi = File1.filename
If strPanelAdi = "" Then
MsgBox "Bir .CPL dosyasi seçilmedi." & vbCrLf & _
"Windows Control Panel açiliyor.",vbInformation
End If
Shell "rundll32.exe shell32.dll,Control_RunDLL " & _
strPanelAdi, vbNormalFocus
End Sub

Private Sub Form_Load()
With File1
'Sadece Control Panel uzantili dosyalari göster
.Pattern = "*.CPL"
'FileListBox yalnizca System yada System32 dizinini hedef alsin:
.Filename = "C:\Windows\System"
End With
End Sub



Bellegi bosaltmak için tüm formlar nasil unload edilir?

Public Sub UnloadAllForms()
Dim Form As Form
For Each Form In Forms
   Unload Form
   Set Form = Nothing
Next Form
End Sub

Bu prosedürü çalistirmak için en uygun yer ana formun unload event'idir

Yazdirma islemi nasil iptal edilir?
'Bu örnekte ayrica birden fazla sayfanin nasil yazilacagi da gösteriliyor

Printer.Print "Page 1"
Printer.Newpage
Printer.Print "Page 2"
Printer.KillDoc




Resim nasil yazdirilir?

Printer.PaintPicture Picture1.Picture
Printer.EndDoc




Windows'un Belgeler içerigi nasil silinir?

Bir module asagidaki API deklerasyonunu ekle:

Declare Sub SHAddToRecentDocs Lib "shell32.dll" (ByVal uFlags As Long,
ByVal pv As String)

Herhangi bir click içine de asagidaki kodu ekle:

SHAddToRecentDocs(2,vbNullString)




Windows'un Belgeler içine nasil ekleme yapilir?

Bir module asagidaki API deklerasyonunu ekle:

Declare Sub SHAddToRecentDocs Lib "shell32.dll" (ByVal uFlags As Long,
ByVal pv As String)

Herhangi bir click içine de asagidaki kodu ekle:

Dim ekleme as String
ekleme="c:\falan dizin\filan dosya.txt"

SHAddToRecentDocs(2,ekleme)




Alan adina göre bir Recordset içindeki kayitlar nasil siraya konur?

'Bu kod tüm kayitlari Z-A (geriye dogru) siraya dizer

' A-Z (ileri dogru) sirasi isterseniz ,DESC yerine ASC kullanin.

Dim DB as Database
Dim Kayitlar as Recordset

Set Kayitlar = DB.OpenRecordset("SELECT * FROM _
Personel " & "ORDER BY Personel.Adi DESC;")

Personel tablosundan tüm kayitlari Adi (personel adi) field degerine göre azalan (Z-A ) sekilde siraya dizer




Listbox'u Access (mdb) veritabanina nasil baglarsiniz?

On Error GoTo Hata_Kontrol

Dim DB as Database
Dim Kayitlar as Recordset
Dim X as Long, record_count as Long

'Veritabanini açalim

Set DB = OpenDatabase("Ogrenci.mdb", dbOpenSnapshot)
Set Kayitlar = DB.OpenRecordset("Ogrenciler")

' Dikkat ederseniz asagida yapilan islem önce veritabaninin sonuna gitmek, RecordCount degerini
' ögrenmek ve sonra tekrar veritabani basina dönmektir. Veritabani sonuna gitmeden kaç adet kayit
' oldugunu ögrenemezsiniz.

Kayitlar.MoveLast
X = Kayitlar.RecordCount
Kayitlar.MoveFirst

' Listbox içine adlari yerlestirelim
' Ilk kayita geldikten sonra artik sirayla ögrenci adlarini listbox içine alabiliriz

Do
List1.AddItem Kayitlar!OgrenciAdi
Y = Y + 1
Kayitlar.MoveNext
Loop Until Y = X ' X = Recordcount, yani son kayit

Hata_Kontrol:
Select Case (Err)
Case 3021 ' Kayit yok
record_count = 0 'Kayit yoksa degeri 0 a esitleyelim.
Exit Sub
List1.Refresh
End Select




Iki integer degisken nasil swap (degistokus) edilir?

Asagidaki algoritma kullanilarak iki integer'in degerleri birbirine aktarilir

a = a Xor b

b = a Xor b

a = a Xor b






Bir form nasil asagi ve yukari katlanir? (açilista splash screen olarak kullanmak üzere..)

Sub FormuYukariKatla(frm As Form, yukari As Integer)

' Formunuzun Scalemode property'sine dikkat edin. Eger degeri pixel ise
' ve siz twip deger kullanirsaniz form sonsuz bir döngü içinde katllanir.
' formunuzun ne kadar katlanmasini istiyorsaniz yukari degerini o kadar yükseltin
' Açilista splash screen olarak kullanilir...

Dim NereyeKadar

NereyeKadar = frm.Height - yukari
If NereyeKadar <= 0 Then Exit Sub
If yukari < 0 Then Exit Sub

Do
frm.Height = frm.Height - 1
DoEvents
Loop Until frm.Height <= NereyeKadar
End Sub

Sub FormuAsagiKatla(frm As Form, asagi As Integer)

'Yine scalemode'a dikkatedin!
' Formun ne kadar asagi katlanmasini istiyorsaniz "asagi " degerini o kadar büyütün

Dim NereyeKadar

NereyeKadar = frm.Height + yukari
If yukari < 0 Then Exit Sub

Do
frm.Height = frm.Height + 1
DoEvents
Loop Until frm.Height >= NereyeKadar
End Sub

'Asagidaki sub yordamimiz çagirir
Private Sub Command1_Click()
Call FormuAsagiKatla(Form1, 100)
End Sub




isEven fonksiyonu nasil kullanilir?

'Bu fonksiyon tek sayilarda TRUE döndürür

Function isEven(n As Integer) As Boolean
isEven = True
If n And 1 Then isEven = False
End Function

Kontroller nasil gölgelendirilir?


Yeni bir proje baslatip form üzerine bir textbox yerlestirin

Asagidakini bir module yerlestirin:

Global Const GFM_BACKSHADOW = 1
Global Const GFM_DROPSHADOW = 2

Public Sub ControlShadow(f As Form, C As Control, shadow_effect _
As Integer, shadow_width As Integer, shadow_color As Long)

Dim shColor As Long
Dim shWidth As Integer
Dim oldWidth As Integer
Dim oldScale As Integer
shWidth = shadow_width
shColor = shadow_color
oldWidth = f.DrawWidth
oldScale = f.ScaleMode

f.ScaleMode = 3
f.DrawWidth = 1

Select Case shadow_effect

Case GFM_DROPSHADOW
f.Line (C.Left + shWidth, C.Top + shWidth)-Step(C.Width - 1, _
C.Height - 1), shColor, BF

Case GFM_BACKSHADOW
f.Line (C.Left - shWidth, C.Top - shWidth)-Step(C.Width - 1, _
C.Height - 1), shColor, BF

End Select

f.DrawWidth = oldWidth
f.ScaleMode = oldScale

End Sub

Form'un Load procedurüne asagidaki kodu ekleyin:

Private Sub Form_Load()

Dim r
r = ControlShadow(me,text1,1,2,black)

End Sub


 

Title bar'in rengi nasil degistirilir?

Windows'un tüm desktop renklerini SetSysColors API fonksiyonu ile degistirebilirsiniz.
Bu fonksiyon 3 parametre alir :
1. Rengi degisecek elemanlarin sayisi
2. Color nesnesi degismezleri (const)
3. RGB degeri

API:

Declare Function SetSysColors Lib "user32" Alias _
"SetSysColors" (ByVal nChanges As Long, lpSysColor As _
Long, lpColorValues As Long) As Long



Degismezler:

Public Const COLOR_SCROLLBAR = 0 'Scrollbar rengi
Public Const COLOR_BACKGROUND = 1 'Duvarkagidi yokken masaüstü arkaplan rengi
Public Const COLOR_ACTIVECAPTION = 2 'Aktif pencere adi rengi
Public Const COLOR_INACTIVECAPTION = 3 'Aktif olmayan pencere adinin rengi
Public Const COLOR_MENU = 4 'Menu
Public Const COLOR_WINDOW = 5 'Windows arkaplan
Public Const COLOR_WINDOWFRAME = 6 'Pencere çerçevesi
Public Const COLOR_MENUTEXT = 7 'Pencere Texti
Public Const COLOR_WINDOWTEXT = 8 '3D koyu gölge (Win95)
Public Const COLOR_CAPTIONTEXT = 9 'Pencere caption text rengi
Public Const COLOR_ACTIVEBORDER = 10 'Aktif pencere sinirlari rengi
Public Const COLOR_INACTIVEBORDER = 11 'Inaktif pencere sinirlari rengi
Public Const COLOR_APPWORKSPACE = 12 'MDI desktop arkaplan rengi
Public Const COLOR_HIGHLIGHT = 13 ' seçili alan arkaplan rengi
Public Const COLOR_HIGHLIGHTTEXT = 14 'Seçili menü rengi
Public Const COLOR_BTNFACE = 15 'Button
Public Const COLOR_BTNSHADOW = 16 '3D buton gölgeleme
Public Const COLOR_GRAYTEXT = 17 'Gri text
Public Const COLOR_BTNTEXT = 18 'Button text
Public Const COLOR_INACTIVECAPTIONTEXT = 19 'Inactive pencere rengi
Public Const COLOR_BTNHIGHLIGHT = 20 'Butonun 3D isaretlenmesi rengi


Aktif pencere title bar rengini degistirmek için :

t& = SetSysColors(1, COLOR_ACTIVECAPTION, RGB(255,0,0))

Bu örnek kirmiziya çevirir.

::: ALINTIDIR :::

Hazir Kodlar #1

Basliksiz Formu Hareket Ettirme

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

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

INTERNET BAGLANTI DURUMUNU OGRENMEK

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

Formu 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

Formu Kaydirma

Private Sub Command1_Click()
Do Until Form1.Top = Screen.Height
Form1.Top = Form1.Top + 1
Loop
Unload Me
End Sub

Ekran Koruyucu

Public Sub drawcircle()
Dim red As Integer 'declare all varibles
Dim blue As Integer
Dim green As Integer
Dim xPos As Integer
Dim yPos As Integer
red = 255 * Rnd 'randomize red color
blue = 255 * Rnd 'randomize blue color
green = 255 * Rnd 'randomize green color
xPos = ScaleWidth / 2
yPos = ScaleHeight / 2
radius = ((yPos * 0.99) + 1) * Rnd
Circle (xPos, yPos), radius, RGB(red, blue, green)
End Sub
Private Sub Timer1_Timer()
Call drawcircle
End Sub

Titreyen Form

Private Sub Form_Load()
Timer1.Interval = 22
End Sub
Private Sub Timer1_Timer()
Form1.Top = Form1.Top + 50
Form1.Top = Form1.Top - 50
Form1.Left = Form1.Left - 50
Form1.Left = Form1.Top + 50
End Sub

Formu Yuvarlatma

Private Sub Form_Load()
Dim hr&, dl&
Dim usew&, useh&
usew& = Me.Width / Screen.TwipsPerPixelX
useh& = Me.Height / Screen.TwipsPerPixelY
hr& = CreateEllipticRgn(55, -20, usew, useh)
dl& = SetWindowRgn(Me.hWnd, hr, True)
End Sub

Her Koseden Program Kapatma

Private Sub Cmd1çıkış_Click()
Do Until Form1.Height = 405 And Form1.Width = 1680
Form1.Height = Form1.Height - 1
Form1.Width = Form1.Width - 1
Loop
Unload Me
End Sub
Private Sub Form_Load()
Form1.Caption = "Form Move"
Form1.Height = 0
Form1.Width = 1680
Timer1.Interval = 200
Timer1.Enabled = True
End Sub
Private Sub Timer1_Timer()
On Error Resume Next
For x = 0 To Form1.Height + 2000
Form1.Height = x
Next x
For y = 100 To Form1.Width + 1500
Form1.Width = y
Next y
Timer1.Enabled = False
End Sub

Yanip Sonen Label

Private Sub Command1_Click()
For X = 1 To 5000: DoEvents: Next X
label1.ForeColor = vbRed
For X = 1 To 5000: DoEvents: Next X
label1.ForeColor = vbBlue
For X = 1 To 5000: DoEvents: Next X
label1.ForeColor = vbGreen
For X = 1 To 5000: DoEvents: Next X
label1.ForeColor = vbRed
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
For X = 1 To 5000: DoEvents: Next X
label1.ForeColor = vbRed
For X = 1 To 5000: DoEvents: Next X
label1.ForeColor = vbBlue
For X = 1 To 5000: DoEvents: Next X
label1.ForeColor = vbGreen
For X = 1 To 5000: DoEvents: Next X
label1.ForeColor = vbRed
End Sub
Private Sub label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
For X = 1 To 5000: DoEvents: Next X
label1.ForeColor = vbRed
For X = 1 To 5000: DoEvents: Next X
label1.ForeColor = vbBlue
For X = 1 To 5000: DoEvents: Next X
label1.ForeColor = vbGreen
For X = 1 To 5000: DoEvents: Next X
label1.ForeColor = vbRed

Etrafa Carpan Top

Private Sub Command1_Click()
End
End Sub
Private Sub topa_Click()
End Sub
Private Sub xgeri_Timer()
topa.Left = topa.Left - 100
If topa.Left < 0 Then
xileri.Enabled = True
xgeri.Enabled = False
End If
End Sub
Private Sub xileri_Timer()
topa.Left = topa.Left + 100
If topa.Left > 13000 Then
xileri.Enabled = False
xgeri.Enabled = True
End If
End Sub
Private Sub ygeri_Timer()
topa.top = topa.top - 100
If topa.top < 0 Then
yileri.Enabled = True
ygeri.Enabled = False
End If
End Sub
Private Sub yileri_Timer()
topa.top = topa.top + 100
If topa.top > 9000 Then
yileri.Enabled = False
ygeri.Enabled = True
End If
End Sub

Ctrl-Alt-Delete ve Ctrl-Esc tus kombinasyonlarinin calismasini iptal etme!!!!

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
Sub CtrlAltDeleteKapat(Kapali As Boolean)
Dim X As Long
X = SystemParametersInfo(97, Kapali, CStr(1), 0)
End Sub
Ctrl-Alt-Delete kombinasyonunu kapatmak için:
Call CtrlAltDeleteKapat(True)
Ctrl-Alt-Delete kombinasyonunu açmak için:
Call CtrlAltDeleteKapat(False)

Alıntıdır