TN00008 - Creating Row grouping using the VB6 ActiveGantt Scheduler Component

Need technical support or assistance?
Click Here.
Please remember to read our guidelines first.
You will receive advance information about products and web updates as well as free software and source code that we will soon make available.
Subscribe Now
Once your subscription is activated you will receive instructions on how to leave the list.
Hundreds of free Visual Basic source code snippets, activeX controls, tutorials, tips, projects and articles covering VB.NET and VB6! Great code on topics like MAPI, winsock programming, COM, MTS, XML, graphics, threading, timers, networking, API's and more!
Search the best developer Web sites and hundreds of developer newsgroups... updated every thirty minutes!
TN00008 - Creating Row grouping using the VB6 ActiveGantt Scheduler Component
Applies to:
ActiveGantt Scheduler Component for Visual Basic 6.0
Summary:
From version 2.5.7 onwards it is possible to simulate TreeView behaviour for Row objects, like in the following example:
Child Row objects can be expanded or collapsed:
On a new empty form create an ActiveGantt control named ActiveGanttVBCtl1 and paste the following code


Option Explicit

Private Type POINTTYPE
  x As Long
  y As Long
End Type

Private Const PS_DOT = 2
Private Const PS_SOLID = 0

Private Declare Function SelectObject Lib "GDI32.DLL" (ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, _
ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function Polyline Lib "gdi32" (ByVal hdc As Long, _
lpPoint As POINTTYPE, ByVal nCount As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, _
ByVal crColor As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, _
ByVal x As Long, ByVal y As Long, ByVal lpString As String, _
ByVal nCount As Long) As Long

Private Sub Command1_Click()
    ActiveGanttVBCtl1.RowHeadings.Item(1).Width = 100
    ActiveGanttVBCtl1.FixedColumnWidth = 100
End Sub

Private Sub Form_Load()
        ActiveGanttVBCtl1.RowHeight = 20
        ActiveGanttVBCtl1.RowHeadings.Add ""
        ActiveGanttVBCtl1.Rows.Add "K010", "Row K010", True
        ActiveGanttVBCtl1.Rows.Item("K010").Tag = "-"
        ActiveGanttVBCtl1.Rows.Add "K010010", "Row K010010", True
        ActiveGanttVBCtl1.Rows.Item("K010010").Tag = "-"
        ActiveGanttVBCtl1.Rows.Add "K010010010", "Row K010010010", True
        ActiveGanttVBCtl1.Rows.Add "K010020", "Row K010020", True
        ActiveGanttVBCtl1.Rows.Add "K010030", "Row K010030", True
        ActiveGanttVBCtl1.Rows.Item("K010030").Tag = "-"
        ActiveGanttVBCtl1.Rows.Add "K010030010", "Row K010030010", True
        ActiveGanttVBCtl1.Rows.Add "K010030020", "Row K010030020", True
        ActiveGanttVBCtl1.Rows.Add "K020", "Row K020", True
        ActiveGanttVBCtl1.Rows.Item("K020").Tag = "-"
        ActiveGanttVBCtl1.Rows.Add "K020010", "Row K020010", True
        ActiveGanttVBCtl1.Rows.Add "K020020", "Row K020020", True
        ActiveGanttVBCtl1.Rows.Add "K020030", "Row K020030", True
        ActiveGanttVBCtl1.Rows.Add "K030", "Row K030", True
        ActiveGanttVBCtl1.Rows.Item("K030").Tag = "-"
        ActiveGanttVBCtl1.Rows.Add "K030010", "Row K030010", True
        ActiveGanttVBCtl1.Rows.Add "K030020", "Row K030020", True
        ActiveGanttVBCtl1.Rows.Add "K030030", "Row K030030", True
        ActiveGanttVBCtl1.Rows.Add "K030040", "Row K030040", True
End Sub

Private Function IsSibling(ByVal sMasterKey As String, _
ByVal sKey As String) As Boolean
    Dim sSiblingID As String
    If Len(sMasterKey) = 4 Then
        sSiblingID = "K"
    Else
        sSiblingID = Left(sMasterKey, Len(sMasterKey) - 3)
    End If
    If (Len(sMasterKey) = Len(sKey)) Then
        If (Left(sKey, Len(sSiblingID)) = sSiblingID) Then
            IsSibling = True
        Else
            IsSibling = False
        End If
    Else
        IsSibling = False
    End If
End Function

    Private Function bHasChildren(ByVal Index As Integer) As Boolean
        Dim sMasterKey As String
        Dim sKey As String
        If Index >= ActiveGanttVBCtl1.Rows.Count Then
            bHasChildren = False
            Exit Function
        End If
        sMasterKey = ActiveGanttVBCtl1.Rows.Item(Index).Key
        Index = Index + 1
        sKey = ActiveGanttVBCtl1.Rows.Item(Index).Key
        If Len(sKey) < Len(sMasterKey) Then
            bHasChildren = False
            Exit Function
        End If
        If Left(sKey, Len(sMasterKey)) = sMasterKey Then
            bHasChildren = True
            Exit Function
        End If
    End Function
    
    Private Function bIsChild(ByVal Key As String) As Boolean
        If Len(Key) = 4 Then
            bIsChild = False
        Else
            bIsChild = True
        End If
    End Function
    
    Private Sub HideChildren(ByVal sKey As String)
        Dim i As Integer
        Dim sChildKey As String
        For i = 1 To ActiveGanttVBCtl1.Rows.Count
            sChildKey = ActiveGanttVBCtl1.Rows.Item(i).Key
            If Len(sChildKey) > Len(sKey) Then
                If (Left(sChildKey, Len(sKey)) = sKey) And (Len(sChildKey) > _
                Len(sKey)) Then
                    ActiveGanttVBCtl1.Rows.Item(i).Height = -1
                End If
            End If
        Next i
    End Sub
    
    Private Sub ShowChildren(ByVal sKey As String)
        Dim i As Integer
        Dim sChildKey As String
        For i = 1 To ActiveGanttVBCtl1.Rows.Count
            sChildKey = ActiveGanttVBCtl1.Rows.Item(i).Key
            If Len(sChildKey) > Len(sKey) Then
                If (Left(sChildKey, Len(sKey)) = sKey) And (Len(sChildKey) > _
                Len(sKey)) Then
                    ActiveGanttVBCtl1.Rows.Item(i).Height = 20
                    If ActiveGanttVBCtl1.Rows.Item(i).Tag = "+" Then
                        ActiveGanttVBCtl1.Rows.Item(i).Tag = "-"
                    End If
                End If
            End If
        Next i
    End Sub
    
Private Sub ActiveGanttVBCtl1_RowClick(ByVal Index As Long, ByVal x As Single, _
ByVal y As Single, ByVal Button As Integer)
        Dim sTag As String
        If bHasChildren(Index) = True Then
            sTag = ActiveGanttVBCtl1.Rows.Item(Index).Tag
            If sTag = "+" Then
                ActiveGanttVBCtl1.Rows.Item(Index).Tag = "-"
                ShowChildren (ActiveGanttVBCtl1.Rows.Item(Index).Key)
            ElseIf sTag = "-" Then
                ActiveGanttVBCtl1.Rows.Item(Index).Tag = "+"
                HideChildren (ActiveGanttVBCtl1.Rows.Item(Index).Key)
            End If
            ActiveGanttVBCtl1.redraw
        End If
End Sub

Private Sub ActiveGanttVBCtl1_RowDraw(CustomDraw As Boolean, ByVal Index As Long, _
ByVal lHdc As Long)
        If ActiveGanttVBCtl1.Rows.Item(Index).Height > -1 Then
            CustomDraw = True
            Dim sCaption As String
            Dim sKey As String
            Dim sTag As String
            Dim lTextX As Single
            Dim lTextY As Single
            Dim oFont As New StdFont
            oFont.Name = "Arial"
            oFont.Size = 8
            sCaption = ActiveGanttVBCtl1.Rows.Item(Index).Caption
            sKey = ActiveGanttVBCtl1.Rows.Item(Index).Key
            sTag = ActiveGanttVBCtl1.Rows.Item(Index).Tag
            lTextX = ActiveGanttVBCtl1.RowHeadings.Item(1).Left + (Len(sKey) * 5)
            lTextY = ActiveGanttVBCtl1.Rows.Item(Index).Top + 1
            If bHasChildren(Index) = True Then
                If sTag = "+" Then
                    DrawRectangle lHdc, RGB(0, 0, 0), lTextX - 10, _
                    ActiveGanttVBCtl1.Rows.Item(Index).Top + 3, 8, 8
                    DrawLine lHdc, RGB(0, 0, 0), lTextX - 8, _
                    ActiveGanttVBCtl1.Rows.Item(Index).Top + 7, lTextX - 3, _
                    ActiveGanttVBCtl1.Rows.Item(Index).Top + 7
                    DrawLine lHdc, RGB(0, 0, 0), lTextX - 6, _
                    ActiveGanttVBCtl1.Rows.Item(Index).Top + 5, lTextX - 6, _
                    ActiveGanttVBCtl1.Rows.Item(Index).Top + 10
                ElseIf sTag = "-" Then
                    DrawRectangle lHdc, RGB(0, 0, 0), lTextX - 10, _
                    ActiveGanttVBCtl1.Rows.Item(Index).Top + 3, 8, 8
                    DrawLine lHdc, RGB(0, 0, 0), lTextX - 8, _
                    ActiveGanttVBCtl1.Rows.Item(Index).Top + 7, lTextX - 3, _
                    ActiveGanttVBCtl1.Rows.Item(Index).Top + 7
                End If
            End If
            If bIsChild(sKey) = True And sTag = "" Then
                Dim y As Single
                Dim X1 As Single
                X1 = ActiveGanttVBCtl1.RowHeadings.Item(1).Left + (Len(sKey) * 5)
                y = CSng(ActiveGanttVBCtl1.Rows.Item(Index).Top + _
                ((ActiveGanttVBCtl1.Rows.Item(Index).bottom - _
                ActiveGanttVBCtl1.Rows.Item(Index).Top) / 2))
                DrawLine lHdc, RGB(0, 0, 0), X1, y, X1 - 6, y
            End If
            DrawString sCaption, lHdc, oFont, RGB(0, 0, 0), lTextX + 3, lTextY
        Else
            CustomDraw = False
        End If
End Sub

Private Sub ActiveGanttVBCtl1_FixedColumnDraw(ByVal lHdc As Long)
        Dim i As Integer
        Dim k As Integer
        Dim sMasterKey As String
        Dim sKey As String
        Dim lTextX As Single
        Dim lTop As Single
        Dim lBottom As Single
        For i = 1 To ActiveGanttVBCtl1.Rows.Count
            sMasterKey = ActiveGanttVBCtl1.Rows.Item(i).Key
            If bHasChildren(i) = True And _
            ActiveGanttVBCtl1.Rows.Item(i).Height > -1 And _
            ActiveGanttVBCtl1.Rows.Item(i).Tag = "-" Then
                lTextX = ActiveGanttVBCtl1.RowHeadings.Item(1).Left + _
                ((Len(sMasterKey) + 3) * 5) - 6
                lTop = CSng(ActiveGanttVBCtl1.Rows.Item(i).Top + _
                ((ActiveGanttVBCtl1.Rows.Item(i).bottom - _
                ActiveGanttVBCtl1.Rows.Item(i).Top) / 2)) + 5
                If bHasChildren(i + 1) = False Then
                    lBottom = CSng(ActiveGanttVBCtl1.Rows.Item(i + 1).Top + _
                    ((ActiveGanttVBCtl1.Rows.Item(i + 1).bottom - _
                    ActiveGanttVBCtl1.Rows.Item(i + 1).Top) / 2))
                Else
                    lBottom = CSng(ActiveGanttVBCtl1.Rows.Item(i + 1).Top) + 4
                End If
                DrawLine lHdc, RGB(0, 0, 0), lTextX, lTop, lTextX, lBottom
            End If
            For k = i + 1 To ActiveGanttVBCtl1.Rows.Count
                sKey = ActiveGanttVBCtl1.Rows.Item(k).Key
                If IsSibling(sMasterKey, sKey) = True Then
                    If ActiveGanttVBCtl1.Rows.Item(i).Height > -1 And _
                    ActiveGanttVBCtl1.Rows.Item(k).Height > -1 Then
                        lTextX = ActiveGanttVBCtl1.RowHeadings.Item(1).Left + _
                        (Len(sKey) * 5) - 6
                        If (ActiveGanttVBCtl1.Rows.Item(i).Tag = "") Then
                            lTop = CSng(ActiveGanttVBCtl1.Rows.Item(i).Top + _
                            ((ActiveGanttVBCtl1.Rows.Item(i).bottom - _
                            ActiveGanttVBCtl1.Rows.Item(i).Top) / 2))
                        Else
                            lTop = CSng(ActiveGanttVBCtl1.Rows.Item(i).Top + _
                            ((ActiveGanttVBCtl1.Rows.Item(i).bottom - _
                            ActiveGanttVBCtl1.Rows.Item(i).Top) / 2)) + 1
                        End If
                        If (ActiveGanttVBCtl1.Rows.Item(k).Tag = "") Then
                            lBottom = CSng(ActiveGanttVBCtl1.Rows.Item(k).Top + _
                            ((ActiveGanttVBCtl1.Rows.Item(k).bottom - _
                            ActiveGanttVBCtl1.Rows.Item(k).Top) / 2)) + 1
                        Else
                            lBottom = CSng(ActiveGanttVBCtl1.Rows.Item(k).Top) + 3
                        End If
                        DrawLine lHdc, RGB(0, 0, 0), lTextX, lTop, lTextX, lBottom
                    End If
                    Exit For
                End If
            Next k
        Next i
End Sub

Private Sub DrawRectangle(ByVal hdc As Long, ByVal lColor As OLE_COLOR, _
ByVal v_X1 As Long, ByVal v_Y1 As Long, ByVal Width As Long, ByVal Height As Long)
    Dim hPen As Long
    Dim HoldPen As Long
    Dim Points() As POINTTYPE
    hPen = CreatePen(PS_SOLID, 1, lColor)
    HoldPen = SelectObject(hdc, hPen)
    ReDim Points(4)
    Points(0).x = v_X1
    Points(0).y = v_Y1
    Points(1).x = v_X1 + Width
    Points(1).y = v_Y1
    Points(2).x = v_X1 + Width
    Points(2).y = v_Y1 + Height
    Points(3).x = v_X1
    Points(3).y = v_Y1 + Height
    Points(4).x = v_X1
    Points(4).y = v_Y1
    Polyline hdc, Points(0), 5
    SelectObject hdc, HoldPen
    DeleteObject hPen
End Sub

Private Sub DrawLine(ByVal hdc As Long, ByVal lColor As OLE_COLOR, _
ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long)
    Dim hPen As Long
    Dim HoldPen As Long
    Dim Points() As POINTTYPE
    hPen = CreatePen(PS_SOLID, 1, lColor)
    HoldPen = SelectObject(hdc, hPen)
    ReDim Points(1)
    Points(0).x = X1
    Points(0).y = Y1
    Points(1).x = X2
    Points(1).y = Y2
    Polyline hdc, Points(0), 2
    SelectObject hdc, HoldPen
    DeleteObject hPen
End Sub

Private Sub DrawString(ByVal sCaption As String, ByVal lHdc As Long, _
ByRef oFont As StdFont, ByVal lColor As OLE_COLOR, ByVal X1 As Long, ByVal Y1 As Long)
    Dim holdFont As Long
    Dim FontI As IFont
    Set FontI = oFont
    holdFont = SelectObject(lHdc, FontI.hFont)
    SetTextColor lHdc, lColor
    TextOut lHdc, X1, Y1, sCaption, Len(sCaption)
    SelectObject lHdc, holdFont
End Sub
This code uses the RowDraw and FixedColumnDraw events to custom paint the Treeview. With some additional coding it can be adapted to most situations.
Home | Products | Support | Downloads | OnLine Store
Online Documentation | Licensing | About Us | Contact Us