PlanetSquires Forums

Please login or register.

Login with username, password and session length
Advanced search  
Pages: 1 [2]

Author Topic: list box limits  (Read 698 times)

Paul Squires

  • Administrator
  • Master FireFly Member
  • *****
  • Posts: 8295
  • Windows 10
    • PlanetSquires Software
Re: list box limits
« Reply #15 on: June 07, 2018, 02:33:21 PM »

#1 you should look at all of Jose's tooltip functions in his AfxCtl.inc source code file.
« Last Edit: June 07, 2018, 02:35:32 PM by Paul Squires »
Logged
Paul Squires
PlanetSquires Software
FireFly Visual Designer, WinFBE Editor

raymw

  • FireFly3 User
  • Junior FireFly Member
  • *
  • Posts: 105
Re: list box limits
« Reply #16 on: June 08, 2018, 08:34:30 AM »

#2 does the job, thanks. But, it has got me thinking in other directions... Is it possible to edit the font, say background colour, for an individual item in the listbox? I've yet to look into Jose's functions

« Last Edit: June 08, 2018, 09:35:22 AM by raymw »
Logged

Pierre Bellisle

  • FireFly3 User
  • Junior FireFly Member
  • *
  • Posts: 66
Re: list box limits
« Reply #17 on: June 09, 2018, 07:54:54 PM »

Here is a listbox demo that can display 2,147,483,646 items via a subclass to overcome SB_THUMBPOSITION and SB_THUMBTRACK 16bits limits. This LBS_OWNERDRAWFIXED listbox also use different colors and fonts for item display.

Code: [Select]
#Define JumpCompiler "<D:\Free\64\fbc.exe>"
#Define JumpCompilerCmd "<-s gui -w pedantic "D:\Free\bas\~~Default.rc">"

#Print Coded on FreeBASIC 1.05.0
#Ifdef __FB_64BIT__
  #Print  64bit compiler used
#Else
  #Print  32bit compiler used
#EndIf
'_____________________________________________________________________________

#define unicode

#Include Once "Windows.bi"
#Include Once "String.bi" 'Format
#Include Once "Win\ShellApi.bi"

#Define ButtonExit       101
#Define Listbox          201
#Define ListboxItemCount MAXDWORD / 2 '2,147,483,646 items
#Define AppName          "Big ListBox "

Dim Shared As HINSTANCE hInstance : hInstance = GetModuleHandle(NULL)
'_____________________________________________________________________________

Sub EnumCharSet(ByRef elf As ENUMLOGFONT, ByRef ntm As NEWTEXTMETRIC, _
                ByVal FontType As Long, ByVal CharSet As Long)
 'Get type of character set - ansi, symbol.. a must for some fonts.
 CharSet = elf.elfLogFont.lfCharSet

End Sub
'_____________________________________________________________________________

Function MakeFontEx(ByVal hDC As HDC, ByVal pwsFontName As WString Pointer, ByVal PointSize As Long, _
                    ByVal Angle As Long, ByVal fBold As Long, ByVal fItalic As DWORD, _
                    ByVal fUnderline As DWORD, ByVal StrikeThru As DWORD) As HFONT

 'Create a font and return its handle. Ex: hFont = MakeFontEx(hDC, "Segoe UI", 9, 0, 0, 0, 0, 0)
 Dim CharSet  As LParam
 Dim CyPixels As Long

 If hDC = 0 Then
   hDC      = GetDC(HWND_DESKTOP)
   CyPixels = GetDeviceCaps(hDC, LOGPIXELSY)
   EnumFontFamilies(hDC, pwsFontName, Cast(FONTENUMPROCW, ProcPtr(EnumCharSet)), CharSet)
   ReleaseDC(HWND_DESKTOP, hDC)
 Else
   CyPixels = GetDeviceCaps(hDC, LOGPIXELSY)
   EnumFontFamilies(hDC, pwsFontName, Cast(FONTENUMPROCW, ProcPtr(EnumCharSet)), CharSet)
 End If

 PointSize = 0 - (PointSize * CyPixels) \ 72

 Function = CreateFont(PointSize, 0, _                         'Height, Width (default=0),
                       Angle, Angle, _                         'Escapement(angle), Orientation,
                       fBold, _                                'Weight (%FW_DONTCARE = 0, %FW_NORMAL = 400, %FW_BOLD = 700),
                       fItalic, fUnderline, StrikeThru, _      'Italic, Underline, Strike thru,
                       CharSet, OUT_TT_PRECIS, _               'Char set, Output precision,
                       CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, _ 'ClipPrecision, Quality,
                       FF_DONTCARE,  pwsFontName)              'Pitch and family, Typeface

End Function
'_____________________________________________________________________________

FUNCTION ListboxProc(BYVAL hListbox AS HWND, BYVAL Msg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LONG
 'For big Listbox, due to the way where designed, it may be difficult to scroll past the first 65,536 items.
 'The 16 bit returned with SB_THUMBTRACK and SB_THUMBPOSITION set this barrier.
 'A workaround for this is simply to Subclass the ListBox to intercept those messages
 'to set the ScrollBar 32bit position and scroll the ListBox accordingly.
 'Mostly exe using Common-Controls 6.0.0.0 seems to need this correction.

 'MSDN: WM_VSCROLL message carries only 16 bits of scroll box position data in HiWord of wParam.
 'Thus, applications that rely solely on WM_VSCROLL and WM_HSCROLL for
 'scroll position data have a practical maximum position value of 65,535.

 Dim    ScrollInf    AS SCROLLINFO
 Static pListboxProc AS WndProc

 IF Msg = WM_VSCROLL AND (wParam AND &h0000FFFE) = 4 THEN 'wParam AND ... is a quick way to test for SB_THUMBPOSITION(4) or SB_THUMBTRACK(5)
   ScrollInf.cbSize = SIZEOF(SCROLLINFO)
   ScrollInf.fMask  = SIF_ALL OR SIF_DISABLENOSCROLL
   GetScrollInfo(hListbox, SB_VERT, @ScrollInf)
   ScrollInf.nPos = ScrollInf.nTrackPos
   SetScrollInfo(hListbox, SB_VERT, @ScrollInf, TRUE) 'Fix scrollbar thumb position avoiding the Lisbox 16 bit engine.
   SendMessage(hListbox, LB_SETTOPINDEX, ScrollInf.nTrackPos, 0) 'Scroll listbox
 ELSE
   IF hListbox = 0 THEN pListboxProc = Cast(WndProc, wParam) 'Auto asign pListboxProc for later in WM_NCDESTROY
   IF Msg = WM_KEYDOWN And (wParam = VK_HOME Or wParam = VK_END) THEN
     ScrollInf.cbSize = SIZEOF(SCROLLINFO)
     ScrollInf.fMask  = SIF_POS 'HOME and END scrool half the way with 2,147,483,6460
     IF wParam = VK_HOME THEN ScrollInf.nPos = 0 ELSE ScrollInf.nPos = ListboxItemCount - 1
     SetScrollInfo(hListbox, SB_VERT, @ScrollInf, TRUE)
     SendMessage(hListbox, LB_SETTOPINDEX, ScrollInf.nPos, 0)
     EXIT FUNCTION
   END IF
   IF Msg = WM_NCDESTROY THEN SetWindowLongPtr(hListbox, GWLP_WNDPROC, Cast(LONG_PTR, pListboxProc)) 'Unsubclass listbox
   FUNCTION = CallWindowProc(pListboxProc, hListbox, Msg, wParam, lParam) 'Let the Listbox engine finish the work
 END IF

END FUNCTION
'_____________________________________________________________________________

Function WndProc(ByVal hWnd As HWND, ByVal uMsg As UINT, ByVal wParam As WPARAM, ByVal lParam As LPARAM) As Integer
 Static hFont            As HFONT
 Static hFontArialBlack  As HFONT
 Dim    hFontGenuine     As HFONT
 Static hListbox         As HWND
 Static hButtonExit      As HWND
 Dim    Even             As LONG

 Function = 0

 Select Case (uMsg)

   Case WM_CREATE
     'Get Windows default font
     Dim NotClientMetrics As NONCLIENTMETRICS
     NotClientMetrics.cbSize = SizeOf(NONCLIENTMETRICS)
     SystemParametersInfo(SPI_GETNONCLIENTMETRICS, NotClientMetrics.cbSize, @NotClientMetrics, 0)
     hFont = CreateFontIndirect(@NotClientMetrics.lfMessageFont)

     'Use a second font
     hFontArialBlack = MakeFontEx(0, "Arial Black", 9, 0, True, 0, 0, 0)

     'Button Exit
     hButtonExit = CreateWindowEx(0, "Button", "E&xit", _
                                  WS_CHILD Or WS_VISIBLE Or BS_CENTER Or WS_TABSTOP Or _
                                  BS_NOTIFY Or BS_TEXT Or BS_VCENTER, _
                                  10, 325, 205, 30, _
                                  hWnd, Cast(HMENU, ButtonExit), _
                                  hInstance, NULL)
     SendMessage(hButtonExit, WM_SETFONT, Cast(WPARAM, hFont), TRUE)

     'Listbox
     hListbox   = CreateWindowEx(WS_EX_CLIENTEDGE, "Listbox", "", _
                                 WS_CHILD OR WS_VISIBLE OR WS_TABSTOP OR LBS_OWNERDRAWFIXED OR _
                                 LBS_NODATA OR LBS_NOTIFY OR WS_TABSTOP OR WS_VSCROLL, _
                                 10, 10, 205, 310, _
                                 hWnd, Cast(HMENU, Listbox), _
                                 hInstance, NULL)
     SendMessage(hListbox, LB_SETCOUNT, Cast(UInteger, MAXLONG), 0) '34,463
     SendMessage(hListbox, WM_SETFONT, Cast(UInteger, hFont), TRUE)

     'Subclass listbox with a a one liner and no variables needed...
     ListboxProc(0, 0, SetWindowLongPtr(hListbox, GWLP_WNDPROC, Cast(LONG_PTR, ProcPtr(ListboxProc))), 0)

    Case WM_COMMAND
     Select Case LoWord(wParam)

       CASE Listbox
         IF HiWord(wParam) = LBN_SELCHANGE THEN
           SetWindowText(hWnd, "Index is " & STR$(SendMessage(hListbox, LB_GETCURSEL, 0, 0)))
         END IF

        Case ButtonExit, IDCANCEL
          If HiWord(wParam) = BN_CLICKED Then
            PostMessage(hWnd, WM_CLOSE, 0, 0)
            Exit Function
          EndIf

     End Select

   Case WM_DRAWITEM
     If wParam = Listbox Then
       Dim pDrawItemStructure AS DRAWITEMSTRUCT Pointer
       pDrawItemStructure = Cast(pDRAWITEMSTRUCT, lParam)

       If pDrawItemStructure->itemID <> &HFFFFFFFF THEN 'Is list is empty?
         Even = (pDrawItemStructure->itemID And 1) 'A simple Odd/Even flip-flop for the demo
         If (pDrawItemStructure->itemAction = ODA_DRAWENTIRE) OR (pDrawItemStructure->itemAction = ODA_SELECT) Then
           If (pDrawItemStructure->itemState AND ODS_SELECTED) = False Then                                          'Not selected
             If Even Then                                                                                            '  Even colors
               FillRect(pDrawItemStructure->hDC, @pDrawItemStructure->rcItem, GetSysColorBrush(COLOR_ACTIVECAPTION)) '    Cls
               SetBkColor(pDrawItemStructure->hDC, GetSysColor(COLOR_ACTIVECAPTION))                                 '    Text background
               SetTextColor(pDrawItemStructure->hDC, GetSysColor(COLOR_INFOBK))                                      '    Text color
             Else                                                                                                    '  Odd color
               FillRect(pDrawItemStructure->hDC, @pDrawItemStructure->rcItem, GetSysColorBrush(COLOR_WINDOW))        '    Cls
               SetBkColor(pDrawItemStructure->hDC, GetSysColor(COLOR_WINDOW))                                        '    Text background
               SetTextColor(pDrawItemStructure->hDC, GetSysColor(COLOR_WINDOWTEXT))                                  '    Text color
             EndIf
           Else                                                                                                      'Selected
             FillRect(pDrawItemStructure->hDC, @pDrawItemStructure->rcItem, GetSysColorBrush(COLOR_HIGHLIGHT))       'Cls
             SetBkColor(pDrawItemStructure->hDC, GetSysColor(COLOR_HIGHLIGHT))                                       'Text background
             SetTextColor(pDrawItemStructure->hDC, GetSysColor(COLOR_HIGHLIGHTTEXT))                                 'Text color
           EndIf

           'Draw some text
           Dim sElement AS WSTRING * 50
           sElement = "Element " & FORMAT(pDrawItemStructure->itemID, "#,")
           If Even Then hFontGenuine = SelectObject(pDrawItemStructure->hDC, hFontArialBlack)
           DrawText(pDrawItemStructure->hDC, Cast(LPCTSTR, STRPTR(sElement)), _
                    LEN(sElement), @pDrawItemStructure->rcItem, DT_SINGLELINE OR DT_LEFT OR DT_VCENTER)
           If Even Then SelectObject(pDrawItemStructure->hDC, hFontGenuine)

           'Draw grid lines
           Dim hPen As HPEN
           hPen = SelectObject(pDrawItemStructure->hDC, CreatePen(PS_SOLID, 1, GetSysColor(COLOR_3DFACE)))
           MoveToEx(pDrawItemStructure->hDC, 0, pDrawItemStructure->rcItem.Bottom - 1, BYVAL NULL)
           LineTo(pDrawItemStructure->hDC, pDrawItemStructure->rcItem.Right, pDrawItemStructure->rcItem.Bottom - 1)
           DeleteObject(SelectObject(pDrawItemStructure->hDC, hPen))
           Function = TRUE
         END IF

       END IF
     END IF

   Case WM_SIZE
     If wParam <> SIZE_MINIMIZED Then
       Dim As LONG SizeX = LOWORD(LPARAM)
       Dim As LONG SizeY = HIWORD(LPARAM)
       MoveWindow(hListbox, 10, 10, SizeX - 20, SizeY - 50, TRUE)
       MoveWindow(hButtonExit, 10, SizeY - 35, SizeX - 20, 30, TRUE)
     End IF

   Case WM_DESTROY
     DeleteObject(hFont)
     DeleteObject(hFontArialBlack)
     PostQuitMessage(0)
     Exit Function

 End Select

 Function = DefWindowProc(hWnd, uMsg, wParam, lParam)

End Function
'_____________________________________________________________________________

Function WinMain(ByVal hInstance As HINSTANCE, ByVal hPrevInst As HINSTANCE, _
                 ByVal CmdLine As WString Ptr, ByVal CmdShow As Integer) As UINT
 Dim wsAppName  As WString * 128
 Dim WinClass   As WNDCLASS
 Dim WindowSize As SIZEL
 Dim hWnd       As HWND
 Dim wMsg       As MSG

 wsAppName              = AppName & " - " & SizeOf(UInteger) * 8
 WindowSize.cx          = 240
 WindowSize.cy          = 390
 WinClass.hIcon         = ExtractIcon(hInstance, "%SystemRoot%\system32\shell32.dll", 293)
 WinClass.style         = CS_HREDRAW Or CS_VREDRAW
 WinClass.lpfnWndProc   = ProcPtr(WndProc)
 WinClass.cbClsExtra    = 0
 WinClass.cbWndExtra    = 0
 WinClass.hInstance     = hInstance
 WinClass.hCursor       = LoadCursor(NULL, IDC_ARROW)
 WinClass.hbrBackground = Cast(HGDIOBJ, COLOR_BTNFACE + 1) 'Default color
 WinClass.lpszMenuName  = NULL
 WinClass.lpszClassName = @wsAppName

 If (RegisterClass(@WinClass)) Then
   hWnd = CreateWindowEx(WS_EX_WINDOWEDGE, _
                         wsAppName, wsAppName, _
                         WS_OVERLAPPED OR WS_CLIPCHILDREN Or WS_DLGFRAME Or WS_BORDER Or WS_VISIBLE Or WS_CAPTION Or _
                         WS_MAXIMIZEBOX Or WS_MINIMIZEBOX Or WS_SIZEBOX Or WS_SYSMENU , _
                         (GetSystemMetrics(SM_CXSCREEN) - WindowSize.cx) / 2, _ 'PosX screen center
                         (GetSystemMetrics(SM_CYSCREEN) - WindowSize.cy) / 2, _ 'PosY screen center
                         WindowSize.cx, WindowSize.cy, _ 'SizeX, SizeY
                         NULL, NULL, hInstance, NULL)

   ShowWindow(hWnd, SW_SHOW)
   UpdateWindow(hWnd)

   While GetMessage(@wMsg, ByVal NULL, 0, 0) > 0
     If IsDialogMessage(hWnd, @wMsg) = 0 Then
       TranslateMessage(@wMsg)
       DispatchMessage(@wMsg)
     End If
   Wend

  End If
  DestroyIcon(WinClass.hIcon)
  Function = wMsg.message

End Function
'_____________________________________________________________________________

End WinMain(hInstance, NULL, Command(), SW_NORMAL) 'Call main() and return the error code to the OS
'_____________________________________________________________________________
'
« Last Edit: June 09, 2018, 07:57:22 PM by Pierre Bellisle »
Logged

raymw

  • FireFly3 User
  • Junior FireFly Member
  • *
  • Posts: 105
Re: list box limits
« Reply #18 on: June 14, 2018, 04:35:56 PM »

Thanks Pierre, Looks interesting and useful. Once I've sorted out my current bugs features I'll maybe look and see if I can incorporate some colour changes to selected text.
Logged
Pages: 1 [2]