Option Explicit
    
Private Sub Command1_Click()
    Unload Form1
End Sub


Private Sub Form_Load()
    Dim I As Integer, ItemIndex As Integer
    Dim MaxFonts As Integer
    Dim ScreenIndex As Integer, PrinterIndex As Integer
    Dim C As SftTreeCell

    With SftTree1
        ' Mass-Update
        .BulkUpdate = True
        
        ' Add all screen fonts to the tree control
        ScreenIndex = .Items.Add("Screen Fonts")
        .Item(ScreenIndex).Level = 0
        ' display screen fonts
        MaxFonts = Screen.FontCount
        ' limit to 20 fonts
        If MaxFonts > 20 Then MaxFonts = 20
        For I = 0 To MaxFonts - 1
            ' add the item
            ItemIndex = .Items.Add(Screen.Fonts(I))
            .Item(ItemIndex).Level = 1
            ' set the cell name and font in column 0
            Set C = .Cell(ItemIndex, 0)
            C.Font.Name = Screen.Fonts(I)
            ' not bold
            C.Font.Bold = False
            ' 10 pt
            C.Font.Size = 10
            ' set the font name in column 1
            .Cell(ItemIndex, 1).Text = Screen.Fonts(I)
        Next I
        
        ' Add all print fonts to the tree control
        PrinterIndex = .Items.Add("Printer Fonts")
        .Item(PrinterIndex).Level = 0
        ' limit to 20 fonts
        On Error GoTo NoPrinter
        MaxFonts = Printer.FontCount
        If MaxFonts > 20 Then MaxFonts = 20
        On Error GoTo 0
        For I = 0 To MaxFonts - 1
            ' add the item
            ItemIndex = .Items.Add(Printer.Fonts(I))
            .Item(ItemIndex).Level = 1
            ' set the cell name and font in column 0
            Set C = .Cell(ItemIndex, 0)
            C.Font.Name = Screen.Fonts(I)
            ' not bold
            C.Font.Bold = False
            ' 10 pt
            C.Font.Size = 10
            ' set the font name in column 1
            .Cell(ItemIndex, 1).Text = Printer.Fonts(I)
        Next I
        ' Sort fonts
        .Items.SortDependents PrinterIndex, 0, sortSftTreeAscending
NoPrinter:
        ' Sort fonts
        .Items.SortDependents ScreenIndex, 0, sortSftTreeAscending
        
        .Items.Current = 0
        .Item(0).Selected = True
        
        ' End of Mass-Update
        .BulkUpdate = False
        ' make column widths optimal
        .ColumnsObj.MakeOptimal
        ' allow horizontal scrolling
        .Items.RecalcHorizontalExtent
    End With
End Sub

Private Sub SftTree1_ItemDblClick(ByVal ItemIndex As Long, ByVal ColNum As Integer, ByVal AreaType As Integer, ByVal Button As Integer, ByVal Shift As Integer)
    If AreaType = constSftTreeColumnRes Then
        SftTree1.Column(ColNum).MakeOptimal
        SftTree1.Items.RecalcHorizontalExtent
    End If
End Sub