PureBoard

Das deutsche PureBasic-Forum
https://www.purebasic.fr/german/

Nutzt jemand die PureLVSort Lib?

https://www.purebasic.fr/german/viewtopic.php?t=29211

Seite 3 von 4

Re: Nutzt jemand die PureLVSort Lib?

Verfasst: 21.10.2015 12:30
von dige
Ich habe das mal quick & dirty eingebaut und bekomme aber eine Laufzeitfehlermeldung.
Was mache ich falsch? Ich befürchte, das ich das mit den Modulen nicht so richtig kapiert habe :freak:

Code: Alles auswählen

; ==================================================================================================
; --- ListIconGadget Extras & Sort
; --- ----------------------------------------------------------------------------------------------
; --- File            : module_nalorLIG.pbi
; --- OriginalAuthor  : nalor
; --- modified        : bisonte (change to new module system of pb)
; --- Link            : http://purebasic.fr/english/viewtopic.php?f=12&t=55085   
; --- Date            : June 23, 2013
; --- Compiler        : PureBasic 5.20b2 (Windows - x64)
; --- Target OS       : Windows
; --- Version         : 1.0a
; ==================================================================================================
; --- Module : nalorLIG
; --- Remark : If WindowsXP is used - Disable Debugger or use Unicode Flag only

CompilerIf #PB_Compiler_Version => 520
  
  EnableExplicit
  
  CompilerIf #PB_Compiler_OS <> #PB_OS_Windows
    MessageRequester("PureBasic", "Windows only! Sorry.") : End
  CompilerEndIf
  
  DeclareModule nalorLIG
  
  ; --- Original by : nalor
  ; --- Link        : http://purebasic.fr/english/viewtopic.php?f=12&t=55085   
  ; --- mod.by      : bisonte (change to module) - 23.06.2013
  
  Enumeration ; Type of Column Sort
    #SortString
    #SortNumeric
    #SortFloat
    #SortDate
    #SortAutoDetect
  EndEnumeration
  Enumeration ; Column Sort States
    #NoSort   ; keine Sortierung
    #AscSort  ; Aufsteigende Sortierung
    #DescSort ; Absteigende Sortierung
  EndEnumeration
  
  Structure LVWSORT
    hWndListView.i ; Fensterhandle des ListView-Controls
    SortKey.i ; Spalte, die sortiert werden soll
    SortType.b ; Typ der zu sortierenden Daten
    SortOrder.b ; Sortierrichtung
    DateFormat.s ; Mask for 'ParseDate'
  EndStructure
  
  Declare   AlignColumn(gadget, Index, Format)
  Declare   SetColumnWidth(gadget, Index, New_Width)
  Declare   SetSortIcon(gadget, Column, SortOrder)
  Declare.b GetSortOrder(gadget, Column)
  Declare   EnsureVisible(gadget, Line)
  
  Declare   Enable(GadgetID)
  
  EndDeclareModule
  Module        nalorLIG
  
  
  Import ""
    GetProcAddress(hmod, s.p-ascii)
  EndImport
  
  Prototype pSetWindowSubclass(hwnd, *Proc, *Id, *RefData)
  Prototype pDefSubclassProc(hwnd, msg, wParam, lParam)
  Prototype pRemoveWindowSubclass(hwnd, *Proc, *Id)
  Prototype pGetWindowSubclass(hwnd, *Proc, *Id, *RefData)
  
  ;https://msdn.microsoft.com/de-de/library/windows/desktop/bb776430(v=vs.85).aspx
  Procedure SetWindowSubclass(hwnd, *Proc, *Id, *RefData)
    Protected Comctl32 = GetModuleHandle_("Comctl32.dll")   
    Protected func.pSetWindowSubclass = GetProcAddress(Comctl32, "SetWindowSubclass")
    ProcedureReturn func(hwnd, *Proc, *Id, *RefData)
  EndProcedure
  
  ;https://msdn.microsoft.com/de-de/library/windows/desktop/bb776403(v=vs.85).aspx
  Procedure DefSubclassProc(hwnd, msg, wParam, lParam)
    Protected Comctl32 = GetModuleHandle_("Comctl32.dll")
    Protected func.pDefSubclassProc = GetProcAddress(Comctl32, "DefSubclassProc")
    ProcedureReturn func(hwnd, msg, wParam, lParam)
  EndProcedure
  
  ;https://msdn.microsoft.com/de-de/library/windows/desktop/bb762094(v=vs.85).aspx
  Procedure RemoveWindowSubclass(hwnd, *Proc, *Id)
    Protected Comctl32 = GetModuleHandle_("Comctl32.dll")
    Protected func.pRemoveWindowSubclass = GetProcAddress(Comctl32, "RemoveWindowSubclass")
    ProcedureReturn func(hwnd, *Proc, *Id)
  EndProcedure
  
  ;https://msdn.microsoft.com/de-de/library/windows/desktop/bb776430(v=vs.85).aspx
  Procedure GetWindowSubclass(hwnd, *Proc, *Id, *RefData)
    Protected Comctl32 = GetModuleHandle_("Comctl32.dll")
    Protected func.pGetWindowSubclass = GetProcAddress(Comctl32, "GetWindowSubclass")
    ProcedureReturn func(hwnd, *Proc, *Id, *RefData)
  EndProcedure
  
  
  
  
  ; --- Original by : nalor
  ; --- Link        : http://purebasic.fr/english/viewtopic.php?f=12&t=55085   
  ; --- mod.by      : bisonte (change to module) - 23.06.2013
  
  Procedure   GethWnd(id)
    
    Protected hWnd = #False
    
    If IsGadget(ID)
      hWnd = GadgetID(ID)
    Else
      If IsWindow_(ID)
        hWnd = ID
      EndIf
    EndIf
    
    ProcedureReturn hWnd
    
  EndProcedure
  
  ;- ++++++ ListIconGadget Tools Start ++++++
  
  Procedure   AlignColumn(gadget, Index, Format)
    
    ; by Danilo, 15.12.2003 - english chat (for 'Karbon')
    ; 20130615..nalor..modified
    ; change text alignment for columns
    ; #LVCFMT_LEFT / #LVCFMT_CENTER / #LVCFMT_RIGHT
    
    Protected lvc.LV_COLUMN, hWnd = GethWnd(Gadget)
    
    If hWnd
      
      lvc\mask = #LVCF_FMT
      lvc\fmt = Format
      
      SendMessage_(hWnd, #LVM_SETCOLUMN, Index, @lvc)
      
      ProcedureReturn #True
      
    EndIf
    
    ProcedureReturn #False
    
  EndProcedure
  Procedure   SetColumnWidth(gadget, Index, New_Width)
    
    ; by Danilo, 15.12.2003 - english chat (for 'Karbon')
    ;
    ; change column header width
    ;
    
    Protected hWnd = GethWnd(Gadget)
    
    If hWnd
      
      SendMessage_(hWnd, #LVM_SETCOLUMNWIDTH, Index, New_Width)
      ProcedureReturn #True
      
    EndIf
    
    ProcedureReturn #False
    
  EndProcedure
  Procedure   SetSortIcon(gadget, Column, SortOrder)
    
    ; http://stackoverflow.com/questions/254129/how-To-i-display-a-sort-arrow-in-the-header-of-a-List-view-column-using-c   
    
    Protected ColumnHeader
    Protected ColumnCount
    Protected hditem.HD_ITEM
    Protected Cnt
    Protected hWnd = GethWnd(Gadget)
    
    If hWnd
      
      ColumnHeader = SendMessage_(hWnd, #LVM_GETHEADER, 0, 0)
      ColumnCount  = SendMessage_(ColumnHeader, #HDM_GETITEMCOUNT, 0, 0)
      
      For Cnt = 0 To ColumnCount - 1
        
        hditem\mask=#HDI_FORMAT
        
        If SendMessage_(ColumnHeader, #HDM_GETITEM, Cnt, @hditem) = 0
          Debug "ERROR! LIG_SetSortIcon 1"
        EndIf
        
        hditem\mask=#HDI_FORMAT
        
        If (Cnt = Column And SortOrder <> #NoSort)
          
          Select SortOrder
              
            Case #AscSort ; wenn aufsteigend sortiert werden soll
              hditem\fmt& ~#HDF_SORTDOWN
              hditem\fmt|#HDF_SORTUP
              Debug "sortup"
              
            Case #DescSort
              hditem\fmt& ~#HDF_SORTUP
              hditem\fmt|#HDF_SORTDOWN               
              Debug "sortdown"
              
          EndSelect
          
        Else
          
          hditem\fmt& ~#HDF_SORTUP
          hditem\fmt& ~#HDF_SORTDOWN
          
        EndIf
        
        If (SendMessage_(ColumnHeader, #HDM_SETITEM, Cnt, @hditem) = 0)
          Debug "ERROR! LIG_SetSortIcon 2"
        EndIf
        
      Next cnt
      
      ProcedureReturn #True
      
    EndIf
    
    ProcedureReturn #False
    
  EndProcedure
  Procedure.b GetSortOrder(gadget, Column)
    
    Protected ColumnHeader
    Protected hditem.HD_ITEM
    Protected RetVal.b = -1
    Protected hWnd = GethWnd(Gadget)
    
    If hWnd
      
      ColumnHeader = SendMessage_(hWnd, #LVM_GETHEADER, 0, 0)
      
      hditem\mask=#HDI_FORMAT
      
      If SendMessage_(ColumnHeader, #HDM_GETITEM, Column, @hditem)
        
        If (hditem\fmt&#HDF_SORTUP)=#HDF_SORTUP
          
          Debug "sortup"
          RetVal=#AscSort
          
        ElseIf (hditem\fmt&#HDF_SORTDOWN)=#HDF_SORTDOWN
          
          Debug "sortdown"
          RetVal=#DescSort
          
        Else
          
          Debug "keine sortierung"
          RetVal=#NoSort
          
        EndIf
        
      Else
        
        Debug "ERROR! LIG_GetSortOrder"
        RetVal=-1
        
      EndIf
      
    EndIf
    
    ProcedureReturn RetVal
    
  EndProcedure
  Procedure   EnsureVisible(gadget, Line)
    ; makes sure the line is visible
    
    Protected hWnd = GethWnd(Gadget)
    If hWnd
      SendMessage_(hWnd, #LVM_ENSUREVISIBLE, Line, #True)
      ProcedureReturn #True 
    EndIf
    ProcedureReturn #False
    
  EndProcedure
  
  ;- ##### ListIconGadget Tools Ende #####
  
  ;- ++++++ ListIconGadget Sort Start ++++++
  
  ; http://msdn.microsoft.com/de-de/library/bb979183.aspx   
  ; Die Struktur LVWSORT enthält Informationen über das zu sortierende ListView-Steuerelement, die Spalte,
  ; nach der sortiert werden soll, sowie die gewünschte Sortierrichtung.
  
  Procedure.b IsNumChar(*Text, Position = 1)
    Select Asc(PeekS(*Text+(Position-1)*SizeOf(Character), 1))
      Case 48 To 57
        ProcedureReturn #True
      Default
        ProcedureReturn #False
    EndSelect
  EndProcedure
  Procedure   CompareStrings(*sEntry1, *sEntry2, SortOrder.b)
    ; ' -----------------------------------------------------
    ; ' 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 = #AscSort
      ; Aufsteigende Sortierung zweier unterschiedlicher Strings
      If CompareMemoryString(*sEntry1, *sEntry2, #PB_String_NoCase) = #PB_String_Lower
        ProcedureReturn -1
      Else
        ProcedureReturn 1
      EndIf
    Else ; Absteigende Sortierung
      If CompareMemoryString(*sEntry1, *sEntry2, #PB_String_NoCase) = #PB_String_Greater
        ProcedureReturn -1
      Else
        ProcedureReturn 1
      EndIf
    EndIf
    
  EndProcedure
  Procedure   CompareNumbers(sEntry1.s, sEntry2.s, SortOrder.b)
    ; ' -----------------------------------------------------
    ; ' 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 = #AscSort
      ; Aufsteigende Sortierung zweier unterschiedlicher Zahlen
      If Val(sEntry1) < Val(sEntry2)
        ProcedureReturn -1
      Else
        ProcedureReturn 1
      EndIf
    Else ; Absteigende Sortierung
      If Val(sEntry1) > Val(sEntry2)
        ProcedureReturn -1
      Else
        ProcedureReturn 1
      EndIf
    EndIf
    
  EndProcedure
  Procedure   CompareFloat(sEntry1.s, sEntry2.s, SortOrder.b)
    ; ' -----------------------------------------------------
    ; ' 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:
    
    ReplaceString(sEntry1, ",", ".", #PB_String_InPlace, 1, 1) ; ersetze Dezimalkomma durch Punkt, damit ValF korrekt arbeitet
    ReplaceString(sEntry2, ",", ".", #PB_String_InPlace, 1, 1)
    
    If SortOrder = #AscSort
      ; Aufsteigende Sortierung zweier unterschiedlicher Zahlen
      If ValF(sEntry1) < ValF(sEntry2)
        ProcedureReturn -1
      Else
        ProcedureReturn 1
      EndIf
    Else ; Absteigende Sortierung
      If ValF(sEntry1) > ValF(sEntry2)
        ProcedureReturn -1
      Else
        ProcedureReturn 1
      EndIf
    EndIf         
    
  EndProcedure
  Procedure   CompareDate(sEntry1.s, sEntry2.s, SortOrder.b, sDateMask.s)
    ; ' -----------------------------------------------------
    ; ' 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 = #AscSort
      ; Aufsteigende Sortierung zweier unterschiedlicher Zahlen
      If ParseDate(sDateMask, sEntry1) < ParseDate(sDateMask, sEntry2)
        ProcedureReturn -1
      Else
        ProcedureReturn 1
      EndIf
    Else ; Absteigende Sortierung
      If ParseDate(sDateMask, sEntry1) > ParseDate(sDateMask, sEntry2)
        ProcedureReturn -1
      Else
        ProcedureReturn 1
      EndIf
    EndIf         
    
  EndProcedure
  Procedure.s LvwGetText(*ListViewSort.LVWSORT, lParam)
    ; ' -----------------------------------------------------
    ; ' 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.
    ; ' -----------------------------------------------------
    Protected udtFindInfo.LV_FINDINFO, udtLVItem.LV_ITEM
    Protected lngIndex, *baBuffer, lngLength, RetVal.s = ""
    
    *baBuffer = AllocateMemory(512)
    
    If *baBuffer
      
      ; Auf Basis des Index den Text der Zelle auslesen:
      udtLVItem\mask=#LVIF_TEXT
      udtLVItem\iSubItem=*ListViewSort\SortKey
      udtLVItem\pszText=*baBuffer
      udtLVItem\cchTextMax=(512/SizeOf(Character))-1
      
      lngLength = SendMessage_(*ListViewSort\hWndListView, #LVM_GETITEMTEXT, lParam, @udtLVItem)
      
      ; Byte-Array in passender Länge als String-Rückgabewert kopieren:
      
      If lngLength > 0
        RetVal = PeekS(*baBuffer, lngLength)
      EndIf
      FreeMemory(*baBuffer) ; thx LittleJohn
      
    EndIf
    
    ProcedureReturn RetVal
    
  EndProcedure
  Procedure   CompareFunc(lParam1, lParam2, lParamSort)
    ; ' -----------------------------------------------------
    ; ' 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
    ; ' -----------------------------------------------------
    Protected *ListViewSort.LVWSORT
    Protected sEntry1.s
    Protected sEntry2.s
    Protected vCompare1.s ; As Variant
    Protected vCompare2.s ; As Variant
    
    ; In lParamSort von SortListView als Long-Pointer übergebene LVWSORT-Struktur abholen, um auf deren
    ; Werte zugreifen zu können:
    
    *ListViewSort=lParamSort
    
    ; 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)
    
    ; Sind die Elemente gleich, kann die Funktion sofort mit dem aktuellen Rückgabewert 0
    ; verlassen werden:
    If sEntry1 = sEntry2
      ProcedureReturn 0
    EndIf
    
    ; Für die Sortierung wird unterschieden zwischen Zahlen, Fließkommazahlen und allgemeinen Strings. Hierfür
    ; steht jeweils eine separate, private Vergleichsfunktion zur Verfügung.
    
    Select *ListViewSort\SortType
      Case #SortNumeric ; ' Spalteninhalte sind Zahlen
        ProcedureReturn CompareNumbers(sEntry1, sEntry2, *ListViewSort\SortOrder)
      Case #SortFloat ; ' Spalteninhalte sind Zahlen mit Nachkommastellen
        ProcedureReturn CompareFloat(sEntry1, sEntry2, *ListViewSort\SortOrder)
      Case #SortString;  ' Spalteninhalte sind Strings
        ProcedureReturn CompareStrings(@sEntry1, @sEntry2, *ListViewSort\SortOrder)
      Case #SortDate
        ProcedureReturn CompareDate(sEntry1, sEntry2, *ListViewSort\SortOrder, *ListViewSort\DateFormat)
    EndSelect
  EndProcedure
  Procedure.s GetDateFormat(Date.s)
    
    Debug "GetDateFormat >"+Date+"<"
    
    Protected Diff.i
    
    Diff=Len(Date)-CountString(Date, "0")-CountString(Date, "1")-CountString(Date, "2")-CountString(Date, "3")-CountString(Date, "4")-CountString(Date, "5")-CountString(Date, "6")-CountString(Date, "7")-CountString(Date, "8")-CountString(Date, "9")   
    
    Select Diff
      Case 2
        If Len(Date)=10 ; Date 'dd.mm.yyyy', 'mm.dd.yyyy' or 'yyyy.mm.dd'
          
          If (Not IsNumChar(@Date, 5) And Not IsNumChar(@Date, 8)) ; yyyy.mm.dd
            ProcedureReturn "" ; faster to sort as string
            
          ElseIf (Not IsNumChar(@Date, 3) And Not IsNumChar(@Date, 6)) ; dd.mm.yyyy or mm.dd.yyyy
            If Val(Mid(Date, 4, 2))>12 ; is it mm.dd.yyyy?
              ProcedureReturn "%mm"+Mid(Date, 3, 1)+"%dd"+Mid(Date, 6, 1)+"%yyyy"
            Else ; default is dd.mm.yyyy
              ProcedureReturn "%dd"+Mid(Date, 3, 1)+"%mm"+Mid(Date, 6, 1)+"%yyyy"
            EndIf
            
          Else
            ProcedureReturn "" ; not a date - sort as string
          EndIf
        Else
          ProcedureReturn "" ; not a date - sort as string
        EndIf
        
      Case 4
        If Len(Date)=16 ;yyyy-mm-dd hh:mm, dd-mm-yyyy hh:mm or mm-dd-yyyy hh:mm
          
          If (Not IsNumChar(@Date, 5) And Not IsNumChar(@Date, 8)) ; yyyy.mm.dd xxxxx
            ProcedureReturn "" ; faster to sort as string
            
          ElseIf (Not IsNumChar(@Date, 3) And Not IsNumChar(@Date, 6)) ; dd.mm.yyyy hh:mm or mm.dd.yyyy hh:mm
            If Val(Mid(Date, 4, 2))>12 ; is it mm.dd.yyyy?
              ProcedureReturn "%mm"+Mid(Date, 3, 1)+"%dd"+Mid(Date, 6, 1)+"%yyyy"+Mid(Date, 11, 1)+"%hh"+Mid(Date, 14, 1)+"%mm"
            Else ; default is dd.mm.yyyy
              ProcedureReturn "%dd"+Mid(Date, 3, 1)+"%mm"+Mid(Date, 6, 1)+"%yyyy"+Mid(Date, 11, 1)+"%hh"+Mid(Date, 14, 1)+"%mm"
            EndIf
            
          Else
            ProcedureReturn "" ; not a date - sort as string
          EndIf
        Else
          ProcedureReturn "" ; not a date - sort as string
        EndIf           
        
      Case 5 ; 5 other chars, possibly DateTime?
        
        If Len(Date)=19 ;yyyy-mm-dd hh:mm, dd-mm-yyyy hh:mm or mm-dd-yyyy hh:mm
          
          If (Not IsNumChar(@Date, 5) And Not IsNumChar(@Date, 8)) ; yyyy.mm.dd xxxxx
            ProcedureReturn "" ; faster to sort as string
            
          ElseIf (Not IsNumChar(@Date, 3) And Not IsNumChar(@Date, 6)) ; dd.mm.yyyy hh:mm or mm.dd.yyyy hh:mm
            If Val(Mid(Date, 4, 2))>12 ; is it mm.dd.yyyy?
              ProcedureReturn "%mm"+Mid(Date, 3, 1)+"%dd"+Mid(Date, 6, 1)+"%yyyy"+Mid(Date, 11, 1)+"%hh"+Mid(Date, 14, 1)+"%mm"+Mid(Date, 17, 1)+"%ss"
            Else ; default is dd.mm.yyyy
              ProcedureReturn "%dd"+Mid(Date, 3, 1)+"%mm"+Mid(Date, 6, 1)+"%yyyy"+Mid(Date, 11, 1)+"%hh"+Mid(Date, 14, 1)+"%mm"+Mid(Date, 17, 1)+"%ss"
            EndIf
            
          Else
            ProcedureReturn "" ; not a date - sort as string
          EndIf
        Else
          ProcedureReturn "" ; not a date - sort as string
        EndIf
        
      Default
        ProcedureReturn ""
    EndSelect
    
  EndProcedure
  Procedure   SortListView(hWndListView, SortKey, SortType.b, SortOrder.b)
    ; ' -----------------------------------------------------
    ; ' Ö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
    ; ' -----------------------------------------------------
    
    Protected udtLVWSORT.LVWSORT
    Protected sDateFormat.s, sTemp.s, GadId.i
    
    If SortType = #SortDate
      GadId = GetDlgCtrlID_(hWndListView)
      sDateFormat = GetDateFormat(GetGadgetItemText(GadId, 0, SortKey))
      
      If sDateFormat = ""
        SortType = #SortString
      Else
        sTemp = GetDateFormat(GetGadgetItemText(GadId, CountGadgetItems(GadId)-1, SortKey))
        If sTemp=""
          SortType=#SortString
        Else
          If sTemp<>sDateFormat
            If Left(sTemp, 3)="%mm" ; new format starts with %mm (.dd.yyyy) - if this US format is detected it has higher prio
              sDateFormat=sTemp
            EndIf
          EndIf
          sTemp=GetDateFormat(GetGadgetItemText(GadId, CountGadgetItems(GadId)/2, SortKey))
          If sTemp=""
            SortType=#SortString
          Else
            If sTemp<>sDateFormat
              If Left(sTemp, 3)="%mm" ; new format starts with %mm (.dd.yyyy) - if this US format is detected it has higher prio
                sDateFormat=sTemp
              EndIf
            EndIf
          EndIf   
        EndIf         
      EndIf
      udtLVWSORT\DateFormat=sDateFormat
      Debug "Final DateFormat >"+sDateFormat+"<"
    EndIf
    
    ; Übergebene Informationen in einer LVWSORT-Struktur zusammenfassen:
    udtLVWSORT\hWndListView=hWndListView
    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_(hWndListView, #LVM_SORTITEMSEX, @udtLVWSORT, @CompareFunc())
    
  EndProcedure
  Procedure.b DetectOrderType(sText.s)
    
    Protected Diff
    
    Diff=Len(sText)-CountString(sText, "0")-CountString(sText, "1")-CountString(sText, "2")-CountString(sText, "3")-CountString(sText, "4")-CountString(sText, "5")-CountString(sText, "6")-CountString(sText, "7")-CountString(sText, "8")-CountString(sText, "9")   
    
    Select Diff
      Case 0 ; es sind nur Ziffern
        ProcedureReturn #SortNumeric
        
      Case 1 ; nur 1 anderes Zeichen
        If (CountString(sText, ",")>0 Or CountString(sText, ".")>0)
          ProcedureReturn #SortFloat
        ElseIf (Left(sText, 1)="$" Or Left(sText, 1)="%") ; es ist eine HEX oder Binär Zahl
          ProcedureReturn #SortNumeric
        Else
          ProcedureReturn #SortString
        EndIf
        
      Case 2 ; 2 andere Zeichen - evtl. Datum?
        
        If (Len(sText)=10 And
          Not IsNumChar(@sText, 3) And Not IsNumChar(@sText, 6))
          ; dd-mm-yyyy or mm-dd-yyyy
          ProcedureReturn #SortDate
        Else
          ; yyyy-mm-dd
          ProcedureReturn #SortString
        EndIf
        
      Case 4 ; 4 other chars, possibly DateTime?
        
        If (Len(sText)=16 And
          Not IsNumChar(@sText, 3) And Not IsNumChar(@sText, 6) And
          Not IsNumChar(@sText, 11) And Not IsNumChar(@sText, 14))
          ;dd-mm-yyyy hh:mm or mm-dd-yyyy hh:mm
          ProcedureReturn #SortDate
        Else
          ProcedureReturn #SortString
        EndIf
        
      Case 5 ; 5 other chars, possibly DateTime?
        
        If (Len(sText)=19 And
          Not IsNumChar(@sText, 3) And Not IsNumChar(@sText, 6) And
          Not IsNumChar(@sText, 11) And Not IsNumChar(@sText, 14) And Not IsNumChar(@sText, 17))
          ;dd-mm-yyyy hh:mm:ss or mm-dd-yyyy hh:mm:ss
          ProcedureReturn #SortDate
        Else
          ProcedureReturn #SortString
        EndIf         
        
      Default
        ProcedureReturn #SortString
        
    EndSelect
    
  EndProcedure
  Procedure   SortColumn(gadget, Column, OrderType.b = #SortAutoDetect)
    
    Protected ColCnt, Order, iStartT, iEndT, Temp.b
    
    If Not IsGadget(Gadget) : ProcedureReturn #False : EndIf
    
    Debug "LIG_SortColumn >"+Str(Gadget)+"< Spalte >"+Str(Column)+"<"
    
    Select GetSortOrder(Gadget, Column)
      Case #NoSort, #DescSort
        Order = #AscSort
      Case #AscSort
        Order = #DescSort
    EndSelect
    
    iStartT=ElapsedMilliseconds()
    
    If OrderType = #SortAutoDetect ; detect it automatically - check first, last and middle item of list
      OrderType = DetectOrderType(GetGadgetItemText(Gadget, 0, Column))
      If (OrderType = DetectOrderType(GetGadgetItemText(Gadget, CountGadgetItems(Gadget)-1, Column)))
        If (OrderType <> DetectOrderType(GetGadgetItemText(Gadget, CountGadgetItems(Gadget)/2, Column)))
          Debug "Different OrderType - use SortString 2"
          OrderType = #SortString
        EndIf
      Else
        Debug "Different OrderType - use SortString"
        OrderType = #SortString
      EndIf
    EndIf   
    
    SortListView(GadgetID(Gadget), Column, OrderType, Order)
    
    iEndT  =ElapsedMilliseconds()
    
    Debug "Dauer >"+StrF( (iEndT-iStartT)/1000, 2)+"<"
    
    SetSortIcon(Gadget, Column, Order)
    
    If (GetGadgetState(Gadget) > -1)
      EnsureVisible(Gadget, GetGadgetState(Gadget))
    EndIf
    
  EndProcedure
  
  ;- ##### ListIconGadget Sort Ende ######
  
  Procedure ColumnClickCallback(hwnd, uMsg, wParam, lParam)
    
    Protected *msg.NM_LISTVIEW
    
    If uMsg = #WM_NOTIFY
      *msg = lParam
      If *msg\hdr\code = #LVN_COLUMNCLICK                     
        SortColumn(GetDlgCtrlID_(*msg\hdr\hwndfrom), *msg\iSubItem)
      EndIf
    EndIf
    
    ProcedureReturn DefSubclassProc(hwnd, uMsg, wParam, lParam)
  EndProcedure
  
  Procedure Enable(GadgetID)
    SetWindowSubclass(GadgetID(GadgetID), @ColumnClickCallback(), 0, 0)
    ;SetWindowCallback(@ColumnClickCallback()) 
  EndProcedure
  
  EndModule
  
  DisableExplicit
  
CompilerElse
  
  MessageRequester("PureBasic", "PureBasic V5.20 or higher needed!") : End
  
CompilerEndIf
; --- Example
CompilerIf #PB_Compiler_IsMainFile
  
  Enumeration #PB_Compiler_EnumerationValue
    #MainWin
  EndEnumeration
  Enumeration #PB_Compiler_EnumerationValue
    #ListIcon
  EndEnumeration
  
  Procedure OpenMainWin()
    OpenWindow(#MainWin, 0, 0, 850, 500, "ListIconGadget-SortExample", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
    
    ListIconGadget(#ListIcon, 10, 10, 830, 480, "COL 0", 150, #PB_ListIcon_GridLines | #PB_ListIcon_FullRowSelect)
    AddGadgetColumn(#ListIcon, 1, "COL 1", 100)
    AddGadgetColumn(#ListIcon, 2, "COL 2", 100)
    AddGadgetColumn(#ListIcon, 3, "COL 3 (NUM)", 100)
    AddGadgetColumn(#ListIcon, 4, "COL 4 (FLOAT)", 100)
    AddGadgetColumn(#ListIcon, 5, "COL 5 (DATE)", 100)
    AddGadgetColumn(#ListIcon, 6, "COL 6 (DATETIME)", 150)
  EndProcedure
  
  Procedure MainWin_Events(event)
    Select event
      Case #PB_Event_CloseWindow
        ProcedureReturn #False
        
    EndSelect
    ProcedureReturn #TRUE
  EndProcedure
  
  
  Define iEvent.i
  Define iEventWindow.i
  Define iCloseAll.i
  Define a.i, x.i
  Define A$, B$, C$, D$, E$, F$, G$
  
  OpenMainWin()
  
  ; generate Test Values:
  
  For a = 0 To 1000
    
    A$ = "COL 1, Row "+RSet(Str(  a  ),6,"0")+Chr(10)
    
    B$ =RSet(Str(Random($FFFF)),5,"0")+Chr(10)
    
    C$ ="$"+RSet(Hex(Random($7FFFFFFF)),8,"0")+Chr(10)
    
    Select Random(5, 1)
      Case 1
        D$=Str(Random(9, 0))
      Case 2
        D$=Str(Random(99, 10))
      Case 3
        D$=Str(Random(999, 100))
      Case 4
        D$=Str(Random(9999, 1000))
      Case 5
        D$=Str(Random(99999, 10000))
    EndSelect         
    D$+Chr(10)
    
    Select Random(5, 1)
      Case 1
        E$=Str(Random(9, 0))+","+Str(Random(99, 0))
      Case 2
        E$=Str(Random(99, 10))+","+Str(Random(99, 0))
      Case 3
        E$=Str(Random(999, 100))+","+Str(Random(99, 0))
      Case 4
        E$=Str(Random(9999, 1000))+","+Str(Random(99, 0))
      Case 5
        E$=Str(Random(99999, 10000))+","+Str(Random(99, 0))
    EndSelect
    E$+Chr(10)
    
    F$=FormatDate("%dd.%mm.%yyyy", Random(Date(), 0))+Chr(10)
    
    G$=FormatDate("%mm-%dd-%yyyy %hh:%mm:%ss", Random(Date(), 0))
    
    AddGadgetItem(#ListIcon, a, A$+B$+C$+D$+E$+F$+G$)
    
  Next
  
  nalorLIG::Enable(#ListIcon)
  
  Repeat
    
    iEvent = WaitWindowEvent()
    iEventWindow=EventWindow()
    
    Select iEventWindow
      Case #MainWin
        If (Not MainWin_Events(iEvent))
          iCloseAll=#TRUE
        EndIf
    EndSelect
    
  Until iCloseAll=#TRUE
  
CompilerEndIf

Re: Nutzt jemand die PureLVSort Lib?

Verfasst: 21.10.2015 12:34
von dige
Habs jetzt auch mal mit SetWindowLongPtr_() probiert .. da funzt es..

Code: Alles auswählen

; ==================================================================================================
; --- ListIconGadget Extras & Sort
; --- ----------------------------------------------------------------------------------------------
; --- File            : module_nalorLIG.pbi
; --- OriginalAuthor  : nalor
; --- modified        : bisonte (change to new module system of pb)
; --- Link            : http://purebasic.fr/english/viewtopic.php?f=12&t=55085   
; --- Date            : June 23, 2013
; --- Compiler        : PureBasic 5.20b2 (Windows - x64)
; --- Target OS       : Windows
; --- Version         : 1.0a
; ==================================================================================================
; --- Module : nalorLIG
; --- Remark : If WindowsXP is used - Disable Debugger or use Unicode Flag only

CompilerIf #PB_Compiler_Version => 520
  
  EnableExplicit
  
  CompilerIf #PB_Compiler_OS <> #PB_OS_Windows
    MessageRequester("PureBasic", "Windows only! Sorry.") : End
  CompilerEndIf
  
  DeclareModule nalorLIG
  
  ; --- Original by : nalor
  ; --- Link        : http://purebasic.fr/english/viewtopic.php?f=12&t=55085   
  ; --- mod.by      : bisonte (change to module) - 23.06.2013
  
  Enumeration ; Type of Column Sort
    #SortString
    #SortNumeric
    #SortFloat
    #SortDate
    #SortAutoDetect
  EndEnumeration
  Enumeration ; Column Sort States
    #NoSort   ; keine Sortierung
    #AscSort  ; Aufsteigende Sortierung
    #DescSort ; Absteigende Sortierung
  EndEnumeration
  
  Structure LVWSORT
    hWndListView.i ; Fensterhandle des ListView-Controls
    SortKey.i ; Spalte, die sortiert werden soll
    SortType.b ; Typ der zu sortierenden Daten
    SortOrder.b ; Sortierrichtung
    DateFormat.s ; Mask for 'ParseDate'
  EndStructure
  
  Declare   AlignColumn(gadget, Index, Format)
  Declare   SetColumnWidth(gadget, Index, New_Width)
  Declare   SetSortIcon(gadget, Column, SortOrder)
  Declare.b GetSortOrder(gadget, Column)
  Declare   EnsureVisible(gadget, Line)
  
  Declare   Enable(GadgetID)
  
  EndDeclareModule
  Module        nalorLIG
  
  
  Import ""
    GetProcAddress(hmod, s.p-ascii)
  EndImport
  
  Prototype pSetWindowSubclass(hwnd, *Proc, *Id, *RefData)
  Prototype pDefSubclassProc(hwnd, msg, wParam, lParam)
  Prototype pRemoveWindowSubclass(hwnd, *Proc, *Id)
  Prototype pGetWindowSubclass(hwnd, *Proc, *Id, *RefData)
  
  ;https://msdn.microsoft.com/de-de/library/windows/desktop/bb776430(v=vs.85).aspx
  Procedure SetWindowSubclass(hwnd, *Proc, *Id, *RefData)
    Protected Comctl32 = GetModuleHandle_("Comctl32.dll")   
    Protected func.pSetWindowSubclass = GetProcAddress(Comctl32, "SetWindowSubclass")
    ProcedureReturn func(hwnd, *Proc, *Id, *RefData)
  EndProcedure
  
  ;https://msdn.microsoft.com/de-de/library/windows/desktop/bb776403(v=vs.85).aspx
  Procedure DefSubclassProc(hwnd, msg, wParam, lParam)
    Protected Comctl32 = GetModuleHandle_("Comctl32.dll")
    Protected func.pDefSubclassProc = GetProcAddress(Comctl32, "DefSubclassProc")
    ProcedureReturn func(hwnd, msg, wParam, lParam)
  EndProcedure
  
  ;https://msdn.microsoft.com/de-de/library/windows/desktop/bb762094(v=vs.85).aspx
  Procedure RemoveWindowSubclass(hwnd, *Proc, *Id)
    Protected Comctl32 = GetModuleHandle_("Comctl32.dll")
    Protected func.pRemoveWindowSubclass = GetProcAddress(Comctl32, "RemoveWindowSubclass")
    ProcedureReturn func(hwnd, *Proc, *Id)
  EndProcedure
  
  ;https://msdn.microsoft.com/de-de/library/windows/desktop/bb776430(v=vs.85).aspx
  Procedure GetWindowSubclass(hwnd, *Proc, *Id, *RefData)
    Protected Comctl32 = GetModuleHandle_("Comctl32.dll")
    Protected func.pGetWindowSubclass = GetProcAddress(Comctl32, "GetWindowSubclass")
    ProcedureReturn func(hwnd, *Proc, *Id, *RefData)
  EndProcedure
  
  
  
  
  ; --- Original by : nalor
  ; --- Link        : http://purebasic.fr/english/viewtopic.php?f=12&t=55085   
  ; --- mod.by      : bisonte (change to module) - 23.06.2013
  
  Procedure   GethWnd(id)
    
    Protected hWnd = #False
    
    If IsGadget(ID)
      hWnd = GadgetID(ID)
    Else
      If IsWindow_(ID)
        hWnd = ID
      EndIf
    EndIf
    
    ProcedureReturn hWnd
    
  EndProcedure
  
  ;- ++++++ ListIconGadget Tools Start ++++++
  
  Procedure   AlignColumn(gadget, Index, Format)
    
    ; by Danilo, 15.12.2003 - english chat (for 'Karbon')
    ; 20130615..nalor..modified
    ; change text alignment for columns
    ; #LVCFMT_LEFT / #LVCFMT_CENTER / #LVCFMT_RIGHT
    
    Protected lvc.LV_COLUMN, hWnd = GethWnd(Gadget)
    
    If hWnd
      
      lvc\mask = #LVCF_FMT
      lvc\fmt = Format
      
      SendMessage_(hWnd, #LVM_SETCOLUMN, Index, @lvc)
      
      ProcedureReturn #True
      
    EndIf
    
    ProcedureReturn #False
    
  EndProcedure
  Procedure   SetColumnWidth(gadget, Index, New_Width)
    
    ; by Danilo, 15.12.2003 - english chat (for 'Karbon')
    ;
    ; change column header width
    ;
    
    Protected hWnd = GethWnd(Gadget)
    
    If hWnd
      
      SendMessage_(hWnd, #LVM_SETCOLUMNWIDTH, Index, New_Width)
      ProcedureReturn #True
      
    EndIf
    
    ProcedureReturn #False
    
  EndProcedure
  Procedure   SetSortIcon(gadget, Column, SortOrder)
    
    ; http://stackoverflow.com/questions/254129/how-To-i-display-a-sort-arrow-in-the-header-of-a-List-view-column-using-c   
    
    Protected ColumnHeader
    Protected ColumnCount
    Protected hditem.HD_ITEM
    Protected Cnt
    Protected hWnd = GethWnd(Gadget)
    
    If hWnd
      
      ColumnHeader = SendMessage_(hWnd, #LVM_GETHEADER, 0, 0)
      ColumnCount  = SendMessage_(ColumnHeader, #HDM_GETITEMCOUNT, 0, 0)
      
      For Cnt = 0 To ColumnCount - 1
        
        hditem\mask=#HDI_FORMAT
        
        If SendMessage_(ColumnHeader, #HDM_GETITEM, Cnt, @hditem) = 0
          Debug "ERROR! LIG_SetSortIcon 1"
        EndIf
        
        hditem\mask=#HDI_FORMAT
        
        If (Cnt = Column And SortOrder <> #NoSort)
          
          Select SortOrder
              
            Case #AscSort ; wenn aufsteigend sortiert werden soll
              hditem\fmt& ~#HDF_SORTDOWN
              hditem\fmt|#HDF_SORTUP
              Debug "sortup"
              
            Case #DescSort
              hditem\fmt& ~#HDF_SORTUP
              hditem\fmt|#HDF_SORTDOWN               
              Debug "sortdown"
              
          EndSelect
          
        Else
          
          hditem\fmt& ~#HDF_SORTUP
          hditem\fmt& ~#HDF_SORTDOWN
          
        EndIf
        
        If (SendMessage_(ColumnHeader, #HDM_SETITEM, Cnt, @hditem) = 0)
          Debug "ERROR! LIG_SetSortIcon 2"
        EndIf
        
      Next cnt
      
      ProcedureReturn #True
      
    EndIf
    
    ProcedureReturn #False
    
  EndProcedure
  Procedure.b GetSortOrder(gadget, Column)
    
    Protected ColumnHeader
    Protected hditem.HD_ITEM
    Protected RetVal.b = -1
    Protected hWnd = GethWnd(Gadget)
    
    If hWnd
      
      ColumnHeader = SendMessage_(hWnd, #LVM_GETHEADER, 0, 0)
      
      hditem\mask=#HDI_FORMAT
      
      If SendMessage_(ColumnHeader, #HDM_GETITEM, Column, @hditem)
        
        If (hditem\fmt&#HDF_SORTUP)=#HDF_SORTUP
          
          Debug "sortup"
          RetVal=#AscSort
          
        ElseIf (hditem\fmt&#HDF_SORTDOWN)=#HDF_SORTDOWN
          
          Debug "sortdown"
          RetVal=#DescSort
          
        Else
          
          Debug "keine sortierung"
          RetVal=#NoSort
          
        EndIf
        
      Else
        
        Debug "ERROR! LIG_GetSortOrder"
        RetVal=-1
        
      EndIf
      
    EndIf
    
    ProcedureReturn RetVal
    
  EndProcedure
  Procedure   EnsureVisible(gadget, Line)
    ; makes sure the line is visible
    
    Protected hWnd = GethWnd(Gadget)
    If hWnd
      SendMessage_(hWnd, #LVM_ENSUREVISIBLE, Line, #True)
      ProcedureReturn #True 
    EndIf
    ProcedureReturn #False
    
  EndProcedure
  
  ;- ##### ListIconGadget Tools Ende #####
  
  ;- ++++++ ListIconGadget Sort Start ++++++
  
  ; http://msdn.microsoft.com/de-de/library/bb979183.aspx   
  ; Die Struktur LVWSORT enthält Informationen über das zu sortierende ListView-Steuerelement, die Spalte,
  ; nach der sortiert werden soll, sowie die gewünschte Sortierrichtung.
  
  Procedure.b IsNumChar(*Text, Position = 1)
    Select Asc(PeekS(*Text+(Position-1)*SizeOf(Character), 1))
      Case 48 To 57
        ProcedureReturn #True
      Default
        ProcedureReturn #False
    EndSelect
  EndProcedure
  Procedure   CompareStrings(*sEntry1, *sEntry2, SortOrder.b)
    ; ' -----------------------------------------------------
    ; ' 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 = #AscSort
      ; Aufsteigende Sortierung zweier unterschiedlicher Strings
      If CompareMemoryString(*sEntry1, *sEntry2, #PB_String_NoCase) = #PB_String_Lower
        ProcedureReturn -1
      Else
        ProcedureReturn 1
      EndIf
    Else ; Absteigende Sortierung
      If CompareMemoryString(*sEntry1, *sEntry2, #PB_String_NoCase) = #PB_String_Greater
        ProcedureReturn -1
      Else
        ProcedureReturn 1
      EndIf
    EndIf
    
  EndProcedure
  Procedure   CompareNumbers(sEntry1.s, sEntry2.s, SortOrder.b)
    ; ' -----------------------------------------------------
    ; ' 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 = #AscSort
      ; Aufsteigende Sortierung zweier unterschiedlicher Zahlen
      If Val(sEntry1) < Val(sEntry2)
        ProcedureReturn -1
      Else
        ProcedureReturn 1
      EndIf
    Else ; Absteigende Sortierung
      If Val(sEntry1) > Val(sEntry2)
        ProcedureReturn -1
      Else
        ProcedureReturn 1
      EndIf
    EndIf
    
  EndProcedure
  Procedure   CompareFloat(sEntry1.s, sEntry2.s, SortOrder.b)
    ; ' -----------------------------------------------------
    ; ' 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:
    
    ReplaceString(sEntry1, ",", ".", #PB_String_InPlace, 1, 1) ; ersetze Dezimalkomma durch Punkt, damit ValF korrekt arbeitet
    ReplaceString(sEntry2, ",", ".", #PB_String_InPlace, 1, 1)
    
    If SortOrder = #AscSort
      ; Aufsteigende Sortierung zweier unterschiedlicher Zahlen
      If ValF(sEntry1) < ValF(sEntry2)
        ProcedureReturn -1
      Else
        ProcedureReturn 1
      EndIf
    Else ; Absteigende Sortierung
      If ValF(sEntry1) > ValF(sEntry2)
        ProcedureReturn -1
      Else
        ProcedureReturn 1
      EndIf
    EndIf         
    
  EndProcedure
  Procedure   CompareDate(sEntry1.s, sEntry2.s, SortOrder.b, sDateMask.s)
    ; ' -----------------------------------------------------
    ; ' 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 = #AscSort
      ; Aufsteigende Sortierung zweier unterschiedlicher Zahlen
      If ParseDate(sDateMask, sEntry1) < ParseDate(sDateMask, sEntry2)
        ProcedureReturn -1
      Else
        ProcedureReturn 1
      EndIf
    Else ; Absteigende Sortierung
      If ParseDate(sDateMask, sEntry1) > ParseDate(sDateMask, sEntry2)
        ProcedureReturn -1
      Else
        ProcedureReturn 1
      EndIf
    EndIf         
    
  EndProcedure
  Procedure.s LvwGetText(*ListViewSort.LVWSORT, lParam)
    ; ' -----------------------------------------------------
    ; ' 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.
    ; ' -----------------------------------------------------
    Protected udtFindInfo.LV_FINDINFO, udtLVItem.LV_ITEM
    Protected lngIndex, *baBuffer, lngLength, RetVal.s = ""
    
    *baBuffer = AllocateMemory(512)
    
    If *baBuffer
      
      ; Auf Basis des Index den Text der Zelle auslesen:
      udtLVItem\mask=#LVIF_TEXT
      udtLVItem\iSubItem=*ListViewSort\SortKey
      udtLVItem\pszText=*baBuffer
      udtLVItem\cchTextMax=(512/SizeOf(Character))-1
      
      lngLength = SendMessage_(*ListViewSort\hWndListView, #LVM_GETITEMTEXT, lParam, @udtLVItem)
      
      ; Byte-Array in passender Länge als String-Rückgabewert kopieren:
      
      If lngLength > 0
        RetVal = PeekS(*baBuffer, lngLength)
      EndIf
      FreeMemory(*baBuffer) ; thx LittleJohn
      
    EndIf
    
    ProcedureReturn RetVal
    
  EndProcedure
  Procedure   CompareFunc(lParam1, lParam2, lParamSort)
    ; ' -----------------------------------------------------
    ; ' 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
    ; ' -----------------------------------------------------
    Protected *ListViewSort.LVWSORT
    Protected sEntry1.s
    Protected sEntry2.s
    Protected vCompare1.s ; As Variant
    Protected vCompare2.s ; As Variant
    
    ; In lParamSort von SortListView als Long-Pointer übergebene LVWSORT-Struktur abholen, um auf deren
    ; Werte zugreifen zu können:
    
    *ListViewSort=lParamSort
    
    ; 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)
    
    ; Sind die Elemente gleich, kann die Funktion sofort mit dem aktuellen Rückgabewert 0
    ; verlassen werden:
    If sEntry1 = sEntry2
      ProcedureReturn 0
    EndIf
    
    ; Für die Sortierung wird unterschieden zwischen Zahlen, Fließkommazahlen und allgemeinen Strings. Hierfür
    ; steht jeweils eine separate, private Vergleichsfunktion zur Verfügung.
    
    Select *ListViewSort\SortType
      Case #SortNumeric ; ' Spalteninhalte sind Zahlen
        ProcedureReturn CompareNumbers(sEntry1, sEntry2, *ListViewSort\SortOrder)
      Case #SortFloat ; ' Spalteninhalte sind Zahlen mit Nachkommastellen
        ProcedureReturn CompareFloat(sEntry1, sEntry2, *ListViewSort\SortOrder)
      Case #SortString;  ' Spalteninhalte sind Strings
        ProcedureReturn CompareStrings(@sEntry1, @sEntry2, *ListViewSort\SortOrder)
      Case #SortDate
        ProcedureReturn CompareDate(sEntry1, sEntry2, *ListViewSort\SortOrder, *ListViewSort\DateFormat)
    EndSelect
  EndProcedure
  Procedure.s GetDateFormat(Date.s)
    
    Debug "GetDateFormat >"+Date+"<"
    
    Protected Diff.i
    
    Diff=Len(Date)-CountString(Date, "0")-CountString(Date, "1")-CountString(Date, "2")-CountString(Date, "3")-CountString(Date, "4")-CountString(Date, "5")-CountString(Date, "6")-CountString(Date, "7")-CountString(Date, "8")-CountString(Date, "9")   
    
    Select Diff
      Case 2
        If Len(Date)=10 ; Date 'dd.mm.yyyy', 'mm.dd.yyyy' or 'yyyy.mm.dd'
          
          If (Not IsNumChar(@Date, 5) And Not IsNumChar(@Date, 8)) ; yyyy.mm.dd
            ProcedureReturn "" ; faster to sort as string
            
          ElseIf (Not IsNumChar(@Date, 3) And Not IsNumChar(@Date, 6)) ; dd.mm.yyyy or mm.dd.yyyy
            If Val(Mid(Date, 4, 2))>12 ; is it mm.dd.yyyy?
              ProcedureReturn "%mm"+Mid(Date, 3, 1)+"%dd"+Mid(Date, 6, 1)+"%yyyy"
            Else ; default is dd.mm.yyyy
              ProcedureReturn "%dd"+Mid(Date, 3, 1)+"%mm"+Mid(Date, 6, 1)+"%yyyy"
            EndIf
            
          Else
            ProcedureReturn "" ; not a date - sort as string
          EndIf
        Else
          ProcedureReturn "" ; not a date - sort as string
        EndIf
        
      Case 4
        If Len(Date)=16 ;yyyy-mm-dd hh:mm, dd-mm-yyyy hh:mm or mm-dd-yyyy hh:mm
          
          If (Not IsNumChar(@Date, 5) And Not IsNumChar(@Date, 8)) ; yyyy.mm.dd xxxxx
            ProcedureReturn "" ; faster to sort as string
            
          ElseIf (Not IsNumChar(@Date, 3) And Not IsNumChar(@Date, 6)) ; dd.mm.yyyy hh:mm or mm.dd.yyyy hh:mm
            If Val(Mid(Date, 4, 2))>12 ; is it mm.dd.yyyy?
              ProcedureReturn "%mm"+Mid(Date, 3, 1)+"%dd"+Mid(Date, 6, 1)+"%yyyy"+Mid(Date, 11, 1)+"%hh"+Mid(Date, 14, 1)+"%mm"
            Else ; default is dd.mm.yyyy
              ProcedureReturn "%dd"+Mid(Date, 3, 1)+"%mm"+Mid(Date, 6, 1)+"%yyyy"+Mid(Date, 11, 1)+"%hh"+Mid(Date, 14, 1)+"%mm"
            EndIf
            
          Else
            ProcedureReturn "" ; not a date - sort as string
          EndIf
        Else
          ProcedureReturn "" ; not a date - sort as string
        EndIf           
        
      Case 5 ; 5 other chars, possibly DateTime?
        
        If Len(Date)=19 ;yyyy-mm-dd hh:mm, dd-mm-yyyy hh:mm or mm-dd-yyyy hh:mm
          
          If (Not IsNumChar(@Date, 5) And Not IsNumChar(@Date, 8)) ; yyyy.mm.dd xxxxx
            ProcedureReturn "" ; faster to sort as string
            
          ElseIf (Not IsNumChar(@Date, 3) And Not IsNumChar(@Date, 6)) ; dd.mm.yyyy hh:mm or mm.dd.yyyy hh:mm
            If Val(Mid(Date, 4, 2))>12 ; is it mm.dd.yyyy?
              ProcedureReturn "%mm"+Mid(Date, 3, 1)+"%dd"+Mid(Date, 6, 1)+"%yyyy"+Mid(Date, 11, 1)+"%hh"+Mid(Date, 14, 1)+"%mm"+Mid(Date, 17, 1)+"%ss"
            Else ; default is dd.mm.yyyy
              ProcedureReturn "%dd"+Mid(Date, 3, 1)+"%mm"+Mid(Date, 6, 1)+"%yyyy"+Mid(Date, 11, 1)+"%hh"+Mid(Date, 14, 1)+"%mm"+Mid(Date, 17, 1)+"%ss"
            EndIf
            
          Else
            ProcedureReturn "" ; not a date - sort as string
          EndIf
        Else
          ProcedureReturn "" ; not a date - sort as string
        EndIf
        
      Default
        ProcedureReturn ""
    EndSelect
    
  EndProcedure
  Procedure   SortListView(hWndListView, SortKey, SortType.b, SortOrder.b)
    ; ' -----------------------------------------------------
    ; ' Ö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
    ; ' -----------------------------------------------------
    
    Protected udtLVWSORT.LVWSORT
    Protected sDateFormat.s, sTemp.s, GadId.i
    
    If SortType = #SortDate
      GadId = GetDlgCtrlID_(hWndListView)
      sDateFormat = GetDateFormat(GetGadgetItemText(GadId, 0, SortKey))
      
      If sDateFormat = ""
        SortType = #SortString
      Else
        sTemp = GetDateFormat(GetGadgetItemText(GadId, CountGadgetItems(GadId)-1, SortKey))
        If sTemp=""
          SortType=#SortString
        Else
          If sTemp<>sDateFormat
            If Left(sTemp, 3)="%mm" ; new format starts with %mm (.dd.yyyy) - if this US format is detected it has higher prio
              sDateFormat=sTemp
            EndIf
          EndIf
          sTemp=GetDateFormat(GetGadgetItemText(GadId, CountGadgetItems(GadId)/2, SortKey))
          If sTemp=""
            SortType=#SortString
          Else
            If sTemp<>sDateFormat
              If Left(sTemp, 3)="%mm" ; new format starts with %mm (.dd.yyyy) - if this US format is detected it has higher prio
                sDateFormat=sTemp
              EndIf
            EndIf
          EndIf   
        EndIf         
      EndIf
      udtLVWSORT\DateFormat=sDateFormat
      Debug "Final DateFormat >"+sDateFormat+"<"
    EndIf
    
    ; Übergebene Informationen in einer LVWSORT-Struktur zusammenfassen:
    udtLVWSORT\hWndListView=hWndListView
    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_(hWndListView, #LVM_SORTITEMSEX, @udtLVWSORT, @CompareFunc())
    
  EndProcedure
  Procedure.b DetectOrderType(sText.s)
    
    Protected Diff
    
    Diff=Len(sText)-CountString(sText, "0")-CountString(sText, "1")-CountString(sText, "2")-CountString(sText, "3")-CountString(sText, "4")-CountString(sText, "5")-CountString(sText, "6")-CountString(sText, "7")-CountString(sText, "8")-CountString(sText, "9")   
    
    Select Diff
      Case 0 ; es sind nur Ziffern
        ProcedureReturn #SortNumeric
        
      Case 1 ; nur 1 anderes Zeichen
        If (CountString(sText, ",")>0 Or CountString(sText, ".")>0)
          ProcedureReturn #SortFloat
        ElseIf (Left(sText, 1)="$" Or Left(sText, 1)="%") ; es ist eine HEX oder Binär Zahl
          ProcedureReturn #SortNumeric
        Else
          ProcedureReturn #SortString
        EndIf
        
      Case 2 ; 2 andere Zeichen - evtl. Datum?
        
        If (Len(sText)=10 And
          Not IsNumChar(@sText, 3) And Not IsNumChar(@sText, 6))
          ; dd-mm-yyyy or mm-dd-yyyy
          ProcedureReturn #SortDate
        Else
          ; yyyy-mm-dd
          ProcedureReturn #SortString
        EndIf
        
      Case 4 ; 4 other chars, possibly DateTime?
        
        If (Len(sText)=16 And
          Not IsNumChar(@sText, 3) And Not IsNumChar(@sText, 6) And
          Not IsNumChar(@sText, 11) And Not IsNumChar(@sText, 14))
          ;dd-mm-yyyy hh:mm or mm-dd-yyyy hh:mm
          ProcedureReturn #SortDate
        Else
          ProcedureReturn #SortString
        EndIf
        
      Case 5 ; 5 other chars, possibly DateTime?
        
        If (Len(sText)=19 And
          Not IsNumChar(@sText, 3) And Not IsNumChar(@sText, 6) And
          Not IsNumChar(@sText, 11) And Not IsNumChar(@sText, 14) And Not IsNumChar(@sText, 17))
          ;dd-mm-yyyy hh:mm:ss or mm-dd-yyyy hh:mm:ss
          ProcedureReturn #SortDate
        Else
          ProcedureReturn #SortString
        EndIf         
        
      Default
        ProcedureReturn #SortString
        
    EndSelect
    
  EndProcedure
  Procedure   SortColumn(gadget, Column, OrderType.b = #SortAutoDetect)
    
    Protected ColCnt, Order, iStartT, iEndT, Temp.b
    
    If Not IsGadget(Gadget) : ProcedureReturn #False : EndIf
    
    Debug "LIG_SortColumn >"+Str(Gadget)+"< Spalte >"+Str(Column)+"<"
    
    Select GetSortOrder(Gadget, Column)
      Case #NoSort, #DescSort
        Order = #AscSort
      Case #AscSort
        Order = #DescSort
    EndSelect
    
    iStartT=ElapsedMilliseconds()
    
    If OrderType = #SortAutoDetect ; detect it automatically - check first, last and middle item of list
      OrderType = DetectOrderType(GetGadgetItemText(Gadget, 0, Column))
      If (OrderType = DetectOrderType(GetGadgetItemText(Gadget, CountGadgetItems(Gadget)-1, Column)))
        If (OrderType <> DetectOrderType(GetGadgetItemText(Gadget, CountGadgetItems(Gadget)/2, Column)))
          Debug "Different OrderType - use SortString 2"
          OrderType = #SortString
        EndIf
      Else
        Debug "Different OrderType - use SortString"
        OrderType = #SortString
      EndIf
    EndIf   
    
    SortListView(GadgetID(Gadget), Column, OrderType, Order)
    
    iEndT  =ElapsedMilliseconds()
    
    Debug "Dauer >"+StrF( (iEndT-iStartT)/1000, 2)+"<"
    
    SetSortIcon(Gadget, Column, Order)
    
    If (GetGadgetState(Gadget) > -1)
      EnsureVisible(Gadget, GetGadgetState(Gadget))
    EndIf
    
  EndProcedure
  
  ;- ##### ListIconGadget Sort Ende ######
  
  Procedure ColumnClickCallback(hwnd, uMsg, wParam, lParam)
    
    Protected *msg.NM_LISTVIEW
    
    Window = GetProp_(hwnd, "WINNR")
    OldProc = GetProp_(hwnd, "OLDPROC")
    
    If Not IsWindow(Window) : ProcedureReturn 0 : EndIf
    If Not OldProc : ProcedureReturn 0 : EndIf
    
    If uMsg = #WM_NOTIFY
      *msg = lParam
      If *msg\hdr\code = #LVN_COLUMNCLICK                     
        SortColumn(GetDlgCtrlID_(*msg\hdr\hwndfrom), *msg\iSubItem)
      EndIf
    EndIf
    
    If OldProc
      ;: Den "originalen" Callback aufrufen ... den CB der in der Callbackliste von Windows an
      ;: der stelle vor unserem ist
      ProcedureReturn CallWindowProc_(OldProc, hwnd, uMsg, wParam, lParam)
    Else
      ;: ansonsten soll nichts passieren
      ProcedureReturn #Null
    EndIf
    
  EndProcedure
  
  Procedure Enable(Window)
    ; SetWindowSubclass(GadgetID(GadgetID), @ColumnClickCallback(), 0, 0)
    ;SetWindowCallback(@ColumnClickCallback()) 
    
    ;: Setzen des CallBacks
    OldProc = SetWindowLongPtr_(WindowID(Window), #GWLP_WNDPROC, @ColumnClickCallback())
    
    ;: Anhängen von Variablen die im Callback gebraucht werden
    ;: Man sollte versuchen, so wenig wie möglich an daten anzuhängen.
    SetProp_(WindowID(Window), "WINNR", Window)
    SetProp_(WindowID(Window), "OLDPROC", OldProc)
    
  EndProcedure
  
  EndModule
  
  DisableExplicit
  
CompilerElse
  
  MessageRequester("PureBasic", "PureBasic V5.20 or higher needed!") : End
  
CompilerEndIf
; --- Example
CompilerIf #PB_Compiler_IsMainFile
  
  Enumeration #PB_Compiler_EnumerationValue
    #MainWin
  EndEnumeration
  Enumeration #PB_Compiler_EnumerationValue
    #ListIcon
  EndEnumeration
  
  Procedure OpenMainWin()
    OpenWindow(#MainWin, 0, 0, 850, 500, "ListIconGadget-SortExample", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
    
    ListIconGadget(#ListIcon, 10, 10, 830, 480, "COL 0", 150, #PB_ListIcon_GridLines | #PB_ListIcon_FullRowSelect)
    AddGadgetColumn(#ListIcon, 1, "COL 1", 100)
    AddGadgetColumn(#ListIcon, 2, "COL 2", 100)
    AddGadgetColumn(#ListIcon, 3, "COL 3 (NUM)", 100)
    AddGadgetColumn(#ListIcon, 4, "COL 4 (FLOAT)", 100)
    AddGadgetColumn(#ListIcon, 5, "COL 5 (DATE)", 100)
    AddGadgetColumn(#ListIcon, 6, "COL 6 (DATETIME)", 150)
  EndProcedure
  
  Procedure MainWin_Events(event)
    Select event
      Case #PB_Event_CloseWindow
        ProcedureReturn #False
        
    EndSelect
    ProcedureReturn #TRUE
  EndProcedure
  
  
  Define iEvent.i
  Define iEventWindow.i
  Define iCloseAll.i
  Define a.i, x.i
  Define A$, B$, C$, D$, E$, F$, G$
  
  OpenMainWin()
  
  ; generate Test Values:
  
  For a = 0 To 1000
    
    A$ = "COL 1, Row "+RSet(Str(  a  ),6,"0")+Chr(10)
    
    B$ =RSet(Str(Random($FFFF)),5,"0")+Chr(10)
    
    C$ ="$"+RSet(Hex(Random($7FFFFFFF)),8,"0")+Chr(10)
    
    Select Random(5, 1)
      Case 1
        D$=Str(Random(9, 0))
      Case 2
        D$=Str(Random(99, 10))
      Case 3
        D$=Str(Random(999, 100))
      Case 4
        D$=Str(Random(9999, 1000))
      Case 5
        D$=Str(Random(99999, 10000))
    EndSelect         
    D$+Chr(10)
    
    Select Random(5, 1)
      Case 1
        E$=Str(Random(9, 0))+","+Str(Random(99, 0))
      Case 2
        E$=Str(Random(99, 10))+","+Str(Random(99, 0))
      Case 3
        E$=Str(Random(999, 100))+","+Str(Random(99, 0))
      Case 4
        E$=Str(Random(9999, 1000))+","+Str(Random(99, 0))
      Case 5
        E$=Str(Random(99999, 10000))+","+Str(Random(99, 0))
    EndSelect
    E$+Chr(10)
    
    F$=FormatDate("%dd.%mm.%yyyy", Random(Date(), 0))+Chr(10)
    
    G$=FormatDate("%mm-%dd-%yyyy %hh:%mm:%ss", Random(Date(), 0))
    
    AddGadgetItem(#ListIcon, a, A$+B$+C$+D$+E$+F$+G$)
    
  Next
  
  nalorLIG::Enable(#MainWin)
  
  Repeat
    
    iEvent = WaitWindowEvent()
    iEventWindow=EventWindow()
    
    Select iEventWindow
      Case #MainWin
        If (Not MainWin_Events(iEvent))
          iCloseAll=#TRUE
        EndIf
    EndSelect
    
  Until iCloseAll=#TRUE
  
CompilerEndIf

Re: Nutzt jemand die PureLVSort Lib?

Verfasst: 21.10.2015 12:39
von edel
Die Callbacks haben 2 weitere Parameter :

Code: Alles auswählen

ColumnClickCallback(hwnd, uMsg, wParam, lParam, id, udata)

Re: Nutzt jemand die PureLVSort Lib?

Verfasst: 21.10.2015 13:55
von dige
Ok, daran lags. Danke.

Leider läuft die Sortierung innerhalb meines Programmes nicht.

Code: Alles auswählen

GetDlgCtrlID_(*msg\hdr\hwndfrom), *msg\iSubItem)
Liefert immer 0 zurück. Ich vermute, dass man innerhalb komplexer GUI's diesen Trick
zur Ermittelung der PB GadgetID nicht verwenden kann.

*msg\hdr\code liefert auch nicht #LVN_COLUMNCLICK wenn ich auf den Header klicke
und *msg\iSubItem liefert nicht die richtige Spalte, sondern immer Null.

Ich bin frustriert und lass das erstmal ruhen...

:(

Re: Nutzt jemand die PureLVSort Lib?

Verfasst: 21.10.2015 14:05
von edel
Das ListView sendet eine Nachricht an das Fenster darueber. Also wenn WM_NOTIFY annkommt, dann moechte das Kindfenster dem Elternfenster etwas mitteilen. In deinem Fall hast du aber ein Callback auf das Listview gesetzt, welches aber gar keine WM_NOTIFY erhaelt.

Aendere mal den Code so ab :

Code: Alles auswählen

  Procedure Enable(GadgetID)
    SetWindowSubclass(GetParent_(GadgetID(GadgetID)), @ColumnClickCallback(), 0, 0)
    ;SetWindowCallback(@ColumnClickCallback()) 
  EndProcedure
LIG_SortColumn >4< Spalte >2<
keine sortierung
Different OrderType - use SortString
Dauer >0.04<
sortup
LIG_SortColumn >4< Spalte >0<
keine sortierung
Dauer >0.04<
sortup
LIG_SortColumn >4< Spalte >0<
sortup
Dauer >0.02<
sortdown

Re: Nutzt jemand die PureLVSort Lib?

Verfasst: 21.10.2015 14:09
von Bisonte
Das ganze ist für einen Callback eines WINDOW ausgelegt.

Wenn man das nach Edel's Methode machen möchte ersetze die
Prozedur : ColumnClickCallback(hWnd, uMsg, wParam, lParam)
durch

Code: Alles auswählen

    Procedure ColumnClickCallback_SubClass(hWnd, uMsg, wParam, lParam, ID, *refData)

      Protected *msg.NM_LISTVIEW

      Select uMsg
        Case #WM_NCDESTROY
          RemoveWindowSubclass(hWnd, @ColumnClickCallback_SubClass(), ID)

        Case #WM_NOTIFY
          *msg = lParam
          If *msg\hdr\code = #HDN_ITEMCLICK
            SortColumn(GetDlgCtrlID_(hWnd), *msg\iItem)  
          EndIf
          
      EndSelect
      
      ProcedureReturn DefSubclassProc(hWnd, uMsg, wParam, lParam)
     
    EndProcedure
P.S.: ich hoffe das mit dem RemoveWindowSubclass() an der Stelle ist so richtig ?

und die Prozedur : Enable() durch

Code: Alles auswählen

    Procedure Enable(Gadget)
      SetWindowSubclass(GadgetID(Gadget), @ColumnClickCallback_SubClass(), #Null, #Null)
    EndProcedure
Natürlich musst du Edel's Deklaration innerhalb des Modulbereiches haben.

Edit: Oh man ... ich werde langsam .... ;)

Re: Nutzt jemand die PureLVSort Lib?

Verfasst: 21.10.2015 14:14
von edel
Ich habe gerade noch einmal nachgelesen, man soll hier WM_NCDESTROY benutzen.
http://blogs.msdn.com/b/oldnewthing/arc ... 55653.aspx

Re: Nutzt jemand die PureLVSort Lib?

Verfasst: 21.10.2015 14:17
von Bisonte
edel hat geschrieben:Ich habe gerade noch einmal nachgelesen, man soll hier WM_NCDESTROY benutzen.
http://blogs.msdn.com/b/oldnewthing/arc ... 55653.aspx
Gerade geändert. Danke.
Allerdings sehe ich bei deiner Enable(GadgetID) Prozedur ein Problem aufkommen, wenn das ListIcon in einem ContainerGadget liegt....
weil dann ja das Handle des ContainerGadgets zurückkommt, und nicht das des Windows...
Oder irre ich mich da ?

Re: Nutzt jemand die PureLVSort Lib?

Verfasst: 21.10.2015 14:21
von edel
Man ubergibt die ID des ListViews, und dann wird, per API, auf das Fenster darueber zugegriffen. Und wie du bereits angemerkt hast, unter Windows ist alles ein Fenster ;)

Re: Nutzt jemand die PureLVSort Lib?

Verfasst: 21.10.2015 14:45
von Bisonte
Ok dann hier nochmal als komplettes Modul , wobei ich hier die Debug's auskommentiert habe...

Code: Alles auswählen

; ==================================================================================================
; --- ListIconGadget Extras & Sort
; --- ----------------------------------------------------------------------------------------------
; --- File            : module_nalorLIG.pbi
; --- OriginalAuthor  : nalor
; --- modified        : bisonte (change to new module system of pb)
; --- Link            : http://purebasic.fr/english/viewtopic.php?f=12&t=55085   
; --- Date            : June 23, 2013
; --- Compiler        : PureBasic 5.20b2 (Windows - x64)
; --- Target OS       : Windows
; --- Version         : 1.0a
; ==================================================================================================
; --- Module : nalorLIG
; --- Remark : If WindowsXP is used - Disable Debugger or use Unicode Flag only
; --- Changed with edel's help to subclass
; ==================================================================================================
CompilerIf #PB_Compiler_Version => 520
 
  EnableExplicit
 
  CompilerIf #PB_Compiler_OS <> #PB_OS_Windows
    MessageRequester("PureBasic", "Windows only! Sorry.") : End
  CompilerEndIf
 
  DeclareModule nalorLIG
   
    ; --- Original by : nalor
    ; --- Link        : http://purebasic.fr/english/viewtopic.php?f=12&t=55085   
    ; --- mod.by      : bisonte (change to module) - 23.06.2013
   
    Enumeration ; Type of Column Sort
      #SortString
      #SortNumeric
      #SortFloat
      #SortDate
      #SortAutoDetect
    EndEnumeration
    Enumeration ; Column Sort States
      #NoSort   ; keine Sortierung
      #AscSort  ; Aufsteigende Sortierung
      #DescSort ; Absteigende Sortierung
    EndEnumeration
   
    Structure LVWSORT
      hWndListView.i ; Fensterhandle des ListView-Controls
      SortKey.i ; Spalte, die sortiert werden soll
      SortType.b ; Typ der zu sortierenden Daten
      SortOrder.b ; Sortierrichtung
      DateFormat.s ; Mask for 'ParseDate'
    EndStructure
   
    Declare   Enable(Gadget)
   
  EndDeclareModule
  Module        nalorLIG
    
    ; --- Original by : nalor
    ; --- Link        : http://purebasic.fr/english/viewtopic.php?f=12&t=55085   
    ; --- mod.by      : bisonte (change to module) - 23.06.2013
    
    ;{--- Improvement by edel
    
    ; Subclass Window
    
    Import ""
      GetProcAddress(hmod, s.p-ascii)
    EndImport
    
    Prototype pSetWindowSubclass(hWnd, *Proc, *Id, *RefData)
    Prototype pDefSubclassProc(hWnd, Msg, wparam, lParam)
    Prototype pRemoveWindowSubclass(hWnd, *Proc, *Id)
    Prototype pGetWindowSubclass(hWnd, *Proc, *Id, *RefData)
    
    Procedure SetWindowSubclass(hWnd, *Proc, *Id, *RefData)
      Protected Comctl32 = GetModuleHandle_("Comctl32.dll")   
      Protected func.pSetWindowSubclass = GetProcAddress(Comctl32, "SetWindowSubclass")
      ProcedureReturn func(hWnd, *Proc, *Id, *RefData)
    EndProcedure
    Procedure DefSubclassProc(hWnd, Msg, wparam, lParam)
      Protected Comctl32 = GetModuleHandle_("Comctl32.dll")
      Protected func.pDefSubclassProc = GetProcAddress(Comctl32, "DefSubclassProc")
      ProcedureReturn func(hWnd, Msg, wparam, lParam)
    EndProcedure
    Procedure RemoveWindowSubclass(hWnd, *Proc, *Id)
      Protected Comctl32 = GetModuleHandle_("Comctl32.dll")
      Protected func.pRemoveWindowSubclass = GetProcAddress(Comctl32, "RemoveWindowSubclass")
      ProcedureReturn func(hWnd, *Proc, *Id)
    EndProcedure
    Procedure GetWindowSubclass(hWnd, *Proc, *Id, *RefData)
      Protected Comctl32 = GetModuleHandle_("Comctl32.dll")
      Protected func.pGetWindowSubclass = GetProcAddress(Comctl32, "GetWindowSubclass")
      ProcedureReturn func(hWnd, *Proc, *Id, *RefData)
    EndProcedure
    ;}
    
    Procedure   GethWnd(ID)
     
      Protected hWnd = #False
     
      If IsGadget(ID)
        hWnd = GadgetID(ID)
      Else
        If IsWindow_(ID)
          hWnd = ID
        EndIf
      EndIf
     
      ProcedureReturn hWnd
     
    EndProcedure
    
    ;- ++++++ ListIconGadget Tools Start ++++++
   
    Procedure   AlignColumn(Gadget, Index, Format)
     
      ; by Danilo, 15.12.2003 - english chat (for 'Karbon')
      ; 20130615..nalor..modified
      ; change text alignment for columns
      ; #LVCFMT_LEFT / #LVCFMT_CENTER / #LVCFMT_RIGHT
     
      Protected lvc.LV_COLUMN, hWnd = GethWnd(Gadget)
     
      If hWnd
       
        lvc\mask = #LVCF_FMT
        lvc\fmt = Format
       
        SendMessage_(hWnd, #LVM_SETCOLUMN, Index, @lvc)
       
        ProcedureReturn #True
       
      EndIf
     
      ProcedureReturn #False
     
    EndProcedure
    Procedure   SetColumnWidth(Gadget, Index, New_Width)
     
      ; by Danilo, 15.12.2003 - english chat (for 'Karbon')
      ;
      ; change column header width
      ;
     
      Protected hWnd = GethWnd(Gadget)
     
      If hWnd
       
        SendMessage_(hWnd, #LVM_SETCOLUMNWIDTH, Index, New_Width)
        ProcedureReturn #True
       
      EndIf
     
      ProcedureReturn #False
     
    EndProcedure
    Procedure   SetSortIcon(Gadget, Column, SortOrder)
     
      ; http://stackoverflow.com/questions/254129/how-To-i-display-a-sort-arrow-in-the-header-of-a-List-view-column-using-c   
     
      Protected ColumnHeader
      Protected ColumnCount
      Protected hditem.HD_ITEM
      Protected Cnt
      Protected hWnd = GethWnd(Gadget)
     
      If hWnd
       
        ColumnHeader = SendMessage_(hWnd, #LVM_GETHEADER, 0, 0)
        ColumnCount  = SendMessage_(ColumnHeader, #HDM_GETITEMCOUNT, 0, 0)
       
        For Cnt = 0 To ColumnCount - 1
         
          hditem\mask=#HDI_FORMAT
         
          If SendMessage_(ColumnHeader, #HDM_GETITEM, Cnt, @hditem) = 0
            Debug "ERROR! LIG_SetSortIcon 1"
          EndIf
         
          hditem\mask=#HDI_FORMAT
         
          If (Cnt = Column And SortOrder <> #NoSort)
           
            Select SortOrder
               
              Case #AscSort ; wenn aufsteigend sortiert werden soll
                hditem\fmt& ~#HDF_SORTDOWN
                hditem\fmt|#HDF_SORTUP
                ;Debug "sortup"
               
              Case #DescSort
                hditem\fmt& ~#HDF_SORTUP
                hditem\fmt|#HDF_SORTDOWN               
                ;Debug "sortdown"
               
            EndSelect
           
          Else
           
            hditem\fmt& ~#HDF_SORTUP
            hditem\fmt& ~#HDF_SORTDOWN
           
          EndIf
         
          If (SendMessage_(ColumnHeader, #HDM_SETITEM, Cnt, @hditem) = 0)
            Debug "ERROR! LIG_SetSortIcon 2"
          EndIf
         
        Next cnt
       
        ProcedureReturn #True
       
      EndIf
     
      ProcedureReturn #False
     
    EndProcedure
    Procedure.b GetSortOrder(Gadget, Column)
     
      Protected ColumnHeader
      Protected hditem.HD_ITEM
      Protected RetVal.b = -1
      Protected hWnd = GethWnd(Gadget)
     
      If hWnd
       
        ColumnHeader = SendMessage_(hWnd, #LVM_GETHEADER, 0, 0)
       
        hditem\mask=#HDI_FORMAT
       
        If SendMessage_(ColumnHeader, #HDM_GETITEM, Column, @hditem)
         
          If (hditem\fmt&#HDF_SORTUP)=#HDF_SORTUP
           
            ;Debug "sortup"
            RetVal=#AscSort
           
          ElseIf (hditem\fmt&#HDF_SORTDOWN)=#HDF_SORTDOWN
           
            ;Debug "sortdown"
            RetVal=#DescSort
           
          Else
           
            ;Debug "keine sortierung"
            RetVal=#NoSort
           
          EndIf
         
        Else
         
          Debug "ERROR! LIG_GetSortOrder"
          RetVal=-1
         
        EndIf
       
      EndIf
     
      ProcedureReturn RetVal
     
    EndProcedure
    Procedure   EnsureVisible(Gadget, Line)
      ; makes sure the line is visible
     
      Protected hWnd = GethWnd(Gadget)
      If hWnd
        SendMessage_(hWnd, #LVM_ENSUREVISIBLE, Line, #True)
        ProcedureReturn #True 
      EndIf
      ProcedureReturn #False
     
    EndProcedure
   
    ;- ##### ListIconGadget Tools Ende #####
   
    ;- ++++++ ListIconGadget Sort Start ++++++
   
    ; http://msdn.microsoft.com/de-de/library/bb979183.aspx   
    ; Die Struktur LVWSORT enthält Informationen über das zu sortierende ListView-Steuerelement, die Spalte,
    ; nach der sortiert werden soll, sowie die gewünschte Sortierrichtung.
   
    Procedure.b IsNumChar(*Text, Position = 1)
      Select Asc(PeekS(*Text+(Position-1)*SizeOf(Character), 1))
        Case 48 To 57
          ProcedureReturn #True
        Default
          ProcedureReturn #False
      EndSelect
    EndProcedure
    Procedure   CompareStrings(*sEntry1, *sEntry2, SortOrder.b)
      ; ' -----------------------------------------------------
      ; ' 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 = #AscSort
        ; Aufsteigende Sortierung zweier unterschiedlicher Strings
        If CompareMemoryString(*sEntry1, *sEntry2, #PB_String_NoCase) = #PB_String_Lower
          ProcedureReturn -1
        Else
          ProcedureReturn 1
        EndIf
      Else ; Absteigende Sortierung
        If CompareMemoryString(*sEntry1, *sEntry2, #PB_String_NoCase) = #PB_String_Greater
          ProcedureReturn -1
        Else
          ProcedureReturn 1
        EndIf
      EndIf
     
    EndProcedure
    Procedure   CompareNumbers(sEntry1.s, sEntry2.s, SortOrder.b)
      ; ' -----------------------------------------------------
      ; ' 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 = #AscSort
        ; Aufsteigende Sortierung zweier unterschiedlicher Zahlen
        If Val(sEntry1) < Val(sEntry2)
          ProcedureReturn -1
        Else
          ProcedureReturn 1
        EndIf
      Else ; Absteigende Sortierung
        If Val(sEntry1) > Val(sEntry2)
          ProcedureReturn -1
        Else
          ProcedureReturn 1
        EndIf
      EndIf
     
    EndProcedure
    Procedure   CompareFloat(sEntry1.s, sEntry2.s, SortOrder.b)
      ; ' -----------------------------------------------------
      ; ' 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:
     
      ReplaceString(sEntry1, ",", ".", #PB_String_InPlace, 1, 1) ; ersetze Dezimalkomma durch Punkt, damit ValF korrekt arbeitet
      ReplaceString(sEntry2, ",", ".", #PB_String_InPlace, 1, 1)
     
      If SortOrder = #AscSort
        ; Aufsteigende Sortierung zweier unterschiedlicher Zahlen
        If ValF(sEntry1) < ValF(sEntry2)
          ProcedureReturn -1
        Else
          ProcedureReturn 1
        EndIf
      Else ; Absteigende Sortierung
        If ValF(sEntry1) > ValF(sEntry2)
          ProcedureReturn -1
        Else
          ProcedureReturn 1
        EndIf
      EndIf         
     
    EndProcedure
    Procedure   CompareDate(sEntry1.s, sEntry2.s, SortOrder.b, sDateMask.s)
      ; ' -----------------------------------------------------
      ; ' 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 = #AscSort
        ; Aufsteigende Sortierung zweier unterschiedlicher Zahlen
        If ParseDate(sDateMask, sEntry1) < ParseDate(sDateMask, sEntry2)
          ProcedureReturn -1
        Else
          ProcedureReturn 1
        EndIf
      Else ; Absteigende Sortierung
        If ParseDate(sDateMask, sEntry1) > ParseDate(sDateMask, sEntry2)
          ProcedureReturn -1
        Else
          ProcedureReturn 1
        EndIf
      EndIf         
     
    EndProcedure
    Procedure.s LvwGetText(*ListViewSort.LVWSORT, lParam)
      ; ' -----------------------------------------------------
      ; ' 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.
      ; ' -----------------------------------------------------
      Protected udtFindInfo.LV_FINDINFO, udtLVItem.LV_ITEM
      Protected lngIndex, *baBuffer, lngLength, RetVal.s = ""
     
      *baBuffer = AllocateMemory(512)
     
      If *baBuffer
       
        ; Auf Basis des Index den Text der Zelle auslesen:
        udtLVItem\mask=#LVIF_TEXT
        udtLVItem\iSubItem=*ListViewSort\SortKey
        udtLVItem\pszText=*baBuffer
        udtLVItem\cchTextMax=(512/SizeOf(Character))-1
       
        lngLength = SendMessage_(*ListViewSort\hWndListView, #LVM_GETITEMTEXT, lParam, @udtLVItem)
       
        ; Byte-Array in passender Länge als String-Rückgabewert kopieren:
       
        If lngLength > 0
          RetVal = PeekS(*baBuffer, lngLength)
        EndIf
        FreeMemory(*baBuffer) ; thx LittleJohn
       
      EndIf
   
      ProcedureReturn RetVal
     
    EndProcedure
    Procedure   CompareFunc(lParam1, lParam2, lParamSort)
      ; ' -----------------------------------------------------
      ; ' 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
      ; ' -----------------------------------------------------
      Protected *ListViewSort.LVWSORT
      Protected sEntry1.s
      Protected sEntry2.s
      Protected vCompare1.s ; As Variant
      Protected vCompare2.s ; As Variant
     
      ; In lParamSort von SortListView als Long-Pointer übergebene LVWSORT-Struktur abholen, um auf deren
      ; Werte zugreifen zu können:
     
      *ListViewSort=lParamSort
     
      ; 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)
     
      ; Sind die Elemente gleich, kann die Funktion sofort mit dem aktuellen Rückgabewert 0
      ; verlassen werden:
      If sEntry1 = sEntry2
        ProcedureReturn 0
      EndIf
     
      ; Für die Sortierung wird unterschieden zwischen Zahlen, Fließkommazahlen und allgemeinen Strings. Hierfür
      ; steht jeweils eine separate, private Vergleichsfunktion zur Verfügung.
     
      Select *ListViewSort\SortType
        Case #SortNumeric ; ' Spalteninhalte sind Zahlen
          ProcedureReturn CompareNumbers(sEntry1, sEntry2, *ListViewSort\SortOrder)
        Case #SortFloat ; ' Spalteninhalte sind Zahlen mit Nachkommastellen
          ProcedureReturn CompareFloat(sEntry1, sEntry2, *ListViewSort\SortOrder)
        Case #SortString;  ' Spalteninhalte sind Strings
          ProcedureReturn CompareStrings(@sEntry1, @sEntry2, *ListViewSort\SortOrder)
        Case #SortDate
          ProcedureReturn CompareDate(sEntry1, sEntry2, *ListViewSort\SortOrder, *ListViewSort\DateFormat)
      EndSelect
    EndProcedure
    Procedure.s GetDateFormat(Date.s)
     
      ;Debug "GetDateFormat >"+Date+"<"
     
      Protected Diff.i
     
      Diff=Len(Date)-CountString(Date, "0")-CountString(Date, "1")-CountString(Date, "2")-CountString(Date, "3")-CountString(Date, "4")-CountString(Date, "5")-CountString(Date, "6")-CountString(Date, "7")-CountString(Date, "8")-CountString(Date, "9")   
     
      Select Diff
        Case 2
          If Len(Date)=10 ; Date 'dd.mm.yyyy', 'mm.dd.yyyy' or 'yyyy.mm.dd'
           
            If (Not IsNumChar(@Date, 5) And Not IsNumChar(@Date, 8)) ; yyyy.mm.dd
              ProcedureReturn "" ; faster to sort as string
             
            ElseIf (Not IsNumChar(@Date, 3) And Not IsNumChar(@Date, 6)) ; dd.mm.yyyy or mm.dd.yyyy
              If Val(Mid(Date, 4, 2))>12 ; is it mm.dd.yyyy?
                ProcedureReturn "%mm"+Mid(Date, 3, 1)+"%dd"+Mid(Date, 6, 1)+"%yyyy"
              Else ; default is dd.mm.yyyy
                ProcedureReturn "%dd"+Mid(Date, 3, 1)+"%mm"+Mid(Date, 6, 1)+"%yyyy"
              EndIf
             
            Else
              ProcedureReturn "" ; not a date - sort as string
            EndIf
          Else
            ProcedureReturn "" ; not a date - sort as string
          EndIf
         
        Case 4
          If Len(Date)=16 ;yyyy-mm-dd hh:mm, dd-mm-yyyy hh:mm or mm-dd-yyyy hh:mm
           
            If (Not IsNumChar(@Date, 5) And Not IsNumChar(@Date, 8)) ; yyyy.mm.dd xxxxx
              ProcedureReturn "" ; faster to sort as string
             
            ElseIf (Not IsNumChar(@Date, 3) And Not IsNumChar(@Date, 6)) ; dd.mm.yyyy hh:mm or mm.dd.yyyy hh:mm
              If Val(Mid(Date, 4, 2))>12 ; is it mm.dd.yyyy?
                ProcedureReturn "%mm"+Mid(Date, 3, 1)+"%dd"+Mid(Date, 6, 1)+"%yyyy"+Mid(Date, 11, 1)+"%hh"+Mid(Date, 14, 1)+"%mm"
              Else ; default is dd.mm.yyyy
                ProcedureReturn "%dd"+Mid(Date, 3, 1)+"%mm"+Mid(Date, 6, 1)+"%yyyy"+Mid(Date, 11, 1)+"%hh"+Mid(Date, 14, 1)+"%mm"
              EndIf
             
            Else
              ProcedureReturn "" ; not a date - sort as string
            EndIf
          Else
            ProcedureReturn "" ; not a date - sort as string
          EndIf           
         
        Case 5 ; 5 other chars, possibly DateTime?
         
          If Len(Date)=19 ;yyyy-mm-dd hh:mm, dd-mm-yyyy hh:mm or mm-dd-yyyy hh:mm
           
            If (Not IsNumChar(@Date, 5) And Not IsNumChar(@Date, 8)) ; yyyy.mm.dd xxxxx
              ProcedureReturn "" ; faster to sort as string
             
            ElseIf (Not IsNumChar(@Date, 3) And Not IsNumChar(@Date, 6)) ; dd.mm.yyyy hh:mm or mm.dd.yyyy hh:mm
              If Val(Mid(Date, 4, 2))>12 ; is it mm.dd.yyyy?
                ProcedureReturn "%mm"+Mid(Date, 3, 1)+"%dd"+Mid(Date, 6, 1)+"%yyyy"+Mid(Date, 11, 1)+"%hh"+Mid(Date, 14, 1)+"%mm"+Mid(Date, 17, 1)+"%ss"
              Else ; default is dd.mm.yyyy
                ProcedureReturn "%dd"+Mid(Date, 3, 1)+"%mm"+Mid(Date, 6, 1)+"%yyyy"+Mid(Date, 11, 1)+"%hh"+Mid(Date, 14, 1)+"%mm"+Mid(Date, 17, 1)+"%ss"
              EndIf
             
            Else
              ProcedureReturn "" ; not a date - sort as string
            EndIf
          Else
            ProcedureReturn "" ; not a date - sort as string
          EndIf
         
        Default
          ProcedureReturn ""
      EndSelect
     
    EndProcedure
    Procedure   SortListView(hWndListView, SortKey, SortType.b, SortOrder.b)
      ; ' -----------------------------------------------------
      ; ' Ö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
      ; ' -----------------------------------------------------
     
      Protected udtLVWSORT.LVWSORT
      Protected sDateFormat.s, sTemp.s, GadId.i
     
      If SortType = #SortDate
        GadId = GetDlgCtrlID_(hWndListView)
        sDateFormat = GetDateFormat(GetGadgetItemText(GadId, 0, SortKey))
       
        If sDateFormat = ""
          SortType = #SortString
        Else
          sTemp = GetDateFormat(GetGadgetItemText(GadId, CountGadgetItems(GadId)-1, SortKey))
          If sTemp=""
            SortType=#SortString
          Else
            If sTemp<>sDateFormat
              If Left(sTemp, 3)="%mm" ; new format starts with %mm (.dd.yyyy) - if this US format is detected it has higher prio
                sDateFormat=sTemp
              EndIf
            EndIf
            sTemp=GetDateFormat(GetGadgetItemText(GadId, CountGadgetItems(GadId)/2, SortKey))
            If sTemp=""
              SortType=#SortString
            Else
              If sTemp<>sDateFormat
                If Left(sTemp, 3)="%mm" ; new format starts with %mm (.dd.yyyy) - if this US format is detected it has higher prio
                  sDateFormat=sTemp
                EndIf
              EndIf
            EndIf   
          EndIf         
        EndIf
        udtLVWSORT\DateFormat=sDateFormat
        ;Debug "Final DateFormat >"+sDateFormat+"<"
      EndIf
     
      ; Übergebene Informationen in einer LVWSORT-Struktur zusammenfassen:
      udtLVWSORT\hWndListView=hWndListView
      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_(hWndListView, #LVM_SORTITEMSEX, @udtLVWSORT, @CompareFunc())
     
    EndProcedure
    Procedure.b DetectOrderType(sText.s)
     
      Protected Diff
     
      Diff=Len(sText)-CountString(sText, "0")-CountString(sText, "1")-CountString(sText, "2")-CountString(sText, "3")-CountString(sText, "4")-CountString(sText, "5")-CountString(sText, "6")-CountString(sText, "7")-CountString(sText, "8")-CountString(sText, "9")   
     
      Select Diff
        Case 0 ; es sind nur Ziffern
          ProcedureReturn #SortNumeric
         
        Case 1 ; nur 1 anderes Zeichen
          If (CountString(sText, ",")>0 Or CountString(sText, ".")>0)
            ProcedureReturn #SortFloat
          ElseIf (Left(sText, 1)="$" Or Left(sText, 1)="%") ; es ist eine HEX oder Binär Zahl
            ProcedureReturn #SortNumeric
          Else
            ProcedureReturn #SortString
          EndIf
         
        Case 2 ; 2 andere Zeichen - evtl. Datum?
         
          If (Len(sText)=10 And
              Not IsNumChar(@sText, 3) And Not IsNumChar(@sText, 6))
            ; dd-mm-yyyy or mm-dd-yyyy
            ProcedureReturn #SortDate
          Else
            ; yyyy-mm-dd
            ProcedureReturn #SortString
          EndIf
         
        Case 4 ; 4 other chars, possibly DateTime?
         
          If (Len(sText)=16 And
              Not IsNumChar(@sText, 3) And Not IsNumChar(@sText, 6) And
              Not IsNumChar(@sText, 11) And Not IsNumChar(@sText, 14))
            ;dd-mm-yyyy hh:mm or mm-dd-yyyy hh:mm
            ProcedureReturn #SortDate
          Else
            ProcedureReturn #SortString
          EndIf
         
        Case 5 ; 5 other chars, possibly DateTime?
         
          If (Len(sText)=19 And
              Not IsNumChar(@sText, 3) And Not IsNumChar(@sText, 6) And
              Not IsNumChar(@sText, 11) And Not IsNumChar(@sText, 14) And Not IsNumChar(@sText, 17))
            ;dd-mm-yyyy hh:mm:ss or mm-dd-yyyy hh:mm:ss
            ProcedureReturn #SortDate
          Else
            ProcedureReturn #SortString
          EndIf         
         
        Default
          ProcedureReturn #SortString
         
      EndSelect
     
    EndProcedure
    Procedure   SortColumn(Gadget, Column, OrderType.b = #SortAutoDetect)
     
      Protected ColCnt, Order, iStartT, iEndT, Temp.b
     
      If Not IsGadget(Gadget) : ProcedureReturn #False : EndIf
     
      ;Debug "LIG_SortColumn >"+Str(Gadget)+"< Spalte >"+Str(Column)+"<"
     
      Select GetSortOrder(Gadget, Column)
        Case #NoSort, #DescSort
          Order = #AscSort
        Case #AscSort
          Order = #DescSort
      EndSelect
     
      iStartT=ElapsedMilliseconds()
     
      If OrderType = #SortAutoDetect ; detect it automatically - check first, last and middle item of list
        OrderType = DetectOrderType(GetGadgetItemText(Gadget, 0, Column))
        If (OrderType = DetectOrderType(GetGadgetItemText(Gadget, CountGadgetItems(Gadget)-1, Column)))
          If (OrderType <> DetectOrderType(GetGadgetItemText(Gadget, CountGadgetItems(Gadget)/2, Column)))
            ;Debug "Different OrderType - use SortString 2"
            OrderType = #SortString
          EndIf
        Else
          ;Debug "Different OrderType - use SortString"
          OrderType = #SortString
        EndIf
      EndIf   
     
      SortListView(GadgetID(Gadget), Column, OrderType, Order)
     
      iEndT  =ElapsedMilliseconds()
     
      ;Debug "Dauer >"+StrF( (iEndT-iStartT)/1000, 2)+"<"
     
      SetSortIcon(Gadget, Column, Order)
     
      If (GetGadgetState(Gadget) > -1)
        EnsureVisible(Gadget, GetGadgetState(Gadget))
      EndIf
     
    EndProcedure
   
    ;- ##### ListIconGadget Sort Ende ######
   
    Procedure ColumnClickCallback(hWnd, uMsg, wParam, lParam, ID, *refData)
      ; Edel
      Protected *msg.NM_LISTVIEW
     
      If uMsg = #WM_NOTIFY
        *msg = lParam
        If *msg\hdr\code = #LVN_COLUMNCLICK    
          SortColumn(GetDlgCtrlID_(*msg\hdr\hwndfrom), *msg\iSubItem)
        EndIf
      EndIf
     
      ProcedureReturn DefSubclassProc(hWnd, uMsg, wParam, lParam)
     
    EndProcedure
    Procedure ColumnClickCallback_SubClass(hWnd, uMsg, wParam, lParam, ID, *refData)
      ; --- Bisonte
      Protected *msg.NM_LISTVIEW

      Select uMsg
        Case #WM_DESTROY
          RemoveWindowSubclass(hWnd, @ColumnClickCallback_SubClass(), ID)

        Case #WM_NOTIFY
          *msg = lParam
          If *msg\hdr\code = #HDN_ITEMCLICK
            SortColumn(GetDlgCtrlID_(hWnd), *msg\iItem)  
          EndIf
          
      EndSelect
      
      ProcedureReturn DefSubclassProc(hWnd, uMsg, wParam, lParam)
     
    EndProcedure    
    
    Procedure Enable(Gadget)
      ; --- method by edel
      SetWindowSubclass(GetParent_(GadgetID(Gadget)), @ColumnClickCallback(), 0, 0)
      ; --- method by bisonte
      ;SetWindowSubclass(GadgetID(Gadget), @ColumnClickCallback_SubClass(), #Null, #Null)
    EndProcedure
   
  EndModule
 
  DisableExplicit
 
CompilerElse
 
  MessageRequester("PureBasic", "PureBasic V5.20 or higher needed!") : End
 
CompilerEndIf
CompilerIf #PB_Compiler_IsMainFile
  
  Enumeration #PB_Compiler_EnumerationValue
    #MainWin
  EndEnumeration
  Enumeration #PB_Compiler_EnumerationValue
    #ListIcon
  EndEnumeration
  
  Procedure OpenMainWin()
    OpenWindow(#MainWin, 0, 0, 850, 500, "ListIconGadget-SortExample", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
    
    ListIconGadget(#ListIcon, 10, 10, 830, 480, "COL 0", 150, #PB_ListIcon_GridLines | #PB_ListIcon_FullRowSelect)
    AddGadgetColumn(#ListIcon, 1, "COL 1", 100)
    AddGadgetColumn(#ListIcon, 2, "COL 2", 100)
    AddGadgetColumn(#ListIcon, 3, "COL 3 (NUM)", 100)
    AddGadgetColumn(#ListIcon, 4, "COL 4 (FLOAT)", 100)
    AddGadgetColumn(#ListIcon, 5, "COL 5 (DATE)", 100)
    AddGadgetColumn(#ListIcon, 6, "COL 6 (DATETIME)", 150)
  EndProcedure
  
  Procedure MainWin_Events(event)
    Select event
      Case #PB_Event_CloseWindow
        ProcedureReturn #False
        
    EndSelect
    ProcedureReturn #True
  EndProcedure
  
  
  Define iEvent.i
  Define iEventWindow.i
  Define iCloseAll.i
  Define a.i, x.i
  Define A$, B$, C$, D$, E$, F$, G$
  
  OpenMainWin()
  
  ; generate Test Values:
  
  For a = 0 To 1000
    
    A$ = "COL 1, Row "+RSet(Str(  a  ),6,"0")+Chr(10)
    
    B$ =RSet(Str(Random($FFFF)),5,"0")+Chr(10)
    
    C$ ="$"+RSet(Hex(Random($7FFFFFFF)),8,"0")+Chr(10)
    
    Select Random(5, 1)
      Case 1
        D$=Str(Random(9, 0))
      Case 2
        D$=Str(Random(99, 10))
      Case 3
        D$=Str(Random(999, 100))
      Case 4
        D$=Str(Random(9999, 1000))
      Case 5
        D$=Str(Random(99999, 10000))
    EndSelect         
    D$+Chr(10)
    
    Select Random(5, 1)
      Case 1
        E$=Str(Random(9, 0))+","+Str(Random(99, 0))
      Case 2
        E$=Str(Random(99, 10))+","+Str(Random(99, 0))
      Case 3
        E$=Str(Random(999, 100))+","+Str(Random(99, 0))
      Case 4
        E$=Str(Random(9999, 1000))+","+Str(Random(99, 0))
      Case 5
        E$=Str(Random(99999, 10000))+","+Str(Random(99, 0))
    EndSelect
    E$+Chr(10)
    
    F$=FormatDate("%dd.%mm.%yyyy", Random(Date(), 0))+Chr(10)
    
    G$=FormatDate("%mm-%dd-%yyyy %hh:%mm:%ss", Random(Date(), 0))
    
    AddGadgetItem(#ListIcon, a, A$+B$+C$+D$+E$+F$+G$)
    
  Next
  
  nalorLIG::Enable(#ListIcon)

  Repeat
    
    iEvent = WaitWindowEvent()
    iEventWindow=EventWindow()
    
    Select iEventWindow
      Case #MainWin
        If (Not MainWin_Events(iEvent))
          iCloseAll=#True
        EndIf
    EndSelect
    
  Until iCloseAll=#True
  
CompilerEndIf
Alle Zeiten sind UTC+02:00
Seite 3 von 4

Powered by phpBB® Forum Software © phpBB Limited

Deutsche Übersetzung durch phpBB.de