Birbirine Bagli Listboxlar ile Userform Olusturma

Ustteki resimdeki gibi birbirine bagli listboxlar nasil olusturabiliriz diye inceleyecegiz. Bunu bu ornegin disinda da kullanabililmeniz icin taslak olarak yapip, daha sonra verilerinizi kullanabileceginiz bir makro daha yapacagiz.

Userform ve uzerindeki nesnelere ait kodlar;

Option Explicit

Private mclsParents As CParents
Private mclsActiveParent As CParent
Private mclsActiveChild As CChild

Public Property Set ActiveParent(ByVal clsActiveParent As CParent): Set mclsActiveParent = clsActiveParent: End Property
Public Property Get ActiveParent() As CParent: Set ActiveParent = mclsActiveParent: End Property
Public Property Set ActiveChild(ByVal clsActiveChild As CChild): Set mclsActiveChild = clsActiveChild: End Property
Public Property Get ActiveChild() As CChild: Set ActiveChild = mclsActiveChild: End Property
Public Property Set Parents(ByVal clsParents As CParents): Set mclsParents = clsParents: End Property
Public Property Get Parents() As CParents: Set Parents = mclsParents: End Property

Private Sub FillParents()

    Me.lbxParents.List = Me.Parents.List

    If Me.lbxParents.ListCount > 0 Then
        Me.lbxParents.ListIndex = 0
    End If

End Sub

Private Sub cmdClose_Click()

    Me.Hide

End Sub

Private Sub FillChildren()

    Me.lbxChildren.Clear

    If Not Me.ActiveParent Is Nothing Then
        If Me.ActiveParent.Children.Count > 0 Then
            Me.lbxChildren.List = Me.ActiveParent.Children.List
            Me.lbxChildren.ListIndex = 0
        End If
    End If

End Sub

Private Sub FillGrandchildren()

    Me.lbxGrandchildren.Clear

    If Not Me.ActiveChild Is Nothing Then
        If Me.ActiveChild.Grandchildren.Count > 0 Then
            Me.lbxGrandchildren.List = Me.ActiveChild.Grandchildren.List
            Me.lbxGrandchildren.ListIndex = 0
        End If
    End If

End Sub

Private Sub lbxChildren_Change()

    If Me.lbxChildren.ListIndex >= 0 Then
        Set Me.ActiveChild = Me.ActiveParent.Children.ChildByDescription(Me.lbxChildren.List(Me.lbxChildren.ListIndex))
    Else
        Set Me.ActiveChild = Nothing
    End If

    FillGrandchildren

End Sub

Private Sub lbxParents_Change()

    If Me.lbxParents.ListIndex >= 0 Then
        Set Me.ActiveParent = Me.Parents.ParentByDescription(Me.lbxParents.Value)
    Else
        Set Me.ActiveParent = Nothing
    End If

    FillChildren

End Sub

Public Sub Initialize()

    FillParents

End Sub

Taslak icin olusturulan class moduller;

Option Explicit

Private mlChildID As Long
Private msDescription As String
Private mlParentPtr As Long
Private mclsGrandchildren As CGrandchildren

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (dest As Any, Source As Any, ByVal bytes As Long)

Public Property Let Description(ByVal sDescription As String): msDescription = sDescription: End Property
Public Property Get Description() As String: Description = msDescription: End Property
Public Property Set Grandchildren(ByVal clsGrandchildren As CGrandchildren): Set mclsGrandchildren = clsGrandchildren: End Property
Public Property Get Grandchildren() As CGrandchildren: Set Grandchildren = mclsGrandchildren: End Property
Public Property Let ChildID(ByVal lChildID As Long): mlChildID = lChildID: End Property
Public Property Get ChildID() As Long: ChildID = mlChildID: End Property
Public Property Get Parent() As CChildren: Set Parent = ObjFromPtr(mlParentPtr): End Property
Public Property Set Parent(obj As CChildren): mlParentPtr = ObjPtr(obj): End Property

Private Function ObjFromPtr(ByVal pObj As Long) As Object
    Dim obj As Object
    CopyMemory obj, pObj, 4
    Set ObjFromPtr = obj
    ' manually destroy the temporary object variable
    ' (if you omit this step you'll get a GPF!)
    CopyMemory obj, 0&, 4
End Function

Private Sub Class_Initialize()

    Set mclsGrandchildren = New CGrandchildren

End Sub

Private Sub Class_Terminate()

    Set mclsGrandchildren = Nothing

End Sub
Option Explicit

Private mcolChildren As Collection

Private Sub Class_Initialize()
    Set mcolChildren = New Collection
End Sub

Private Sub Class_Terminate()
    Set mcolChildren = Nothing
End Sub

Public Property Get NewEnum() As IUnknown
    Set NewEnum = mcolChildren.[_NewEnum]
End Property

Public Sub Add(clsChild As CChild)
    If clsChild.ChildID = 0 Then
        clsChild.ChildID = Me.Count + 1
    End If

    Set clsChild.Parent = Me
    mcolChildren.Add clsChild, CStr(clsChild.ChildID)
End Sub

Public Property Get Child(vItem As Variant) As CChild
    Set Child = mcolChildren.Item(vItem)
End Property

Public Property Get Count() As Long
    Count = mcolChildren.Count
End Property

Public Property Get List() As Variant

    Dim clsChild As CChild
    Dim aReturn() As String
    Dim lCnt As Long

    ReDim aReturn(0 To Me.Count - 1)

    For Each clsChild In Me
        aReturn(lCnt) = clsChild.Description
        lCnt = lCnt + 1
    Next clsChild

    List = aReturn

End Property
Public Property Get ChildByDescription(sDescription As String) As CChild

    Dim clsReturn As CChild
    Dim clsChild As CChild

    For Each clsChild In Me
        If clsChild.Description = sDescription Then
            Set clsReturn = clsChild
            Exit For
        End If
    Next clsChild

    Set ChildByDescription = clsReturn

End Property
Option Explicit

Private mlGrandchildID As Long
Private msDescription As String
Private mlParentPtr As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (dest As Any, Source As Any, ByVal bytes As Long)

Public Property Let Description(ByVal sDescription As String): msDescription = sDescription: End Property
Public Property Get Description() As String: Description = msDescription: End Property
Public Property Let GrandchildID(ByVal lGrandchildID As Long): mlGrandchildID = lGrandchildID: End Property
Public Property Get GrandchildID() As Long: GrandchildID = mlGrandchildID: End Property
Public Property Get Parent() As CGrandchildren: Set Parent = ObjFromPtr(mlParentPtr): End Property
Public Property Set Parent(obj As CGrandchildren): mlParentPtr = ObjPtr(obj): End Property

Private Function ObjFromPtr(ByVal pObj As Long) As Object
    Dim obj As Object
    CopyMemory obj, pObj, 4
    Set ObjFromPtr = obj
    ' manually destroy the temporary object variable
    ' (if you omit this step you'll get a GPF!)
    CopyMemory obj, 0&, 4
End Function
Option Explicit

Private mcolGrandchildren As Collection

Private Sub Class_Initialize()
    Set mcolGrandchildren = New Collection
End Sub

Private Sub Class_Terminate()
    Set mcolGrandchildren = Nothing
End Sub

Public Property Get NewEnum() As IUnknown
    Set NewEnum = mcolGrandchildren.[_NewEnum]
End Property

Public Sub Add(clsGrandchild As CGrandchild)
    If clsGrandchild.GrandchildID = 0 Then
        clsGrandchild.GrandchildID = Me.Count + 1
    End If

    Set clsGrandchild.Parent = Me
    mcolGrandchildren.Add clsGrandchild, CStr(clsGrandchild.GrandchildID)
End Sub

Public Property Get Grandchild(vItem As Variant) As CGrandchild
    Set Grandchild = mcolGrandchildren.Item(vItem)
End Property

Public Property Get Count() As Long
    Count = mcolGrandchildren.Count
End Property

Public Property Get List() As Variant

    Dim clsGrandchild As CGrandchild
    Dim aReturn() As String
    Dim lCnt As Long

    ReDim aReturn(0 To Me.Count - 1)

    For Each clsGrandchild In Me
        aReturn(lCnt) = clsGrandchild.Description
        lCnt = lCnt + 1
    Next clsGrandchild

    List = aReturn

End Property

 

Option Explicit

Private mlParentID As Long
Private msDescription As String
Private mlParentPtr As Long
Private mclsChildren As CChildren

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (dest As Any, Source As Any, ByVal bytes As Long)

Public Property Let Description(ByVal sDescription As String): msDescription = sDescription: End Property
Public Property Get Description() As String: Description = msDescription: End Property
Public Property Set Children(ByVal clsChildren As CChildren): Set mclsChildren = clsChildren: End Property
Public Property Get Children() As CChildren: Set Children = mclsChildren: End Property
Public Property Let ParentID(ByVal lParentID As Long): mlParentID = lParentID: End Property
Public Property Get ParentID() As Long: ParentID = mlParentID: End Property
Public Property Get Parent() As CParents: Set Parent = ObjFromPtr(mlParentPtr): End Property
Public Property Set Parent(obj As CParents): mlParentPtr = ObjPtr(obj): End Property

Private Function ObjFromPtr(ByVal pObj As Long) As Object
    Dim obj As Object
    CopyMemory obj, pObj, 4
    Set ObjFromPtr = obj
    ' manually destroy the temporary object variable
    ' (if you omit this step you'll get a GPF!)
    CopyMemory obj, 0&, 4
End Function

Private Sub Class_Initialize()

    Set mclsChildren = New CChildren

End Sub

Private Sub Class_Terminate()

    Set mclsChildren = Nothing

End Sub
Option Explicit

Private mcolParents As Collection

Private Sub Class_Initialize()
    Set mcolParents = New Collection
End Sub

Private Sub Class_Terminate()
    Set mcolParents = Nothing
End Sub

Public Property Get NewEnum() As IUnknown
    Set NewEnum = mcolParents.[_NewEnum]
End Property

Public Sub Add(clsParent As CParent)
    If clsParent.ParentID = 0 Then
        clsParent.ParentID = Me.Count + 1
    End If

    Set clsParent.Parent = Me
    mcolParents.Add clsParent, CStr(clsParent.ParentID)
End Sub

Public Property Get Parent(vItem As Variant) As CParent
    Set Parent = mcolParents.Item(vItem)
End Property

Public Property Get Count() As Long
    Count = mcolParents.Count
End Property

Public Sub FillFromRange(rRng As Range)

    Dim vaValues As Variant
    Dim i As Long
    Dim clsParent As CParent
    Dim clsChild As CChild
    Dim clsGrandchild As CGrandchild

    vaValues = rRng.Value

    For i = LBound(vaValues, 1) To UBound(vaValues, 1)
        Set clsParent = Nothing
        Set clsChild = Nothing
        Set clsGrandchild = Nothing

        If Len(vaValues(i, 2)) = 0 Then
            Set clsParent = New CParent
            clsParent.Description = vaValues(i, 1)
            Me.Add clsParent
        Else
            Set clsParent = Me.ParentByDescription(vaValues(i, 2))
            If clsParent Is Nothing Then
                Set clsChild = Me.ChildByDescription(vaValues(i, 2))
                If Not clsChild Is Nothing Then
                    Set clsGrandchild = New CGrandchild
                    clsGrandchild.Description = vaValues(i, 1)
                    clsChild.Grandchildren.Add clsGrandchild
                End If
            Else
                Set clsChild = New CChild
                clsChild.Description = vaValues(i, 1)
                clsParent.Children.Add clsChild
            End If
        End If
    Next i

End Sub
Public Property Get ParentByDescription(ByVal sDescription As String) As CParent

    Dim clsReturn As CParent
    Dim clsParent As CParent

    For Each clsParent In Me
        If clsParent.Description = sDescription Then
            Set clsReturn = clsParent
            Exit For
        End If
    Next clsParent

    Set ParentByDescription = clsReturn

End Property

Public Property Get ChildByDescription(ByVal sChildDesc As String) As CChild

    Dim clsParent As CParent
    Dim clsChild As CChild
    Dim clsReturn As CChild

    For Each clsParent In Me
        Set clsChild = Nothing
        For Each clsChild In clsParent.Children
            If clsChild.Description = sChildDesc Then
                Set clsReturn = clsChild
                Exit For
            End If
        Next clsChild
    Next clsParent

    Set ChildByDescription = clsReturn

End Property

Public Property Get List() As Variant

    Dim clsParent As CParent
    Dim aReturn() As String
    Dim lCnt As Long

    ReDim aReturn(0 To Me.Count - 1)

    For Each clsParent In Me
        aReturn(lCnt) = clsParent.Description
        lCnt = lCnt + 1
    Next clsParent

    List = aReturn

End Property

son olarak listboxlari doldurmak icin gerekli kodlar;

Private Const msMODULE As String = "MEntryPoints()"

Sub Main()

    Dim clsParents As CParents
    Dim ufRelations As URelations

    Set clsParents = New CParents
    clsParents.FillFromRange Sheet1.Range("A2:B17")

    Set ufRelations = New URelations
    Set ufRelations.Parents = clsParents

    ufRelations.Initialize
    ufRelations.Show

    Unload ufRelations
    Set ufRelations = Nothing

End Sub

Listboxin konusu olan verilerimiz A2:B17 araliginda bulunmakta buradaki verilerimiz listeboxa giris sekliyle bulunacak. hangi verinin ust kusagi varsa B sutununda karsisina listelenecek.

Birbirine Bagli Listboxlar ile Userform Olusturma

 

Yazar: mmustafaaslan

2004 yilindan itibaren ozel bir sirketin finans departmaninda calismaktadir. Kendini excel, visual basic kullaniminda gelistirmis olan yazarimiz; Meslegi geregi SAP konusunda ileri derecede bilgilidir.

Bir Cevap Yazın

E-posta hesabınız yayımlanmayacak. Gerekli alanlar * ile işaretlenmişlerdir


4 + 6 =