VB Formlara İlişkin Örnek Kodlar

Formu Ortalamak 

Private Sub Form_Load()

         Left = (Screen.Width - Width) / 2     ‘ Ekran yüksekliğinden form yüksekliği

         Top = (Screen.Height - Height) / 2   ‘ çıkarılarak fark ikiye bölünüyor

End Sub

Private Sub Form_Load()

         Me.Move (Screen.Height - Me.Height)/2, (Screen.Width - Me.Width)/2

End Sub

Formu Sürekli En Üstte Tutmak 

(General)(Declaration)

Const HWND_TOPMOST = -1                    ' Form en üstte

Const HWND_NOTOPMOST = -2                            ' Normal

Const SWP_NOSIZE = &H1                       ' Form boyutları değiştirilemez

Const SWP_NOMOVE = &H2                                 ' Form taşınmaz

Const SWP_NOACTIVATE = &H10                         ' Form aktif yapılmaz

Const SWP_SHOWWINDOW = &H40          ' Pencere Görünür

Private Declare Sub SetWindowPos Lib "User32" (ByVal hWnd As Long, _

                                                              ByVal hWndInsertAfter As Long, _

ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, _

                                                              ByVal wFlags As Long)

Private Sub Form_Activate()

         SetWindowPos Me.hWnd, HWND_TOPMOST, 0, 0, 0, 0,  SWP_NOACTIVATE _

                                      Or SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE

End Sub

Başlıksız Formu Taşımak 

(General)(Declaration)

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 WM_NCLBUTTONDOWN = &HA1

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, _

                                                                         X As Single, Y As Single)

         If Button = 1 Then                          ‘ Farenin sol tuşu basılı iken

                  ReleaseCapture

                  r% = SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, 2, 0)

         End If

End Sub

ControlBox İkonunu Değiştirmek 

(General)(Declaration)

Dim y As Integer

        

Private Sub Timer1_Timer()

         y = y + 1

         If y = 4 Then y = 1

         Form1.Icon = Image1(y).Picture                  ‘ 4 adet imaj içerisindeki saklanan

         Picture1.Picture = Image1(y).Picture            ‘ resimler sıra ile kullanılıyor

End Sub

Hafızadaki Tüm Formları Silmek

Public Sub UnloadAllForms()

         Dim Form As Form

         For Each Form In Forms                  ‘ Her bir form için

                  Unload Form

                  Set Form = Nothing                ‘ Form tamamen yok ediliyor

         Next Form

End Sub

Private Sub Form_Unload(Cancel As Integer)

         UnloadAllForms

End Sub

Formun Çeşitli Kısımlarının Rengini Değiştirmek 

(Modul)(General)(Declaration)

Declare Function SetSysColors Lib "user32" (ByVal nChanges As Long, _

                                      lpSysColor As Long, lpColorValues As Long) As Long

Public Const COLOR_SCROLLBAR = 0                   ' ScrollBar

Public Const COLOR_BACKGROUND = 1                ' Masaüstü

Public Const COLOR_ACTIVECAPTION = 2                        ' Aktif pencere adı

Public Const COLOR_INACTIVECAPTION = 3                     ' İnaktif pencere adı

Public Const COLOR_MENU = 4                             ' Menü

Public Const COLOR_WINDOW = 5                        ' Windows arka plan

Public Const COLOR_WINDOWFRAME = 6                          ' Pencere çerçevesi

Public Const COLOR_MENUTEXT = 7                      ' 3D koyu gölge

Public Const COLOR_CAPTIONTEXT = 9                            ' Pencere başlığı

Public Const COLOR_ACTIVEBORDER = 10                        ' Aktif pencere sınırları

Public Const COLOR_INACTIVEBORDER = 11                    ' İnaktif pencere sınırları

Public Const COLOR_APPWORKSPACE = 12                       ' MDI desktop arka plan

Public Const COLOR_HIGHLIGHT = 13                               ' Seçili alan arka plan

Public Const COLOR_HIGHLIGHTTEXT = 14                       ' Seçili menü

Public Const COLOR_BTNFACE = 15 ' Button                      ' Buton

Public Const COLOR_BTNSHADOW = 16                ' 3D buton gölgesi

Public Const COLOR_GRAYTEXT = 17                    ' Gri text

Public Const COLOR_BTNTEXT = 18                      ' Button başlığı

Public Const COLOR_INACTIVECAPTIONTEXT = 19            ' İnaktif pencere

Public Const COLOR_BTNHIGHLIGHT = 20                         ' Buton 3D işarretleme

Private Sub Command1_Click()

deger = SetSysColors(1, COLOR_ACTIVECAPTION, RGB(0,155,122))         ‘ Başlık çubuğu

deger = SetSysColors(1, COLOR_WINDOWFRAME, RGB(0,155,122))           ‘ Çerçeve

End Sub

Form Boyunu Uzatıp Kısalatmak 

Private Sub FormBoyu(ref As Form, taraf As Boolean, aralık As Integer)

         Dim Olcu

         If taraf = False Then

                  Olcu = ref.Height + aralık

                  If aralık < 0 Then Exit Sub

                  Do

                           ref.Height = ref.Height + 1

                           DoEvents

                  Loop Until ref.Height >= Olcu

         End If

         If taraf = True Then

                  Olcu = ref.Height - aralık

                  If Olcu <= 0 Then Exit Sub

                  If aralık < 0 Then Exit Sub

                  Do

                           ref.Height = ref.Height - 1

                           DoEvents

                  Loop Until ref.Height <= Olcu

         End If

End Sub

Private Sub Command1_Click()

         ‘ True – Yukarı doğru kısalır

         ‘ False - Aşağı doğru uzar

         Call FormBoyu(Me, True, 100)                    

End Sub

Yuvarlak Form Oluşturmak 

(General)(Declaration)

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 Sub Form_Load()

         'En ve boy değerleri değiştirilerek eliptik formlar oluşturulabilir

         Dim ref&, i&

         Dim en&, boy&

         en& = Me.Width / Screen.TwipsPerPixelX

         boy& = Me.Height / Screen.TwipsPerPixelY

         ref& = CreateEllipticRgn(0, 0, en&, boy&)

         i& = SetWindowRgn(Me.hWnd, ref&, True)

End Sub

 

 

Şeffaf Form Yapmak 

(Modul)(General)(Declaration)

Option Explicit

Public Declare Function BitBlt Lib "gdi32" (ByVal hDCDest As Long, _

         ByVal XDest As Long, ByVal YDest As Long, _

         ByVal nWidth As Long, ByVal nHeight As Long, _

         ByVal hDCSrc As Long, ByVal XSrc As Long, ByVal YSrc As Long, _

         ByVal dwRop As Long) As Long

Public Const SRCCOPY = &HCC0020

Public Declare Function GetDesktopWindow Lib "user32" () As Long

Public Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long

Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, _

         ByVal hdc As Long) As Long

Dim hwnddesk As Long

Dim hdcdesk As Long

Public Sub SeffafYap (FTBP As Form)

         FTBP.AutoRedraw = True

         hwnddesk = GetDesktopWindow()

         hdcdesk = GetWindowDC(hwnddesk)

         Call BitBlt(FTBP.hdc, 0, 0, _

                  FTBP.Width / Screen.TwipsPerPixelX, _

                  FTBP.Height / Screen.TwipsPerPixelY, hdcdesk, _

                  FTBP.Left / Screen.TwipsPerPixelX, _

                  FTBP.Top / Screen.TwipsPerPixelY, SRCCOPY)

         Call ReleaseDC(hwnddesk, hdcdesk)

End Sub

Private Sub Form_Load()

         SeffafYap Me                                              ‘ Form başlıksız olacak

End Sub

Form Zeminini Karartmak 

Sub kararma(ref As Form)

         For renk = 255 To 0 Step –1                       ‘ 255 ‘den başlayarak  birer birer azalıyor

                  DoEvents                           

                  ref.BackColor = RGB(renk, renk, renk)

         Next renk

End Sub

Private Sub Command1_Click()

         kararma Me

End Sub

Form Başlığını Yakıp Söndürmek 

(General)(Declaration)

Private Declare Function FlashWindow Lib "user32" (ByVal hwnd As Long, _

                  ByVal bInvert As Long) As Long

‘ Timer1.Interval = 1000

Private Sub Timer1_Timer()                     

         deger = FlashWindow(Me.hwnd, 1)

End Sub

Private Sub Command1_Click()

         ' İşlemi başlatır

         Timer1.Enabled = True                   

End Sub

Private Sub Command2_Click()

         ' İşlemi durduur

         Timer1.Enabled = False                  

End Sub

Form Üzerinde Renk Geçişi 

Private Sub RenkGecisi(Ref As Form)

         Dim intLoop As Integer

         Ref.DrawStyle = vbInsideSolid

         Ref.DrawMode = vbCopyPen

         Ref.ScaleMode = vbPixels

         Ref.DrawWidth = 2

         Ref.ScaleHeight = 256

         For intLoop = 0 To 255

         Ref.Line (0, intLoop)-(Screen.Width, intLoop - 1), RGB(255, 0, 255 - intLoop), B

         Next intLoop

End Sub

Private Sub Form_Activate()

         RenkGecisi Me

End Sub

Form’a ScrollBar Eklemek 

(General)(Declaration)

Private Declare Function ShowScrollBar Lib "user32" (ByVal hwnd As Long, _

         ByVal wBar As Long, ByVal bShow As Long) As Long

Private Const SB_HORZ = 0

Private Const SB_VERT = 1

Private Const SB_BOTH = 3

Private Sub Form_Load()

         ShowScrollBar Me.hwnd, SB_BOTH, True

End Sub

Etkileşimsiz Form Yapmak 

(General)(Declaration)

Private Type POINTAPI

    X As Long

    Y As Long

End Type

Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long

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

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Dim Pt As POINTAPI

Private Sub Form_Load()

         SetCapture Me.hwnd

End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, _

                                                              X As Single, Y As Single)

         ReleaseCapture

         SetCapture Me.hwnd

End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _

                                                              X As Single, Y As Single)

         GetCursorPos Pt

         Me.CurrentX = 0

         Me.CurrentY = 0

         Me.Cls

         Me.Print "Fare Kooordinatları : "

        Me.Print "X:" + Str$(Pt.X) + " Y:" + Str$(Pt.Y)

         Me.Print " (Çıkış - ALT-F4)"

         SetCapture Me.hwnd

End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, _

                                                               X As Single, Y As Single)

         ReleaseCapture

         SetCapture Me.hwnd

End Sub

Form Close Butonunu İptal etmek 

Dim bClose As Boolean

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

         If bClose = False Then Cancel = True

End Sub

Form’u Küçülterek Kapatma 

(General)(Declaration)

Const AW_HOR_POSITIVE = &H1             ' Soldan sağa

Const AW_HOR_NEGATIVE = &H2                         ' Sağdan sola

Const AW_VER_POSITIVE = &H4                          ' Yukarıdan aşağıya

Const AW_VER_NEGATIVE = &H8                         ' Aşağıdan yukarıya

Const AW_CENTER = &H10                       ' Merkeze

Const AW_HIDE = &H10000                      ' Sakla

Private Declare Function AnimateWindow Lib "user32" (ByVal hwnd As Long, _

                           ByVal dwTime As Long, ByVal dwFlags As Long) As Boolean

Private Sub Form_Load()

         Me.AutoRedraw = True

         Me.Print "Unload me"

End Sub

Private Sub Form_Unload(Cancel As Integer)

         AnimateWindow Me.hwnd, 200, AW_CENTER Or AW_HIDE

         Set Form1 = Nothing

End Sub

Form Başlığını Harf Harf yazdırmak

Sub HarfHarf(ref As Form)

         baslik = ref.Caption                        ‘ Form başlığı alınıyor

         ref.Caption = ""                              ‘ Form başlığı siliniyor

         ref.Show

         For i = 0 To Len(baslik)                   ‘ Başlık uzunluğu kadar tekrarlanıyor

                  If i = 0 Then

                           ref.Caption = ""

                           current = Timer

                           Do While Timer - current < 0.1

                                      DoEvents

                           Loop

                           GoTo Son

                           Else

                  End If

                  ref.Caption = Left(baslik, i)     ‘ Başlığın soldan i kadarı seçiliyor

                  current = Timer

                  Do While Timer - current < 0.05

                           DoEvents                     ‘ Diğer programların çalışabilmesine

                  Loop                                     ‘ olanak tanıyor

         Son:

         Next i

End Sub

Private Sub Command1_Click()

         HarfHarf Me

End Sub