Programming Tool Box/SIMS_2.iso/code/design/lbtabs/dulist.bas

BASIC Source File | 1995-01-06 | 14KB | 468 lines

Option Explicit

Const WM_USER = 1024
Const LB_SETTABSTOPS = WM_USER + 19
Const EM_SETTABSTOPS = WM_USER + 27
Const CB_SELECTSTRING = WM_USER + 13
Const LB_SELECTSTRING = WM_USER + 13
Const LB_SETHORIZONTALEXTENT = WM_USER + 21

Const nSEARCH_FROM_TOP = -1

Declare Function dulist_nlSetTabstops Lib "User" Alias "SendMessage" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
Declare Function dulist_nlSelectString Lib "User" Alias "SendMessage" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, ByVal lParam As String) As Long
Declare Function dulist_nlGetTextExtent Lib "GDI" Alias "GetTextExtent" (ByVal hDC As Integer, ByVal lpString As String, ByVal nCount As Integer) As Long
Declare Function dulist_nlGetDialogBaseUnits Lib "User" Alias "GetDialogBaseUnits" () As Long
Declare Function dulist_nlSetHorizScrollBar Lib "User" Alias "SendMessage" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long

Sub dulist_AddHorizScrollBar (ctlListControl As Control, fVirtualWidthRatio As Single)

Dim nlRC As Long
Dim fMultiplier As Single


If fVirtualWidthRatio <= 1 Then
   fMultiplier = 2  'default 2x wider
Else
   fMultiplier = fVirtualWidthRatio
End If

nlRC = dulist_nlSetHorizScrollBar(ctlListControl.hWnd, LB_SETHORIZONTALEXTENT, (ctlListControl.Width * fMultiplier) \ Screen.TwipsPerPixelX, 0)

End Sub

Function dulist_sGetColumn (sColData As String, nColID As Integer) As String

Dim sTAB As String
Dim sColString As String
Dim nNbrListboxCols As Integer
Dim nInStart As Integer, nTabPos As Integer


dulist_sGetColumn = ""

If Len(sColData) = 0 Or nColID <= 0 Then
   Exit Function
End If

sTAB = Chr$(9)
nNbrListboxCols = 1

nInStart = 1
Do
   nTabPos = InStr(nInStart, sColData, sTAB)

   If nTabPos > 0 Then
      sColString = Mid$(sColData, nInStart, nTabPos - nInStart)
   Else
      sColString = Mid$(sColData, nInStart, Len(sColData) - nInStart + 1)
   End If

   If nNbrListboxCols = nColID Then
      dulist_sGetColumn = RTrim$(sColString)
      Exit Do
   End If

   If nTabPos > 0 Then
      nNbrListboxCols = nNbrListboxCols + 1

      If nTabPos < Len(sColData) Then
         nInStart = nTabPos + 1
      Else
         Exit Do
      End If
   Else
      Exit Do
   End If
Loop

End Function

Function dulist_tfSelectListItem (ctlListControl As Control, sSelectString As String) As Integer

Dim nMsgID As Integer
Dim nlRC As Long


'===================
SelectListItem_Main:
'===================
dulist_tfSelectListItem = True

GoSub SelectListItem_VerifyControls
GoSub SelectListItem_UpdateControls

Exit Function


'=============================
SelectListItem_VerifyControls:
'=============================
If TypeOf ctlListControl Is ListBox Then
   nMsgID = LB_SELECTSTRING
Else
   If TypeOf ctlListControl Is ComboBox Then
      nMsgID = CB_SELECTSTRING
   Else
      dulist_tfSelectListItem = False
      Exit Function
   End If
End If

If Len(sSelectString) = 0 Then
   dulist_tfSelectListItem = False
   Exit Function
End If

Return

'=============================
SelectListItem_UpdateControls:
'=============================
nlRC = dulist_nlSelectString(ctlListControl.hWnd, nMsgID, nSEARCH_FROM_TOP, sSelectString)

Return

End Function

Function dulist_tfSetListCols (ctlListControl As Control, ctlTextControl As Control, tfUseHeadingWidthsOnly As Integer, tfSetDefaultTabstops As Integer) As Integer

'This function automatically calculates and sets appropriate
'tabstops for a multi-column listbox, based on the actual data
'in the listbox.  You do not have to tell the function how many
'columns you want, nor figure out how wide each column should be;
'the actual data placed into the listbox determines that.

'In addition to the listbox, the function also sets identical
'tabstops in an accompanying, multi-line textbox.  This textbox
'provides the data for the column headings.

'tfUseHeadingWidthsOnly:
'  True -  Tabstops are calculated based only on the
'          widths of the column headings. This option
'          is must faster, but you're gambling that the
'          actual data will always be narrower than the
'          headings.
'
'  False - Tabstops are calculated based on the widest
'          entry in each column; both the headings and
'          the data are examined.  This option is slower
'          because each entry in the listbox must be
'          parsed, but it eliminates the guesswork.

'tfSetDefaultTabstops:
'  True -  Tabstops are reset to Windows' default intervals
'          of 8 dialog units.
'
'  False - Tabstops are calculated based on the actual
'          data in the listbox/textbox.
'
'
'The function itself returns FALSE if any of the control
'verification tests fail; otherwise it returns TRUE.


Dim sTAB As String
Dim sColHeadings As String, sColData As String, sColString As String
Dim sParentFontName As String, fParentFontSize As Single
Dim tfParentFontBold As Integer, tfParentFontItalic As Integer
Dim nColCount As Integer, nDataWidth As Integer, nSpaceBetweenCols As Integer
Dim nMaxListboxCols As Integer, nNbrListboxCols As Integer, nNbrTabstops As Integer
Dim nInStart As Integer, nTabPos As Integer
Dim nListSub As Integer, nTabSub As Integer
Dim nlRC As Long
Dim nListFontAvgWidth As Integer, nSystemFontAvgWidth As Integer
Dim fListFontPixelsPerDlgUnit As Single, fFontRatio As Single

Dim nColWidth() As Integer  'measured column widths
Dim nTabstop() As Integer   'calculated WinAPI tabstops

'================
SetListCols_Main:
'================
dulist_tfSetListCols = True

GoSub SetListCols_VerifyControls
GoSub SetListCols_Initialize

If tfSetDefaultTabstops Then
   nNbrTabstops = 0
   GoSub SetListCols_UpdateControls
Else
   'Since VB provides an hDC property for forms, but
   'not for controls, we must temporarily set the parent
   'form's font characteristics equal to the listbox's
   'font characteristics.  Doing this ensures that all
   'text measurements made using the form's DC will be
   'accurate for the listbox.

   sParentFontName = ctlListControl.Parent.FontName
   fParentFontSize = ctlListControl.Parent.FontSize
   tfParentFontBold = ctlListControl.Parent.FontBold
   tfParentFontItalic = ctlListControl.Parent.FontItalic
   ctlListControl.Parent.FontName = ctlListControl.FontName
   ctlListControl.Parent.FontSize = ctlListControl.FontSize
   ctlListControl.Parent.FontBold = ctlListControl.FontBold
   ctlListControl.Parent.FontItalic = ctlListControl.FontItalic

   'Identify and measure the width of the column headings
   'present in the textbox.

   GoSub SetListCols_MeasureColHeadingWidths

   'Measure the width of the column data values present
   'in the listbox.

   If Not tfUseHeadingWidthsOnly Then
      GoSub SetListCols_MeasureColDataWidths
   End If

   'Calculate and set the necessary tabstop values, based
   'on the maximum width of each column.

   GoSub SetListCols_UpdateControls

   'Reset the parent form's font characteristics to their
   'original values.

   ctlListControl.Parent.FontName = sParentFontName
   ctlListControl.Parent.FontSize = fParentFontSize
   ctlListControl.Parent.FontBold = tfParentFontBold
   ctlListControl.Parent.FontItalic = tfParentFontItalic
End If

Exit Function


'==========================
SetListCols_VerifyControls:
'==========================
'Make sure both controls are of the proper type,
'and that the necessary property values are set.

If TypeOf ctlListControl Is ListBox Then
Else
   dulist_tfSetListCols = False
   Exit Function
End If

If TypeOf ctlTextControl Is TextBox Then
Else
   dulist_tfSetListCols = False
   Exit Function
End If

If ctlListControl.Columns <> 0 Then
   dulist_tfSetListCols = False
   Exit Function
End If

If ctlTextControl.MultiLine = False Then
   dulist_tfSetListCols = False
   Exit Function
End If

If ctlTextControl.BorderStyle <> 0 Then
   dulist_tfSetListCols = False
   Exit Function
End If

If Len(ctlTextControl.Text) = 0 Then
   dulist_tfSetListCols = False
   Exit Function
End If

Return

'======================
SetListCols_Initialize:
'======================
'A little extra space between columns helps
'to mitigate the inevitable rounding errors
'that will occur in the tabstop calculations.

nSpaceBetweenCols = 2

nMaxListboxCols = 10
ReDim nColWidth(nMaxListboxCols)

sTAB = Chr$(9)

Return

'===================================
SetListCols_MeasureColHeadingWidths:
'===================================
'Search for TAB characters in the column heading
'text.  For each column found, measure the width
'of the heading text.

sColHeadings = ctlTextControl.Text
nNbrListboxCols = 1

nInStart = 1
Do
   nTabPos = InStr(nInStart, sColHeadings, sTAB)

   If nTabPos > 0 Then
      sColString = Mid$(sColHeadings, nInStart, nTabPos - nInStart)
   Else
      sColString = Mid$(sColHeadings, nInStart, Len(sColHeadings) - nInStart + 1)
   End If

   'Measure the length of the string, in pixels;
   'this value is the current "column width".

   sColString = sColString + Space$(nSpaceBetweenCols)
   nColWidth(nNbrListboxCols) = dulist_nlGetTextExtent(ctlListControl.Parent.hDC, sColString, Len(sColString)) Mod 65536

   If nTabPos > 0 Then
      nNbrListboxCols = nNbrListboxCols + 1

      'Allocate space for more columns, if necessary

      If nNbrListboxCols > nMaxListboxCols Then
         nMaxListboxCols = nNbrListboxCols
         ReDim Preserve nColWidth(nMaxListboxCols)
      End If

      If nTabPos < Len(sColHeadings) Then
         nInStart = nTabPos + 1
      Else
         Exit Do
      End If
   Else
      Exit Do
   End If
Loop

nNbrTabstops = nNbrListboxCols - 1

Return

'================================
SetListCols_MeasureColDataWidths:
'================================
'Search for TAB characters in the listbox data.
'For each column found, measure the width of
'the data.

For nListSub = 0 To ctlListControl.ListCount - 1
   If Len(ctlListControl.List(nListSub)) > 0 Then
      sColData = ctlListControl.List(nListSub)
      nColCount = 1

      nInStart = 1
      Do
         nTabPos = InStr(nInStart, sColData, sTAB)

         If nTabPos > 0 Then
            sColString = Mid$(sColData, nInStart, nTabPos - nInStart)
         Else
            sColString = Mid$(sColData, nInStart, Len(sColData) - nInStart + 1)
         End If

         'Measure the length of the string, in pixels

         sColString = sColString + Space$(nSpaceBetweenCols)
         nDataWidth = dulist_nlGetTextExtent(ctlListControl.Parent.hDC, sColString, Len(sColString)) Mod 65536

         'Ignore data columns for which there is no heading.

         If nColCount <= nNbrListboxCols Then
            'If any data value is wider than the current column width,
            'it becomes the new column width.

            If nDataWidth > nColWidth(nColCount) Then
               nColWidth(nColCount) = nDataWidth
            End If
         End If

         If nTabPos > 0 Then
            nColCount = nColCount + 1

            If nTabPos < Len(sColData) Then
               nInStart = nTabPos + 1
            Else
               Exit Do
            End If
         Else
            Exit Do
         End If
      Loop
   End If
Next

Return

'==========================
SetListCols_UpdateControls:
'==========================
'Set the textbox font characteristics equal
'to the listbox font characteristics.

ctlTextControl.Enabled = False
ctlTextControl.FontName = ctlListControl.FontName
ctlTextControl.FontSize = ctlListControl.FontSize
ctlTextControl.FontBold = ctlListControl.FontBold
ctlTextControl.FontItalic = ctlListControl.FontItalic
ctlTextControl.Move ctlListControl.Left, ctlListControl.Top - ctlTextControl.Height, ctlListControl.Width, ctlTextControl.Height

ReDim nTabstop(nNbrTabstops)

'Calculate tabstop values for each column, in "dialog units"

If nNbrTabstops > 0 Then
   'Get the average character widths, in pixels, of the
   'listbox font and the system font.

   nListFontAvgWidth = (dulist_nlGetTextExtent(ctlListControl.Parent.hDC, "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz", 52) Mod 65536) / 52
   nSystemFontAvgWidth = dulist_nlGetDialogBaseUnits() Mod 65536

   'A "dialog unit" is defined as 1/4 of the average
   'character width of the system font, in pixels.
   'We've already measured the width of each column,
   'in pixels, but it's not accurate enough to simply
   'divide one value into the other.

   'Note that errors in precision will start to creep in
   'at this point, due to integer rounding and intermediate
   'calculation results.  Experience shows that a little
   'extra white space between the data columns helps to
   'compensate (see "nSpaceBetweenCols").

   'Since a dialog unit is based on the system font,
   'not the font we're actually using in the listbox,
   'we must factor in the difference between the two
   'average character widths.  Thus, a more accurate
   'divisor is calculated as follows.

   fFontRatio = nListFontAvgWidth / nSystemFontAvgWidth
   fListFontPixelsPerDlgUnit = (nSystemFontAvgWidth * fFontRatio) / 4

   'Set a tabstop at the dialog unit closest to the
   'right-hand boundary (width) of each column.

   nTabstop(0) = nColWidth(1) / fListFontPixelsPerDlgUnit
   For nTabSub = 2 To nNbrTabstops
      nTabstop(nTabSub - 1) = nTabstop(nTabSub - 2) + nColWidth(nTabSub) / fListFontPixelsPerDlgUnit
   Next
Else
   nTabstop(0) = 0
End If

'Activate the tabstops.

nlRC = dulist_nlSetTabstops(ctlTextControl.hWnd, EM_SETTABSTOPS, nNbrTabstops, nTabstop(0))
nlRC = dulist_nlSetTabstops(ctlListControl.hWnd, LB_SETTABSTOPS, nNbrTabstops, nTabstop(0))

'Redraw the controls.

ctlTextControl.Refresh
ctlListControl.Refresh

Return

End Function