Programming Tool Box/SIMS_2.iso/vb_code1/listdemo/list_utl.bas

BASIC Source File | 1994-01-10 | 12KB | 397 lines

'These Visual Basic functions were written by Brad Kaenel
'of PC HELP-LINE, and are considered to be a "work-in-progress".
'If you have a comment or suggestion for improvement, contact
'Brad through Compuserve (72357,3523) or Internet ([e-mail])

Option Explicit

Declare Function WinAPI_SetTabstops Lib "User" Alias "SendMessage" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
Declare Function WinAPI_SelectString Lib "User" Alias "SendMessage" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, ByVal lParam As String) As Long
Declare Function WinAPI_GetTextExtent Lib "GDI" Alias "GetTextExtent" (ByVal hDC As Integer, ByVal lpString As String, ByVal nCount As Integer) As Long
Declare Function WinAPI_GetDialogBaseUnits Lib "User" Alias "GetDialogBaseUnits" () As Long

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 SEARCH_FROM_TOP = -1

Function SelectListItem (ListControl As Control, SelectString As String) As Integer

Dim MsgID As Integer
Dim RC As Long


'===================
SelectListItem_Main:
'===================
SelectListItem = True

GoSub SelectListItem_VerifyControls
GoSub SelectListItem_UpdateControls

Exit Function


'=============================
SelectListItem_VerifyControls:
'=============================
If TypeOf ListControl Is ListBox Then
   MsgID = LB_SELECTSTRING
Else
   If TypeOf ListControl Is ComboBox Then
      MsgID = CB_SELECTSTRING
   Else
      SelectListItem = False
      Exit Function
   End If
End If

If Len(SelectString) = 0 Then
   SelectListItem = False
   Exit Function
End If

Return

'=============================
SelectListItem_UpdateControls:
'=============================
RC = WinAPI_SelectString(ListControl.hWnd, MsgID, SEARCH_FROM_TOP, SelectString)

Return

End Function

Function SetListCols (ListControl As Control, TextControl As Control, UseHeadingWidthsOnly As Integer, SetDefaultTabstops 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.

'UseHeadingWidthsOnly:
'  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.

'SetDefaultTabstops:
'  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 return FALSE if any of the control
'verification tests fail; otherwise it returns TRUE.


Dim ColHeadings As String, ColData As String, ColString As String
Dim ParentFontName As String, ParentFontSize As Single
Dim ParentFontBold As Integer, ParentFontItalic As Integer
Dim ColCount As Integer, DataWidth As Integer, SpaceBetweenCols As Integer
Dim MaxListboxCols As Integer, NbrListboxCols As Integer, NbrTabstops As Integer
Dim InStart As Integer, TabPos As Integer
Dim ListSub As Integer, TabSub As Integer
Dim RC As Long
Dim ListFontAvgWidth As Integer, SystemFontAvgWidth As Integer
Dim ListFontPixelsPerDlgUnit As Single, FontRatio As Single

Dim ColWidth() As Integer  'measured column widths
Dim Tabstop() As Integer   'calculated WinAPI tabstops

'================
SetListCols_Main:
'================
SetListCols = True

GoSub SetListCols_VerifyControls
GoSub SetListCols_Initialize

If SetDefaultTabstops Then
   NbrTabstops = 0
   GoSub SetListCols_UpdateControls
Else
   'Since VB provides an hDC property only for forms,
   '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.

   ParentFontName = ListControl.Parent.FontName
   ParentFontSize = ListControl.Parent.FontSize
   ParentFontBold = ListControl.Parent.FontBold
   ParentFontItalic = ListControl.Parent.FontItalic
   ListControl.Parent.FontName = ListControl.FontName
   ListControl.Parent.FontSize = ListControl.FontSize
   ListControl.Parent.FontBold = ListControl.FontBold
   ListControl.Parent.FontItalic = ListControl.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 UseHeadingWidthsOnly 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.

   ListControl.Parent.FontName = ParentFontName
   ListControl.Parent.FontSize = ParentFontSize
   ListControl.Parent.FontBold = ParentFontBold
   ListControl.Parent.FontItalic = ParentFontItalic
End If

Exit Function


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

If TypeOf ListControl Is ListBox Then
Else
   SetListCols = False
   Exit Function
End If

If TypeOf TextControl Is TextBox Then
Else
   SetListCols = False
   Exit Function
End If

If ListControl.Columns <> 0 Then
   SetListCols = False
   Exit Function
End If

If TextControl.MultiLine = False Then
   SetListCols = False
   Exit Function
End If

If TextControl.BorderStyle <> 0 Then
   SetListCols = False
   Exit Function
End If

If Len(TextControl.Text) = 0 Then
   SetListCols = 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.

SpaceBetweenCols = 2

MaxListboxCols = 10
ReDim ColWidth(MaxListboxCols)

Return

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

ColHeadings = TextControl.Text
NbrListboxCols = 1

InStart = 1
Do
   TabPos = InStr(InStart, ColHeadings, Chr$(9))

   If TabPos > 0 Then
      ColString = Mid$(ColHeadings, InStart, TabPos - InStart)
   Else
      ColString = Mid$(ColHeadings, InStart, Len(ColHeadings) - InStart + 1)
   End If

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

   ColString = ColString + Space$(SpaceBetweenCols)
   ColWidth(NbrListboxCols) = WinAPI_GetTextExtent(ListControl.Parent.hDC, ColString, Len(ColString)) Mod 65536

   If TabPos > 0 Then
      NbrListboxCols = NbrListboxCols + 1

      'Allocate more space for more columns, if necessary

      If NbrListboxCols > MaxListboxCols Then
         MaxListboxCols = NbrListboxCols
         ReDim Preserve ColWidth(MaxListboxCols)
      End If

      If TabPos < Len(ColHeadings) Then
         InStart = TabPos + 1
      End If
   End If
Loop Until TabPos = 0

NbrTabstops = NbrListboxCols - 1

Return

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

For ListSub = 0 To ListControl.ListCount - 1
   If Len(ListControl.List(ListSub)) > 0 Then
      ColData = ListControl.List(ListSub)
      ColCount = 1

      InStart = 1
      Do
         TabPos = InStr(InStart, ColData, Chr$(9))

         If TabPos > 0 Then
            ColString = Mid$(ColData, InStart, TabPos - InStart)
         Else
            ColString = Mid$(ColData, InStart, Len(ColData) - InStart + 1)
         End If

         'Measure the length of the string, in pixels

         ColString = ColString + Space$(SpaceBetweenCols)
         DataWidth = WinAPI_GetTextExtent(ListControl.Parent.hDC, ColString, Len(ColString)) Mod 65536

         'Ignore data columns for which there is no heading.

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

            If DataWidth > ColWidth(ColCount) Then
               ColWidth(ColCount) = DataWidth
            End If
         End If

         If TabPos > 0 Then
            ColCount = ColCount + 1

            If TabPos < Len(ColData) Then
               InStart = TabPos + 1
            End If
         End If
      Loop Until TabPos = 0
   End If
Next

Return

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

TextControl.Enabled = False
TextControl.FontName = ListControl.FontName
TextControl.FontSize = ListControl.FontSize
TextControl.FontBold = ListControl.FontBold
TextControl.FontItalic = ListControl.FontItalic
TextControl.Move ListControl.Left, ListControl.Top - TextControl.Height, ListControl.Width, TextControl.Height

ReDim Tabstop(NbrTabstops)

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

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

   ListFontAvgWidth = (WinAPI_GetTextExtent(ListControl.Parent.hDC, "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz", 52) Mod 65536) / 52
   SystemFontAvgWidth = WinAPI_GetDialogBaseUnits() 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 "SpaceBetweenCols").

   '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.

   FontRatio = ListFontAvgWidth / SystemFontAvgWidth
   ListFontPixelsPerDlgUnit = (SystemFontAvgWidth * FontRatio) / 4

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

   Tabstop(0) = ColWidth(1) / ListFontPixelsPerDlgUnit
   For TabSub = 2 To NbrTabstops
      Tabstop(TabSub - 1) = Tabstop(TabSub - 2) + ColWidth(TabSub) / ListFontPixelsPerDlgUnit
   Next
Else
   Tabstop(0) = 0
End If

'Activate the tabstops.

RC = WinAPI_SetTabstops(TextControl.hWnd, EM_SETTABSTOPS, NbrTabstops, Tabstop(0))
RC = WinAPI_SetTabstops(ListControl.hWnd, LB_SETTABSTOPS, NbrTabstops, Tabstop(0))

'Redraw the controls.

TextControl.Refresh
ListControl.Refresh

Return

End Function