Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

10 Haziran 2006 Cumartesi

TreeView Control


'UserForm1

'A) Registre Reference List
    'Name: VBA, Description: Visual Basic For Applications, Full Path: C:\PROGRA~2\COMMON~1\MICROS~1\VBA\VBA7\VBE7.DLL
    'Name: Excel, Description: Microsoft Excel 14.0 Object Library, Full Path: C:\Program Files (x86)\Microsoft Office\Office14\EXCEL.EXE
    'Name: stdole, Description: OLE Automation, Full Path: C:\Windows\SysWOW64\stdole2.tlb
    'Name: Office, Description: Microsoft Office 14.0 Object Library, Full Path: C:\Program Files (x86)\Common Files\Microsoft Shared\OFFICE14\MSO.DLL
    'Name: MSForms, Description: Microsoft Forms 2.0 Object Library, Full Path: C:\Windows\SysWOW64\FM20.DLL
    'Name: MSComctlLib, Description: Microsoft Windows Common Controls 6.0 (SP6), Full Path: C:\Windows\SysWow64\MSCOMCTL.OCX
'B) Additional Tools on UserForm1
    'ImageList1
    'Image1 , Label1, Label2
    'TreeView1
    'Label3 , Label4, Label5, Label6, Label7
    'TextBox1 , TextBox2, TextBox3, TextBox4
    'ComboBox1 , CommandButton1
'C) ImageList1 Custom
    'General; 16 * 16, UseMaskColor is checked
    'Images; To select images to be used in the nodes of TreeView1 "InsertPicture" use the button.

Option Explicit
Private i As Long, j As Long, k As Long
Private hNode As Variant
Private hParent As Variant
Private hMatch() As Variant
Private hObservation As Variant
Private hRecord As Variant
Private hLooked As Variant
Private hSlide As node
Private hCurrent As Boolean
Private hNodeList(1 To 1, 1 To 4)
Private hRow As Range
Private Sub UserForm_Initialize()
    On Error Resume Next
    Me.Caption = "[PBİD®] Treeview Control..."
    Call Ekran_Kur
    Call Sayfa_Kur
    Call Make_TreeView
End Sub
Private Sub TreeView1_NodeClick(ByVal node As MSComctlLib.node)

    On Error Resume Next
    TextBox1.Text = node.Text
    Call Read_Node_Data(node.Text)
    ComboBox1.Value = hNodeList(1, 1)
    TextBox2.Text = hNodeList(1, 2)
    TextBox3.Text = hNodeList(1, 3)
    TextBox4.Text = hNodeList(1, 4)
End Sub
Private Sub CommandButton1_Click()

    On Error GoTo Hata
    If (TextBox1.Value <> "") And (ComboBox1.Value <> "") Then
        Set hRow = Sheets(1).Columns(1).Find(TextBox1.Text, lookat:=xlWhole)
        If hRow Is Nothing Then
        Else
            hRow.Offset(, 1) = ComboBox1.Value
            'Call Resimlendir
            Call Make_TreeView
        End If
        With TreeView1.Nodes(TextBox1.Text)
            .Selected = True
            .EnsureVisible
        End With
    End If
Hata:
End Sub
Sub Make_TreeView() 'Ağaç Kur

    On Error Resume Next
    i = 0
    j = 0
    k = 0
    ComboBox1.Clear
    TreeView1.Nodes.Clear
    With Sheets("Veriler").Range(Sheets("Veriler").[A2], Sheets("Veriler").[A65536].End(xlUp))
        hNode = .Value
        hParent = .Offset(, 1).Value
    End With
    ReDim hMatch(1 To UBound(hNode), 1 To 1)
    For Each hRecord In hParent
        i = i + 1
        hLooked = Application.Match(hRecord, hNode, 0)
        If IsError(hLooked) Then
            hMatch(i, 1) = hNode(i, 1)
        Else
            j = 3
            ReDim Preserve hMatch(1 To UBound(hMatch), 1 To j)
            hMatch(i, 1) = hNode(i, 1)
            hMatch(i, 2) = hRecord
            hMatch(i, 3) = hParent(hLooked, 1)
            Do
                hLooked = Application.Match(hParent(hLooked, 1), hNode, 0)
                If IsError(hLooked) Then Exit Do
                If hParent(hLooked, 1) = "" Then Exit Do
                j = j + 1
                ReDim Preserve hMatch(1 To UBound(hMatch), 1 To j)
                hMatch(i, j) = hParent(hLooked, 1)
            Loop
        End If
    Next hRecord
    hObservation = Make_Matching(hMatch)
    For i = 1 To UBound(hObservation)
        For j = 1 To UBound(hObservation, 2)
            If Not IsEmpty(hObservation(i, j)) Then
                With TreeView1
                    hCurrent = False
                    For Each hRecord In .Nodes
                        If hRecord = hObservation(i, j) Then hCurrent = True
                    Next hRecord
                    If Not hCurrent Then
                        If j = 1 Then
                            'Image & SelectedImage; nothing...
                            Set hSlide = .Nodes.Add(, , hObservation(i, j), hObservation(i, j))
                            'Image & SelectedImage; ImageList1 \ ListImages \ Index...
                            'Set hSlide = .Nodes.Add(, , hObservation(i, j), hObservation(i, j), 2, 3)
                            'Image & SelectedImage; ImageList1 \ ListImages \ Key...
                            'Set hSlide = .Nodes.Add(, , hObservation(i, j), hObservation(i, j), "Resim2", "Resim3")

                        Else
                            'Image & SelectedImage; nothing...
                            Set hSlide = .Nodes.Add(hObservation(i, j - 1), tvwChild, hObservation(i, j), hObservation(i, j))
                            'Image & SelectedImage; ImageList1 \ ListImages \ Index...
                            'Set hSlide = .Nodes.Add(hObservation(i, j - 1), tvwChild, hObservation(i, j), hObservation(i, j), 2, 3)
                            'Image & SelectedImage; ImageList1 \ ListImages \ Key...
                            'Set hSlide = .Nodes.Add(hObservation(i, j - 1), tvwChild, hObservation(i, j), hObservation(i, j), "Resim2", "Resim3")

                        End If
                        hSlide.Expanded = True
                    End If
                End With
            End If
        Next j
    Next i
    ComboBox1.AddItem ""
    For Each hSlide In TreeView1.Nodes
        If hSlide.Children > 0 Then hSlide.ForeColor = vbBlack: hSlide.Bold = True
        If hSlide.Children = 0 Then hSlide.ForeColor = vbBlue: hSlide.Bold = False
        ComboBox1.AddItem hSlide.Text
    Next hSlide
End Sub
Function Make_Matching(ByVal Bellek As Variant) As Variant 'Eşleştir

    On Error GoTo Hata
    ReDim hObservation(LBound(Bellek) To UBound(Bellek), LBound(Bellek, 2) To UBound(Bellek, 2))
    For i = 1 To UBound(Bellek)
        k = 0
        For j = UBound(Bellek, 2) To 1 Step -1
            If Not IsEmpty(Bellek(i, j)) Then
                k = k + 1
                hObservation(i, k) = Bellek(i, j)
            End If
        Next j
    Next i
    Make_Matching = hObservation
Hata:
End Function
Function Read_Node_Data(DalAdı) As String 'Dal Bilgisi Oku

    On Error GoTo Hata
    Set hRow = Sheets(1).Columns(1).Find(DalAdı, lookat:=xlWhole)
    If hRow Is Nothing Then
        hNodeList(1, 1) = "None"
        hNodeList(1, 2) = "None"
        hNodeList(1, 3) = "None"
        hNodeList(1, 4) = "None"
    Else
        hNodeList(1, 1) = hRow.Offset(, 1).Value
        hNodeList(1, 2) = hRow.Offset(, 2).Value
        hNodeList(1, 3) = hRow.Offset(, 3).Value
        hNodeList(1, 4) = hRow.Offset(, 4).Value
    End If
Hata:
End Function
Private Sub Ekran_Kur()

    On Error Resume Next
    Dim Resim
    Set Resim = ImageList1.ListImages
    With Me
        .BackColor = VBA.RGB(242, 242, 242)
        .Width = 396
        .Height = 268
        With Image1
            .Left = 6
            .Top = 6
            .Height = 24
            .Width = 24
            .BorderColor = vbBlue
            .Picture = Resim(1).Picture
            .PictureAlignment = fmPictureAlignmentCenter
            .PictureSizeMode = fmPictureSizeModeClip
            .PictureTiling = False
        End With
        With Label1
            .Left = 36
            .Top = 6
            .Height = 12
            .Width = Me.Width
            .Caption = " Mustafa ULUSARAÇ"
            .ForeColor = vbBlue
            .Font.Bold = True
            .SpecialEffect = fmSpecialEffectFlat
            .BorderStyle = fmBorderStyleNone
            .TextAlign = fmTextAlignLeft
        End With
        With Label2
            .Left = 36
            .Top = 18
            .Height = 12
            .Width = Me.Width
            .Caption = "
01ulusarac@superonline.com"
            .ForeColor = vbBlue
            .Font.Bold = True
            .SpecialEffect = fmSpecialEffectFlat
            .BorderStyle = fmBorderStyleNone
            .TextAlign = fmTextAlignLeft
        End With
        With Label3
            .Left = 6
            .Top = 36
            .Height = 30
            .Width = 192
            .Caption = "Bilgi Ağacı [TreeView]"
            .ForeColor = VBA.RGB(120, 120, 120)
            .Font = "Arial Narrow"
            .Font.Bold = True
            .Font.Size = 10
            .SpecialEffect = fmSpecialEffectEtched
            .BorderStyle = fmBorderStyleNone
            .TextAlign = fmTextAlignCenter
        End With
        With TreeView1
            .Left = 6
            .Top = 72
            .Height = 168
            .Width = 192
            .BorderStyle = ccFixedSingle
            .Appearance = ccFlat
            Set .ImageList = ImageList1
            .Indentation = 14
            .LabelEdit = tvwManual
            .HideSelection = False
            .FullRowSelect = False
            .LineStyle = tvwRootLines
        End With
        With Label4
            .Left = 204
            .Top = 36
            .Height = 30
            .Width = 180
            .Caption = "Düğüm İlişkisi ve Bilgiler [Relationship Between The Node & Information]"
            .ForeColor = VBA.RGB(120, 120, 120)
            .Font = "Arial Narrow"
            .Font.Bold = True
            .Font.Size = 10
            .SpecialEffect = fmSpecialEffectEtched
            .BorderStyle = fmBorderStyleNone
            .TextAlign = fmTextAlignCenter
        End With
        With Label5
            .Left = 204
            .Top = 72
            .Height = 18
            .Width = 96
            .Caption = " Dal [Node]"
            .ForeColor = VBA.RGB(120, 120, 120)
            .Font = "Arial Narrow"
            .Font.Bold = True
            .Font.Size = 10
            .SpecialEffect = fmSpecialEffectEtched
            .BorderStyle = fmBorderStyleNone
            .TextAlign = Left
        End With
        With TextBox1
            .Left = 306
            .Top = 72
            .Height = 18
            .Width = 78
            .SpecialEffect = fmSpecialEffectEtched
            .ForeColor = vbBlue
            .Font = "Arial Narrow"
            .Font.Bold = False
            .Font.Size = 10
        End With
        With Label6
            .Left = 204
            .Top = 96
            .Height = 18
            .Width = 96
            .Caption = " Kök Dal [Parent]"
            .ForeColor = VBA.RGB(120, 120, 120)
            .Font = "Arial Narrow"
            .Font.Bold = True
            .Font.Size = 10
            .SpecialEffect = fmSpecialEffectEtched
            .BorderStyle = fmBorderStyleNone
            .TextAlign = Left
        End With
        With ComboBox1
            .Left = 306
            .Top = 96
            .Height = 18
            .Width = 42
            .ForeColor = VBA.RGB(120, 120, 120)
            .Font = "Arial Narrow"
            .Font.Bold = True
            .Font.Size = 10
            .SpecialEffect = fmSpecialEffectEtched
            .BorderStyle = fmBorderStyleNone
            .TextAlign = Left
            .ListWidth = 42
            .ColumnWidths = 30
        End With
        With CommandButton1
            .Left = 348
            .Top = 96
            .Height = 18
            .Width = 36
            .ForeColor = vbRed
            .Font = "Arial Narrow"
            .Font.Bold = True
            .Font.Size = 10
            .Caption = "Move"
        End With
        With Label7
            .Left = 204
            .Top = 120
            .Height = 18
            .Width = 96
            .Caption = " Veri1 [Data1]"
            .ForeColor = VBA.RGB(120, 120, 120)
            .Font = "Arial Narrow"
            .Font.Bold = True
            .Font.Size = 10
            .SpecialEffect = fmSpecialEffectEtched
            .BorderStyle = fmBorderStyleNone
            .TextAlign = Left
        End With
        With TextBox2
            .Left = 306
            .Top = 120
            .Height = 18
            .Width = 78
            .SpecialEffect = fmSpecialEffectEtched
            .ForeColor = vbBlue
            .Font = "Arial Narrow"
            .Font.Bold = False
            .Font.Size = 10
        End With
        With Label8
            .Left = 204
            .Top = 144
            .Height = 18
            .Width = 96
            .Caption = " Veri2 [Data2]"
            .ForeColor = VBA.RGB(120, 120, 120)
            .Font = "Arial Narrow"
            .Font.Bold = True
            .Font.Size = 10
            .SpecialEffect = fmSpecialEffectEtched
            .BorderStyle = fmBorderStyleNone
            .TextAlign = Left
        End With
        With TextBox3
            .Left = 306
            .Top = 144
            .Height = 18
            .Width = 78
            .SpecialEffect = fmSpecialEffectEtched
            .ForeColor = vbBlue
            .Font = "Arial Narrow"
            .Font.Bold = False
            .Font.Size = 10
        End With
        With Label9
            .Left = 204
            .Top = 168
            .Height = 18
            .Width = 96
            .Caption = " Veri3 [Data3]"
            .ForeColor = VBA.RGB(120, 120, 120)
            .Font = "Arial Narrow"
            .Font.Bold = True
            .Font.Size = 10
            .SpecialEffect = fmSpecialEffectEtched
            .BorderStyle = fmBorderStyleNone
            .TextAlign = Left
        End With
        With TextBox4
            .Left = 306
            .Top = 168
            .Height = 18
            .Width = 78
            .SpecialEffect = fmSpecialEffectEtched
            .ForeColor = vbBlue
            .Font = "Arial Narrow"
            .Font.Bold = False
            .Font.Size = 10
        End With
    End With
End Sub
Sub Sayfa_Kur()

    On Error Resume Next
    Dim Eleman As Worksheet
    For Each Eleman In ThisWorkbook.Worksheets
        If Eleman.Name = "Veriler" Then
            Sheets("Veriler").Select
            GoTo Devam
        End If
    Next Eleman
    ThisWorkbook.Worksheets.Add Sheets(1)
    ActiveSheet.Name = "Veriler"
Devam:
    Cells.Select
    Selection.Delete Shift:=xlUp
    Range("A1").FormulaR1C1 = "Node"
    Range("A2").FormulaR1C1 = "C"
    Range("A3").FormulaR1C1 = "B"
    Range("A4").FormulaR1C1 = "A"
    Range("A5").FormulaR1C1 = "D"
    Range("A6").FormulaR1C1 = "F"
    Range("A7").FormulaR1C1 = "G"
    Range("A8").FormulaR1C1 = "E"
    Range("A9").FormulaR1C1 = "H"
    Range("A10").FormulaR1C1 = "I"
    Range("A11").FormulaR1C1 = "J"
    Range("B1").FormulaR1C1 = "Parent"
    Range("B2").FormulaR1C1 = "J"
    Range("B3").FormulaR1C1 = ""
    Range("B4").FormulaR1C1 = "B"
    Range("B5").FormulaR1C1 = ""
    Range("B6").FormulaR1C1 = "D"
    Range("B7").FormulaR1C1 = "D"
    Range("B8").FormulaR1C1 = "A"
    Range("B9").FormulaR1C1 = "I"
    Range("B10").FormulaR1C1 = "F"
    Range("B11").FormulaR1C1 = ""
    Range("C1").FormulaR1C1 = "Data1"
    Range("C2").FormulaR1C1 = "C En"
    Range("C3").FormulaR1C1 = "B En"
    Range("C4").FormulaR1C1 = "A En"
    Range("C5").FormulaR1C1 = "D En"
    Range("C6").FormulaR1C1 = "F En"
    Range("C7").FormulaR1C1 = "G En"
    Range("C8").FormulaR1C1 = "E En"
    Range("C9").FormulaR1C1 = "H En"
    Range("C10").FormulaR1C1 = "I En"
    Range("C11").FormulaR1C1 = "J En"
    Range("D1").FormulaR1C1 = "Data2"
    Range("D2").FormulaR1C1 = "C Boy"
    Range("D3").FormulaR1C1 = "B Boy"
    Range("D4").FormulaR1C1 = "A Boy"
    Range("D5").FormulaR1C1 = "D Boy"
    Range("D6").FormulaR1C1 = "F Boy"
    Range("D7").FormulaR1C1 = "G Boy"
    Range("D8").FormulaR1C1 = "E Boy"
    Range("D9").FormulaR1C1 = "H Boy"
    Range("D10").FormulaR1C1 = "I Boy"
    Range("D11").FormulaR1C1 = "J Boy"
    Range("E1").FormulaR1C1 = "Data3"
    Range("E2").FormulaR1C1 = "C Yükseklik"
    Range("E3").FormulaR1C1 = "B Yükseklik"
    Range("E4").FormulaR1C1 = "A Yükseklik"
    Range("E5").FormulaR1C1 = "D Yükseklik"
    Range("E6").FormulaR1C1 = "F Yükseklik"
    Range("E7").FormulaR1C1 = "G Yükseklik"
    Range("E8").FormulaR1C1 = "E Yükseklik"
    Range("E9").FormulaR1C1 = "H Yükseklik"
    Range("E10").FormulaR1C1 = "I Yükseklik"
    Range("E11").FormulaR1C1 = "J Yükseklik"
    With Range("A1:E1")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .ShrinkToFit = True
        With .Font
            .Name = "Arial Narrow"
            .FontStyle = "Normal"
            .Size = 12
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0.4
            .ThemeFont = xlThemeFontNone
        End With
        With .Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 16711680
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
    End With
    With Range("A2:B11")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .ShrinkToFit = True
    End With
    Columns("A:E").ColumnWidth = 12
    Range("A1").Select
End Sub


'Module1

Sub Form_Open()

    On Error Resume Next
    UserForm1.Show 0
End Sub
'Sub ReferenceList()

'    On Error Resume Next
'    Dim Eleman, No
'    No = 1
'    For Each Eleman In ThisWorkbook.VBProject.References
'        Cells(No, 1) = "Name: "
'        Cells(No, 2) = Eleman.Name
'        Cells(No, 3) = ", Description: "
'        Cells(No, 4) = Eleman.Description
'        Cells(No, 5) = ", Full Path: "
'        Cells(No, 6) = Eleman.FullPath
'        No = No + 1
'    Next Eleman
'End Sub

Hiç yorum yok:

Blog Arşivi

Bu gadget'ta bir hata oluştu

Bu Blogda Ara

Contributor

Contributor
Mustafa ULUSARAÇ İstanbul, TÜRKİYE
free counters
T. C. Central Bank Indicative Exchange Rates
Currency Exchange Rate Widget,Currency Converter Widget
Borsa İstanbul