SftBox/OCX 5.0 - Combo Box Control

FontDlg Sample (VB6)

This sample illustrates a font dialog for font selection.

The source code is located at C:\Program Files (x86)\Softelvdm\SftBox OCX 5.0\Samples\VB6\FontDlg\Form1.frm or C:\Program Files\Softelvdm\SftBox OCX 5.0\Samples\VB6\FontDlg\Form1.frm (on 32-bit Windows versions).

Option Explicit

Private Sub Form_Load()
    CondHeaders.Value = 1
    ' set sort order
    FontNames.Header(0).Image.Appearance = sftImageSortAsc
    FontStyles.Header(0).Image.Appearance = sftImageSortAsc
    FontSizes.Header(0).Image.Appearance = sftImageSortAsc
    ' add all font information
    UpdateFontNames
End Sub

Private Sub ReverseSortOrder(SftBoxCtrl As SftBox)
    If SftBoxCtrl.Header(0).Image.Appearance = sftImageSortAsc Then
        SftBoxCtrl.Header(0).Image.Appearance = sftImageSortDesc
    Else
        SftBoxCtrl.Header(0).Image.Appearance = sftImageSortAsc
    End If
End Sub

Private Sub PerformCellValueSort(SftBoxCtrl As SftBox)
    ' Font sizes are sorted according to numeric Cell.Data property
    If SftBoxCtrl.Header(0).Image.Appearance = sftImageSortAsc Then
        SftBoxCtrl.Items.Sort -1, 0, sortSftBoxCellValueAscending
    Else
        SftBoxCtrl.Items.Sort -1, 0, sortSftBoxCellValueDescending
    End If
End Sub

Private Sub PerformSort(SftBoxCtrl As SftBox)
    ' Font styles and font names are sorted by Cell.Text property
    If SftBoxCtrl.Header(0).Image.Appearance = sftImageSortAsc Then
        SftBoxCtrl.Items.Sort -1, 0, sortSftBoxAscending
    Else
        SftBoxCtrl.Items.Sort -1, 0, sortSftBoxDescending
    End If
End Sub

Private Sub UpdateFontNames()
    ' add all font names
    FontNames.BulkUpdate = True
    FontNames.Items.Clear
    FontNames.Items.AddFontNames -1, fontSftBoxAll, True, 0
    FontNames.Items.Selection = 0
    PerformSort FontNames
    FontNames.BulkUpdate = False
    FontNames.Columns.MakeOptimal 0
    FontNames.Items.RecalcHorizontalExtent 0
End Sub

Private Sub FontNames_SelectionChange()
    UpdateStyles
End Sub

Private Sub FontNames_ItemClick(ByVal Part As SftBoxLib50.SftBoxPortionConstants, ByVal AreaType As SftBoxLib50.SftBoxAreaConstants, ByVal ItemIndex As Long, ByVal ColNum As Integer, ByVal Button As Integer, ByVal Shift As Integer)
    If AreaType = areaSftBoxColumn Then
        ReverseSortOrder FontNames
        PerformSort FontNames
    End If
End Sub

Private Sub FontNames_ItemDblClk(ByVal Part As SftBoxLib50.SftBoxPortionConstants, ByVal AreaType As SftBoxLib50.SftBoxAreaConstants, ByVal ItemIndex As Long, ByVal ColNum As Integer, ByVal Button As Integer, ByVal Shift As Integer)
    If AreaType = areaSftBoxColumn Then
        ReverseSortOrder FontNames
        PerformSort FontNames
    End If
End Sub

Private Sub UpdateStyles()
    Dim OldText As String, Index As Long
    ' add all styles for the current font name
    If FontNames.Items.Selection >= 0 Then
        OldText = FontStyles.Edit.Text
        FontStyles.Items.AddFontStyles FontNames.Cell(FontNames.Items.Selection, 0).Text, 0, "", ""
        Index = FontStyles.Items.Find(OldText, 0, 0, False, True, True)
        If Index < 0 Then Index = 0
        FontStyles.Items.Selection = Index
    Else
        FontStyles.Items.Clear
    End If
    PerformSort FontStyles
    FontStyles.Columns.MakeOptimal 0
    FontStyles.Items.RecalcHorizontalExtent 0
    UpdateSizes
End Sub

Private Sub FontStyles_SelectionChange()
    UpdateSizes
End Sub

Private Sub FontStyles_ItemClick(ByVal Part As SftBoxLib50.SftBoxPortionConstants, ByVal AreaType As SftBoxLib50.SftBoxAreaConstants, ByVal ItemIndex As Long, ByVal ColNum As Integer, ByVal Button As Integer, ByVal Shift As Integer)
    If AreaType = areaSftBoxColumn Then
        ReverseSortOrder FontStyles
        PerformSort FontStyles
    End If
End Sub

Private Sub FontStyles_ItemDblClk(ByVal Part As SftBoxLib50.SftBoxPortionConstants, ByVal AreaType As SftBoxLib50.SftBoxAreaConstants, ByVal ItemIndex As Long, ByVal ColNum As Integer, ByVal Button As Integer, ByVal Shift As Integer)
    If Part = partSftBoxStatic Then
        If AreaType = areaSftBoxColumn Then
            ReverseSortOrder FontStyles
            PerformSort FontStyles
        End If
    End If
End Sub

Private Sub UpdateSizes()
    Dim OldText As String, Index As Long
    ' add all sizes for the current font name
    If FontNames.Items.Selection >= 0 Then
        OldText = FontSizes.Edit.Text
        FontSizes.Items.AddFontSizes FontNames.Cell(FontNames.Items.Selection, 0).Text, 0
        Index = FontSizes.Items.Find(OldText, 0, 0, False, True, True)
        If Index < 0 Then Index = 0
        FontSizes.Items.Selection = Index
    Else
        FontSizes.Items.Clear
    End If
    PerformCellValueSort FontSizes
    FontSizes.Columns.MakeOptimal 0
    FontSizes.Items.RecalcHorizontalExtent 0
    UpdateSample
End Sub

Private Sub FontSizes_SelectionChange()
    UpdateSample
End Sub

Private Sub FontSizes_ItemClick(ByVal Part As SftBoxLib50.SftBoxPortionConstants, ByVal AreaType As SftBoxLib50.SftBoxAreaConstants, ByVal ItemIndex As Long, ByVal ColNum As Integer, ByVal Button As Integer, ByVal Shift As Integer)
    If AreaType = areaSftBoxColumn Then
        ReverseSortOrder FontSizes
        PerformCellValueSort FontSizes
    End If
End Sub

Private Sub FontSizes_ItemDblClk(ByVal Part As SftBoxLib50.SftBoxPortionConstants, ByVal AreaType As SftBoxLib50.SftBoxAreaConstants, ByVal ItemIndex As Long, ByVal ColNum As Integer, ByVal Button As Integer, ByVal Shift As Integer)
    If AreaType = areaSftBoxColumn Then
        ReverseSortOrder FontSizes
        PerformCellValueSort FontSizes
    End If
End Sub

Private Sub UpdateSample()
    Dim Weight As Integer
    Dim Italic As Boolean
    Dim SelItem As Long
    SelItem = FontStyles.Items.Selection
    If SelItem >= 0 And FontSizes.Edit.Text <> "" Then
        SampleText.Caption = "AaBbCcYyZz"
        SampleText.Font.Name = FontNames.Edit.Text
        Italic = (FontStyles.Cell(SelItem, 0).Data And &H80000000)
        SampleText.Font.Italic = Italic
        Weight = (FontStyles.Cell(SelItem, 0).Data And &H7FFFFFFF)
        SampleText.Font.Bold = (Weight > 400) ' FW_NORMAL
        SampleText.Font.Size = FontSizes.Edit.Text
    Else
        SampleText.Caption = ""
    End If
End Sub

Private Sub Command1_Click()
    Unload Form1
End Sub

Private Sub CondHeaders_Click()
    If CondHeaders.Value = 0 Then
        FontNames.Headers.Main = False
        FontNames.Headers.DropDown = True
        FontStyles.Headers.Main = False
        FontStyles.Headers.DropDown = True
        FontSizes.Headers.Main = False
        FontSizes.Headers.DropDown = True
    Else
        FontNames.Headers.Main = True
        FontNames.Headers.DropDown = False
        FontStyles.Headers.Main = True
        FontStyles.Headers.DropDown = False
        FontSizes.Headers.Main = True
        FontSizes.Headers.DropDown = False
    End If
End Sub