ListBbox ve ComboBox Satır Kaydırma

Listbox ve Combobox Satır Kaydırma isimli kodları kullanarak, her iki nesnede satır kaydırma işlemi yapma işlemini gerçekleştirebilirsiniz.

XD Destek İste
Option Explicit

Private Sub UserForm_Initialize()
    Dim lCounter As Long
    For lCounter = 1 To 1000
    Lst1.AddItem lCounter
    Lst2.AddItem lCounter
    ComboBox1.AddItem lCounter
    ComboBox2.AddItem lCounter
    Next lCounter
    HookWheel Me, Me.Width, Me.Height, 1
End Sub

Private Sub UserForm_Terminate()
    UnHookWheel
End Sub

Option Explicit
Option Private Module

Private Declare Function CallWindowProc Lib "user32.dll" Alias _
"CallWindowProcA" ( _
ByVal lpPrevWndFunc As Long, _
ByVal hWnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long

Private Declare Function SetWindowLong Lib "user32.dll" Alias _
"SetWindowLongA" ( _
ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare Function FindWindowA Lib "user32" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long

Private Declare Function GetWindowRect Lib "user32" ( _
ByVal hWnd As Long, lpRect As typeRect) As Long
Private Type typeRect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private dXFactor As Double
Private dYFactor As Double
Private lCaptionHeight As Long
Private Const GWL_WNDPROC = -4
Private Const WM_MOUSEWHEEL = &H20A
Private Const SM_MOUSEWHEELPRESENT = 75
Private lLines As Long
Private hForm As Long
Public lPrevWndProc As Long
Private lX As Long
Private lY As Long
Private bUp As Boolean
Private frmContainer As msForms.UserForm

Private Function WindowProc( _
ByVal lWnd As Long, _
ByVal lMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
If lMsg = WM_MOUSEWHEEL Then
lX = lParam And 65535
lY = lParam \ 65535
bUp = (wParam > 0)
WheelHandler bUp
End If
If lMsg <> WM_MOUSEWHEEL Then
WindowProc = CallWindowProc(lPrevWndProc, lWnd, lMsg, wParam, lParam)
End If
End Function

Public Sub HookWheel(ByVal frmName As msForms.UserForm, dWidth As Double, _
dHeight As Double, ByVal lLinesToScroll As Long)
If WheelPresent Then
Set frmContainer = frmName
hForm = GetFormHandle(frmName)
GetScreenFactors hForm, dWidth, dHeight
lLines = lLinesToScroll
lPrevWndProc = SetWindowLong(hForm, GWL_WNDPROC, AddressOf WindowProc)
End If
End Sub

Public Sub UnHookWheel()
Call SetWindowLong(hForm, GWL_WNDPROC, lPrevWndProc)
End Sub

Private Function GetFormHandle(ByVal frmName As msForms.UserForm, _
Optional bByClass As Boolean = True) As Long
Dim strClassName As String
Dim strCaption As String
strClassName = IIf(Val(Application.Version) > 8, "ThunderDFrame", _
"ThunderXFrame") & vbNullChar
strCaption = vbNullString
GetFormHandle = FindWindowA(strClassName, strCaption)
End Function

Public Sub GetScreenFactors(lHwnd As Long, _
dWidth As Double, _
dHeight As Double)
Dim uRect As typeRect
GetWindowRect lHwnd, uRect
dXFactor = dWidth / (uRect.Right - uRect.Left)
dYFactor = dHeight / (uRect.Bottom - uRect.Top)
lCaptionHeight = dHeight - frmContainer.InsideHeight
End Sub

Private Function WheelPresent() As Boolean
If GetSystemMetrics(SM_MOUSEWHEELPRESENT) Then
WheelPresent = True
ElseIf FindWindowA("MouseZ", "Magellan MSWHEEL") <> 0 Then
WheelPresent = True
End If
End Function

Public Sub WheelHandler(bUp As Boolean)
Dim ctlFocus As msForms.Control
Dim ctlName As msForms.Control
Dim lTopIndex As Long
Dim bMultiPage As Boolean
Dim lPage As Long
Dim lMove As Long
If Not IsOverForm Then Exit Sub
Set ctlFocus = frmContainer.ActiveControl
If TypeOf ctlFocus Is msForms.MultiPage Then
bMultiPage = True
lPage = ctlFocus.Value
Set ctlFocus = ctlFocus.SelectedItem.ActiveControl
End If
lX = lX * dXFactor
lY = lY * dYFactor
lY = lY - lCaptionHeight
If Not (TypeOf ctlFocus Is msForms.CommandButton Or _
TypeOf ctlFocus Is msForms.TextBox) Then
End If
For Each ctlName In frmContainer.Controls
With ctlName
On Error Resume Next
If TypeOf ctlName Is msForms.ListBox Or TypeOf ctlName Is msForms.ComboBox Or TypeOf ctlName Is msForms.TextBox Then
If bMultiPage = True Then
If lPage <> .Parent.Index Then GoTo SkipControl
End If
If lX > .Left Then
If lX < .Left + .Width Then
If lY > .Top Then
If lY < .Top + .Height Then
If .ListCount = 0 Then Exit Sub
lMove = IIf(bUp, -lLines, lLines)
lTopIndex = .ListIndex + lMove
If lTopIndex < 0 Then
lTopIndex = 0
ElseIf lTopIndex > .ListCount - (.Height / 10) + 2 Then
lTopIndex = .ListIndex
End If
If lTopIndex < 0 Then lTopIndex = 0
.ListIndex = lTopIndex
Exit Sub
End If
End If
End If
End If
End If
End With
SkipControl:
Next ctlName
End Sub

Public Function IsOverForm() As Boolean
Dim uRect As typeRect
GetWindowRect hForm, uRect
    With uRect
        If lX >= .Left Then
            If lX <= .Right Then
                If lY >= .Top Then
                    If lY <= .Bottom Then
                        IsOverForm = True
                        lX = lX - .Left
                        lY = lY - .Top
                    End If
                End If
            End If
        End If
    End With
End Function

Gerekli Adımlar

Kodu çalıştırmanız için aşağıdaki adımları yerine getirmeniz gerekir.

  1. Microsoft Visual Basic for Applications penceresini (Alt + F11) açın.
  2. Project - VBAProject alanının, ekranın sol tarafında görüldüğünden emin olun. Görünmüyorsa, Ctrl + R kısayolu ile hızlıca açın.
  3. Araç çubuklarından Insert -> UserForm yazısına tıklayın.
  4. Solunda klasör simgesi olan Forms yazısının başındaki + simgesine tıklayın.
  5. Alt kısma eklenecek olan UserForm(1) yazısına çift tıklayın.
  6. Üstteki kodu yapıştırın.

Kod Açıklaması

Bu kod çalıştırmak için bir UserFom nesnesi üzerinde ListBox ve ComboBox nesnesi eklemeniz gerekir.

Etiketler

50 Farklı Hazır Makro (VBA) Kodu
Sayılara Yeni Bir Sayı Ekleme
İki Sütundaki Değerleri Karşılaştırıp Ayrıştırma
Dolar Okutma Makrosu
Makro Etkinletirilmezse Sayfalar Gizlenir
Checkbox ile Exceli Kapatıp Açmak
Çalışma Sayfaları için Yakınlaştırma Yüzdesini Ayarlama
Makrolar İşlem Yaparken Ekranın Kilitlenmesi
Tekrar Eden Verileri Farklı Sütunda Yazma
Çalışma Kitabındaki Tüm Pivot Tabloları Yenileme
Makro Etkinleştirilmeden Sayfalar Görüntülenmesin
Aktif Hücrenin Üstüne Satır Ekleme
A Sütunundaki Verileri C Sütununda Sıralama
Tüm Çalışma Sayfalarını Tek Adımda Koruma
Alarmlı Saat Ekleme Kodu
Seçili Hücrenin Sütun Harfini Bulma
Tek Satırı Kes Kopyala ve Yapıştır
Çalışma Kitabının Kaç Kez Açıldığını Öğrenme
Tekrarlayan Verileri Vurgulama
Sayfadaki Ad Tanımlamaları Silme
İçindekiler Tablosu Oluşturma
Tüm Boş Çalışma Sayfalarını Silme
Özet Tablo Aralığını Otomatik Güncelleştirme
Bir Aralıktaki Maksimum Değeri Renklendirme
UserForm Üzerinde Dört İşlem
Hücre Aralığını Kes Kopyala ve Yapıştır
Yanıp Sönme Efekti Verme Kodu
Sayfadaki Grafikleri Yeniden Boyutlandırma
TextBox Nesnelerinin Arasında Boşluk Bırakma
Hücrenin Arka Plan Rengini Değiştirme
Birden Çok Çalışma Sayfası Ekleme
Açılışta UserForm Nesnesinin Otomatik Gösterilmesi
Hatalı Hücreleri Renklendirme
Açık Olan Tüm Excel Sayfalarını Kayıt Ederek Kapatma
Seri Numaralarını Ekleme
Tüm Satırda İşlem Yapan Döngü
Metnin İçinden TC Kimlik Numarasını Ayırma
Excel Satır Seçme Kodu
Program Başlangıcı Kodları
Makro Çalışırken İmlecin Hareket Etmemesini Sağlama
R1C1 Referans Stilini Etkinleştirme
Excel Alarm Kurma
Satırları Otomatik Sığdır
Kopyala ve Özel Yapıştır
Belirli Bir Metne Sahip Hücreleri Vurgulama
Excel ile Demo Yapma Makrosu
Excel Açılırken Otomatik İşlem Yaptırma
MsgBox ile Uyarı Çıkarma Kodu
Makro ile Biçimleri Temizleme
Her Bir Sütundaki Maksimum Değeri Bulma
Grafik Türünü Değiştirme
Üstteki alanda, Google Reklamları yerine sizin reklamınızın yayınlanmasını ister misiniz?
Reklam vermek istiyorum

Daha önce yorum yapılmamış!

Excel sayfanızda yer alan 0 değerlerini gizlemek için, 0 değerlerinizin olduğu alanı seçip, sağ tıkladıktan sonra; Hücre Biçimlendir -> Sayı sekmesi -> İsteğe Uyarlanmış kısmına tıklayıp, Tür kısmına: 0;-0;;@ yazmanız yeterli olacaktır.
Yükleniyor...