Credit to whoever wrote this originally (wasn't me).
Include this, then just call CreateMultiColumnListBox() which returns a TGadget.
Private
Extern "win32"
Function SendMessage:Int(hWnd:Int,MSG:Int,wParam:Int,lParam:Int) = "SendMessageA@16"
Function SetWindowLong:Int(hWnd:Int,nIndex:Int,lNewLong:Int) = "SetWindowLongA@12"
Function GetWindowLong:Int(hWnd:Int, nIndex:Int) = "GetWindowLongA@8"
Function CallWindowProc:Int(lpPrevWndFunc, hWnd, uMsg, wParam, lParam) = "CallWindowProcA@20"
End Extern
Const LBS_NOTIFY:Int = $1
Const LBS_SORT:Int = $2
Const LBS_NOREDRAW:Int = $4
Const LBS_MULTIPLESEL:Int = $8
Const LBS_OWNERDRAWFIXED:Int = $10
Const LBS_OWNERDRAWVARIABLE:Int = $20
Const LBS_HASSTRINGS:Int = $40
Const LBS_USETABSTOPS:Int = $70
Const LBS_NOINTEGRALHEIGHT:Int = $100
Const LBS_MULTICOLUMN:Int = $200
Const LBS_WANTKEYBOARDINPUT:Int = $400
Const LBS_EXTENDEDSEL:Int = $800
Const LBS_DISABLENOSCROLL:Int = $100
Const LBS_NODATA:Int = $2000
Const LBS_NOSEL:Int = $4000
Const LBS_STANDARD:Int = $a00003
Const LVM_FIRST:Int = $1000
Const LVM_GETITEMA:Int = (LVM_FIRST+5)
Const LVM_SETITEMA:Int = (LVM_FIRST+6)
Const LVM_INSERTITEMA:Int = (LVM_FIRST+7)
Const LVM_DELETEITEM:Int = (LVM_FIRST+8)
Const LVM_DELETEALLITEMS:Int = (LVM_FIRST+9)
Const LVM_GETCALLBACKMASK:Int = (LVM_FIRST+10)
Const LVM_SETCALLBACKMASK:Int = (LVM_FIRST+11)
Const LVM_GETCOLUMNA:Int = (LVM_FIRST+25)
Const LVM_SETCOLUMNA:Int = (LVM_FIRST+26)
Const LVM_INSERTCOLUMNA:Int = (LVM_FIRST+27)
Const LVM_DELETECOLUMN:Int = (LVM_FIRST+28)
Const LVM_GETCOLUMNWIDTH:Int = (LVM_FIRST+29)
Const LVM_SETCOLUMNWIDTH:Int = (LVM_FIRST+30)
Const LVM_GETTEXTCOLOR:Int = (LVM_FIRST+35)
Const LVM_SETTEXTCOLOR:Int = (LVM_FIRST+36)
Const LVM_GETTEXTBKCOLOR:Int = (LVM_FIRST+37)
Const LVM_SETTEXTBKCOLOR:Int = (LVM_FIRST+38)
Const LVM_SORTITEMS:Int = (LVM_FIRST+48)
Const LVM_SETLISTBOXEXSTYLE:Int = (LVM_FIRST+54)
Const LVM_GETITEMW:Int = (LVM_FIRST+75)
Const LVM_SETITEMW:Int = (LVM_FIRST+76)
Const LVM_INSERTITEMW:Int = (LVM_FIRST+77)
Const LVM_GETCOLUMNW:Int = (LVM_FIRST+95)
Const LVM_SETCOLUMNW:Int = (LVM_FIRST+96)
Const LVM_INSERTCOLUMNW:Int = (LVM_FIRST+97)
Const LVS_EX_GRIDLINES:Int = $1
Const LVS_EX_SUBITEMIMAGES:Int = $2
Const LVS_EX_CHECKBOXES:Int = $4
Const LVS_EX_TRACKSELECT:Int = $8
Const LVS_EX_HEADERDRAGDROP:Int = $10
Const LVS_EX_FULLROWSELECT:Int = $20
Const LVS_EX_ONECLICKACTIVATE:Int = $40
Const LVS_EX_TWOCLICKACTIVATE:Int = $80
Const LVS_EX_FLATSB:Int = $100
Const LVS_EX_REGIONAL:Int = $200
Const LVS_EX_INFOTIP:Int = $400
Const LVS_EX_UNDERLINEHOT:Int = $800
Const LVS_EX_UNDERLINECOLD:Int = $1000
Const LVS_EX_MULTIWORKAREAS:Int = $2000
Const LVS_EX_LABELTIP:Int = $4000
Const LVS_EX_BORDERSELECT:Int = $8000
Const LVS_EX_DOUBLEBUFFER:Int = $10000
Const LVS_EX_HIDELABELS:Int = $20000
Const LVS_EX_SINGLEROW:Int = $40000
Const LVS_EX_SNAPTOGRID:Int = $80000
Const LVS_EX_SIMPLESELECT:Int = $100000
Const LVCF_FMT:Int = $1
Const LVCF_WIDTH:Int = $2
Const LVCF_TEXT:Int = $4
Const LVCF_SUBITEM:Int = $8
Const LVCF_IMAGE:Int = $10
Const LVCF_ORDER:Int = $20
Const LVIF_TEXT:Int = $1
Const LVIF_IMAGE:Int = $2
Const LVIF_PARAM:Int = $4
Const LVIF_STATE:Int = $8
Const LVIF_INDENT:Int = $10
Const LVIF_GROUPID:Int = $100
Const LVIF_COLUMNS:Int = $200
Const LVIF_NORECOMPUTE:Int = $800
Const LVIF_DI_SETITEM:Int = $1000
Const LVS_ALIGNTOP:Int = $0
Const LVS_ICON:Int = $0
Const LVS_REPORT:Int = $1
Const LVS_SMALLICON:Int = $2
Const LVS_LIST:Int = $3
Const LVS_TYPEMASK:Int = $3
Const LVS_SINGLESEL:Int = $4
Const LVS_SHOWSELALWAYS:Int = $8
Const LVS_SORTASCENDING:Int = $10
Const LVS_SORTDESCENDING:Int = $20
Const LVS_SHAREIMAGELISTS:Int = $40
Const LVS_NOLABELWRAP:Int = $80
Const LVS_AUTOARRANGE:Int = $100
Const LVS_EDITLABELS:Int = $200
Const LVS_OWNERDRAWFIXED:Int = $400
Const LVS_ALIGNLEFT:Int = $800
Const LVS_ALIGNMASK:Int = $C00
Const LVS_NOSCROLL:Int = $2000
Const LVS_NOCOLUMNHEADER:Int = $4000
Const LVS_NOSORTHEADER:Int = $8000
Const LVS_TYPESTYLEMASK:Int = $FC00
Const GWL_STYLE:Int = -$10
Const HDN_ITEMCLICK:Int = -302
Const GWL_WNDPROC:Int = -4
Const WM_NOTIFY = 78
Const HDN_ITEMCLICKW = -322
Type LVCOLUMN
Field mask:Int
Field fmt:Int
Field cx:Int
Field pszText:Byte Ptr
Field cchTextMax:Int
Field iSubItem:Int
EndType
Type LVITEM
Field mask:Int
Field iItem:Int
Field iSubItem:Int
Field iState:Int
Field stateMask:Int
Field pszText:Byte Ptr
Field cchTextMax:Int
Field iImage:Int
Field lParam:Byte Ptr
Field iIndent:Int
Field iGroupId:Int
Field cColumns:Int
Field puColumns:Int
EndType
Type HD_NOTIFY
'Field hdr:Byte Ptr ' NMHDR
Field hwndFrom
Field idFrom
Field code
Field iItem
Field iButton
Field pitem
EndType
Type LVWSORT
Field hWndListView:Int ' Fensterhandle des ListView-Controls
Field SortKey:Int ' Spalte, die sortiert werden soll
Field SortType:Int ' Typ der zu sortierenden Daten
Field SortOrder:Int ' Sortierrichtung
End Type
Const lvwAscending:Int = 0 ' Aufsteigende Sortierung
Const lvwDescending:Int = 1 ' Absteigende Sortierung
Const stString:Int = 1 ' Stringsortierung
Const stDate:Int = 2 ' Datensortierung
Const stNumeric:Int = 3 ' Zahlensortierung
Const LVM_FINDITEM:Int = (LVM_FIRST + 13)
Const LVFI_PARAM:Int = $1
Type POINTAPI ' ben�tigt f�r LV_FINDINFO
Field x:Int
Field y:Int
End Type
Type LV_FINDINFO
Field flags:Int
Field psz:String
Field lParam:Int
Field pt:POINTAPI
Field vkDirection:Long
End Type
Const LVM_GETITEMTEXT:Int = (LVM_FIRST + 45)
Public
Function AddListBoxColumn(ListBox:TGadget, ColumnNr:Int, Width:Int)
Local ListBoxHwnd:Int = QueryGadget(ListBox,QUERY_HWND)
Local Column:LVColumn = New LVColumn
Column.mask = LVCF_WIDTH
Column.cx = Width
SendMessageA(ListBoxHwnd,LVM_INSERTCOLUMNA,ColumnNr,Int(Byte Ptr Column))
End Function
Function SetListBoxHeading(ListBox:TGadget,ColumnNr:Int,HeadingText:String,Style:Int=0)
Local ListBoxHwnd:Int = QueryGadget(ListBox,QUERY_HWND)
Local Column:LVColumn = New LVColumn
Column.mask = LVCF_TEXT | LVCF_FMT
Column.fmt = Style
Column.pszText = HeadingText.ToCString()
Local ListBoxStyle:Int = GetWindowLongA(ListBoxHwnd,GWL_STYLE)
If (ListBoxStyle & LVS_NOCOLUMNHEADER ) Then
ListBoxStyle = ListBoxStyle ~ LVS_NOCOLUMNHEADER
SetWindowLongA(ListBoxHwnd,GWL_STYLE,ListBoxStyle)
EndIf
SendMessageA(ListBoxHwnd,LVM_SETCOLUMNA,ColumnNr,Int(Byte Ptr Column))
End Function
Function SetListBoxColumnWidth(ListBox:TGadget,ColumnNr:Int,Width:Int)
Local ListBoxHwnd:Int = QueryGadget(ListBox,QUERY_HWND)
Local Column:LVColumn = New LVColumn
Column.mask = LVCF_WIDTH
Column.cx = Width
SendMessageA(ListBoxHwnd,LVM_SETCOLUMNA,ColumnNr,Int(Byte Ptr Column))
End Function
Function ModifyListBoxItem(ListBox:TGadget,RowNr:Int,ColumnNr:Int,Text:String)
Local ListBoxHwnd:Int = QueryGadget(ListBox,QUERY_HWND)
Local Item:LVItem = New LVItem
Item.mask = LVIF_TEXT
Item.iSubItem = ColumnNr
Item.iItem = RowNr
Item.pszText = Text.ToCString()
Item.cchTextMax = Text.Length+1
SendMessageA(ListBoxHwnd,LVM_SETITEMA,0,Int(Byte Ptr Item))
End Function
Function GetListBoxItemText:String(ListBox:TGadget,RowNr:Int,ColumnNr:Int)
Local ListBoxHwnd:Int = QueryGadget(ListBox,QUERY_HWND)
Local ReturnText:String
Local TextBank:TBank = CreateBank(1024)
Local Item:LVItem = New LVItem
Item.mask = LVIF_Text
Item.iSubItem = ColumnNr
Item.iItem = RowNr
Item.pszText = BankBuf(TextBank)
Item.cchTextMax = 255
SendMessageA(ListBoxHwnd,LVM_GETITEMA,0,Int(Byte Ptr Item))
If Item.pszText <> Null Then
ReturnText = ReturnText.FromCString(Item.pszText)
EndIf
Return ReturnText
End Function
Function SetListBoxExtendedStyle(ListBox:TGadget,Style:Int)
Local ListBoxHwnd:Int = QueryGadget(ListBox,QUERY_HWND)
SendMessageA(ListBoxHwnd,LVM_SETLISTBOXEXSTYLE,Style,Style)
End Function
Function SetListBoxMultiSelect(ListBox:TGadget, Enable:Byte = True)
Local ListBoxHwnd:Int = QueryGadget(ListBox,QUERY_HWND)
Local ListBoxStyle:Int = GetWindowLongA(ListboxHwnd,GWL_STYLE)
If Sgn(ListBoxStyle & LVS_SINGLESEL) = Enable Then
ListBoxStyle = ListBoxStyle ~ LVS_SINGLESEL
EndIf
SetWindowLongA(ListBoxHwnd,GWL_STYLE,ListBoxStyle)
End Function
Function SortListView:Int(ListBox:TGadget, SortKey:Int, SortType:Int = stString, SortOrder:Int = lvwAscending)
' -----------------------------------------------------
' �ffentlich aufzurufende Prozedur SortListView, die
' f�r die individuelle Sortierung einer ListView-Spalte
' sorgt.
' -----------------------------------------------------
' hWndListView: Fensterhandle des ListView-Steuerelements
' SortKey: Spalte (nullbasiert), die sortiert werden
' soll (= Spaltennummer - 1).
' SortType: stString, um Strings zu sortieren (Standardwert)
' stDate, um Datumsangaben zu sortieren
' stNumeric, um Zahlen zu sortieren
' SortOrder: lvwAscending f�r aufsteigende Sortierung (Std.)
' lvwDescending f�r absteigende Sortierung
' -----------------------------------------------------
' �bergebene Informationen in einer LVWSORT-
' Struktur zusammenfassen:
Local udtLVWSORT:LVWSORT = New LVWSORT
udtLVWSORT.hWndListView = QueryGadget(ListBox, QUERY_HWND)
udtLVWSORT.SortKey = SortKey
udtLVWSORT.SortOrder = SortOrder
udtLVWSORT.SortType = SortType
' Eigene Sortierfunktionalit�t in der Funktion
' CompareFunc verwenden: Die Informationen der
' LVWSORT-Struktur wird mithilfe eines Zeigers
' auf die Variable udtLVWSORT beigegeben:
SendMessage QueryGadget(ListBox, QUERY_HWND), LVM_SORTITEMS, Int(Byte Ptr(udtLVWSORT)), Int(Byte Ptr(CompareFunc))
End Function
Function CompareFunc:Int(lParam1:Int, lParam2:Int, lParamSort:Int)
' -----------------------------------------------------
' Vergleichsfunktion CompareFunc
' -----------------------------------------------------
' Verglichen werden jeweils zwei Elemente der zu
' sortierenden Spalte des ListView-Steuerelements,
' die �ber lParam1 und lParam2 angegeben werden.
' Hierbei wird �ber den R�ckgabewert der Funktion
' bestimmt, welches der beiden Elemente als gr��er
' gelten soll (hier f�r Aufw�rtssortierung):
' * Element 1 < Element 2: R�ckgabewert < 0
' * Element 1 = Element 2: R�ckgabewert = 0
' * Element 1 > Element 2: R�ckgabewert > 0
' -----------------------------------------------------
Local ListViewSort:LVWSORT = New LVWSORT
Local sEntry1:String
Local sEntry2:String
Local vCompare1:VARIANT
Local vCompare2:VARIANT
' In lParamSort von SortListView als Long-Pointer
' �bergebene LVWSORT-Struktur abholen, um auf deren
' Werte zugreifen zu k�nnen:
MemCopy(Byte Ptr(ListViewSort), Byte Ptr(lParamSort), SizeOf(ListViewSort))
' Die Werte der zu vergleichenden Elemente werden
' mithilfe der privaten Funktion LvwGetText aus
' den Angaben lParam1 und lParam2 ermittelt:
sEntry1 = LvwGetText(ListViewSort, lParam1)
sEntry2 = LvwGetText(ListViewSort, lParam2)
DebugLog sEntry1 + " " + sEntry2
' Sind die Elemente gleich, kann die Funktion
' sofort mit dem aktuellen R�ckgabewert 0
' verlassen werden:
If sEntry1 = sEntry2 Then
Return
End If
' F�r die Sortierung wird unterschieden zwischen
' Daten, Zahlen und allgemeinen Strings. Hierf�r
' steht jeweils eine separate, private Vergleichs-
' funktion zur Verf�gung.
Select ListViewSort.SortType
Case stDate ' Spalteninhalte sind Datumswerte
'CompareFunc = CompareDates(sEntry1, sEntry2, ListViewSort.SortOrder)
Case stNumeric ' Spalteninhalte sind Zahlen
'CompareFunc = CompareNumbers(sEntry1, sEntry2, ListViewSort.SortOrder)
Case stString ' Spalteninhalte sind Strings
Local CompareFunc:Int = CompareStrings(sEntry1, sEntry2, ListViewSort.SortOrder)
End Select
End Function
Function LvwGetText:String(ListViewSort:LVWSORT, lParam:Int)
' -----------------------------------------------------
' Ermittelt aus dem Fensterhandle des ListView-
' Steuerelements, der in ListViewSort.SortKey
' angegebenen (nullbasierten) Spalte im ListView
' und der an CompareFunc �bergebenen Werte lParam1/2
' die davon repr�sentierten Zelleninhalte.
' -----------------------------------------------------
Local udtFindInfo:LV_FINDINFO = New LV_FINDINFO
Local udtLVItem:LVITEM = New LVITEM
Local lngIndex:Int
'Local baBuffer:Byte[512]
Local TextBank:TBank = CreateBank(1024)
Local lngLength:Int
Local ReturnText:String
' Den Index der Zelle aus lParam ermitteln:
udtFindInfo.flags = LVFI_PARAM
udtFindInfo.lParam = lParam
lngIndex = SendMessage(ListViewSort.hWndListView, LVM_FINDITEM, - 1, Int(Byte Ptr(udtFindInfo)))
' Auf Basis des gefundenen Index den Text der Zelle
' in ein Byte-Array �bertragen:
udtLVItem.mask = LVIF_TEXT
udtLVItem.iSubItem = ListViewSort.SortKey
udtLVItem.pszText = BankBuf(TextBank)
'Int(VarPtr(baBuffer[0] ))
udtLVItem.cchTextMax = 255
'lngLength = SendMessage(ListViewSort.hWndListView, LVM_GETITEMTEXT, lngIndex, Int(Byte Ptr(udtLVItem)))
' Byte-Array in passender L�nge als String-
' R�ckgabewert kopieren:
If lngLength > 0 Then
ReturnText = ReturnText.FromCString(udtLVItem.pszText)
DebugLog lngLength + " " + ReturnText
Return ReturnText
'LvwGetText = Left:String(StrConv(baBuffer, vbUnicode), lngLength)
End If
End Function
Function CompareStrings:Int(sEntry1:String, sEntry2:String, SortOrder:Int)
' -----------------------------------------------------
' Gibt zurück, ob das erste der beiden unterschiedlichen
' Elemente nach Maßgabe des Parameters SortOrder größer
' (1 bei aufsteigender Sortierung) oder kleiner (-1 bei
' aufsteigender Sortierung) als das zweite Element ist.
' Gleiche Elemente wurden bereits in CompareFunc ausge-
' schlossen; für sie wäre sonst 0 zurückzugeben.
' -----------------------------------------------------
' Rückgabewert je nach erwünschter Sortierung:
If SortOrder = lvwAscending Then
' Aufsteigende Sortierung zweier unterschiedlicher Strings
If sEntry1 < sEntry2 Then
Return - 1
Else
Return 1
End If
Else ' Absteigende Sortierung
If sEntry1 > sEntry2 Then
Return - 1
Else
Return 1
End If
End If
End Function
Type TMultiColumnListBox Extends TProxyGadget
Global list:TList=New TList
Field link:TLink
Field oldListProc:Int
Field listbox:TGadget
Method New()
link=list.addlast(Self)
EndMethod
Method CleanUp()
If link
link.remove()
link=Null
EndIf
Super.CleanUp()
EndMethod
Function NewListProc:Int(hWnd:Int, Msg:Int, wParam:Int, lParam:Int) "win32"
If MSG = WM_NOTIFY Then
Local NotifyMess:HD_NOTIFY = New HD_NOTIFY
MemCopy(Byte Ptr(NotifyMess), Byte Ptr(lParam), SizeOf(HD_NOTIFY))
'DebugLog "hwndFrom " + NotifyMess.hwndFrom
'DebugLog "idFrom " + NotifyMess.idFrom
'DebugLog "code " + NotifyMess.code
'DebugLog "iItem " + NotifyMess.iitem
'DebugLog "iButton " + NotifyMess.iButton
'DebugLog "pitem " + NotifyMess.pitem
If NotifyMess.code = HDN_ITEMCLICKW Then
Local event:TEvent = New TEvent
event.id = HDN_ITEMCLICKW
event.source = ActiveGadget()
event.data = NotifyMess.iitem
PostEvent(event)
'DebugLog(NotifyMess.iitem)
EndIf
EndIf
Local multicolumnlistbox:TMultiColumnListBox
For multicolumnlistbox=EachIn TMultiColumnListBox.list
If QueryGadget(multicolumnlistbox.ListBox, QUERY_HWND)=hWnd
If multicolumnlistbox.oldListProc <> 0 Then
' DebugLog "MSG: " + MSG
' DebugLog "hWnd: " + hwnd
' DebugLog "wParam: " + wParam
' DebugLog "lParam: " + lParam
Return CallWindowProc(multicolumnlistbox.oldListProc, hWnd, MSG, wParam, Int(Byte Ptr(lParam)))
EndIf
EndIf
Next
End
EndFunction
Function Create:TMultiColumnListBox(x:Int,y:Int,width:Int,height:Int,group:TGadget,flags:Int=0)
Local multicolumnlistbox:TMultiColumnListBox=New TMultiColumnListBox
multicolumnlistbox.listbox=CreateListBox(x,y,width,height,group)
multicolumnlistbox.SetProxy(multicolumnlistbox.listbox)
multicolumnlistbox.oldListProc=SetWindowLongA(QueryGadget(multicolumnlistbox.ListBox, QUERY_HWND), GWL_WNDPROC, Int(Byte Ptr(NewListProc)))
Return multicolumnlistbox
EndFunction
EndType
Function CreateMultiColumnListBox:TGadget(x:Int,y:Int,width:Int,height:Int,group:TGadget,flags:Int=0)
Return TMultiColumnListBox.Create(x,y,width,height,group,flags)
EndFunction
|