Avatar of stephenlecomptejr
stephenlecomptejr
Flag for United States of America asked on

Need help with listing modules adjusted by their modified date in descending order using Microsoft Access VBA?

I have the following code and it never sorts the modified date of the modules correctly.  Please let me know where and what syntax I have wrong please!

Private Sub FILL_MODULES_BYDATE()
On Error GoTo Err_Proc

  Dim obj As AccessObject, dbs As Object
  Dim f As Form
  Dim i As Integer
  Dim j As Integer
  Dim iTotal As Integer
  Dim cModules() As Variant
  Dim sName As String
  Dim dDate As Date
  
  Set dbs = Application.CurrentProject
  
  iTotal = dbs.AllModules.Count
  ReDim cModules(iTotal, 2)
  
  For Each obj In dbs.AllModules
'      Debug.Print obj.name
'      Debug.Print obj.name, obj.DateModified
      cModules(i, 1) = obj.NAME
      cModules(i, 2) = CDate(obj.DateModified)
      i = i + 1
  Next obj
  Call SendMsg("total no of modules: " & i & " - sorting them...")
  
  'Sort
  For i = 0 To iTotal - 1
      For j = 1 To iTotal
          If cModules(j, 2) > cModules(i, 2) Then
              sName = cModules(j, 1)
              dDate = cModules(j, 2)
              cModules(j, 1) = cModules(i, 1)
              cModules(j, 2) = cModules(i, 2)
              cModules(i, 1) = sName
              cModules(i, 2) = dDate
          End If
      Next
  Next
  Call SendMsg("total no of modules: " & i & " - adding to listbox...")
  For i = 0 To iTotal
      
      If cModules(i, 1) <> "" Then
          List6.AddItem cModules(i, 1)
      End If
  Next i

Set dbs = Nothing

Exit_Proc:
  Exit Sub
  
Err_Proc:
  Call LogError(Err.Number, Err.Description, "_fSpecificUpdate @ Run_Query_Process")
  Resume Exit_Proc
End Sub

Open in new window

* microsoft access formsMicrosoft AccessVBA

Avatar of undefined
Last Comment
stephenlecomptejr

8/22/2022 - Mon
Gustav Brock

First, the date is a date, so no use for CDate.
Second, the DateModfied seems to be same for all modules, so nothing sort on.

If you sort on the created date

     cModules(i, 2) = obj.DateCreated '.DateModified

Open in new window

it works correctly, except for the first entry.
So, you must adjust your array sorting code.

You may modify the one I am using:

' Quickly sort a Variant array.
'
' The array does not have to be zero- or one-based.
'
' 2018-03-16. Gustav Brock, Cactus Data ApS, CPH.
'
Public Sub QuickSort(ByRef Values As Variant)

    Dim Lows()      As Variant
    Dim Mids()      As Variant
    Dim Tops()      As Variant
    Dim Pivot       As Variant
    Dim Lower       As Long
    Dim Upper       As Long
    Dim UpperLows   As Long
    Dim UpperMids   As Long
    Dim UpperTops   As Long
    
    Dim Value       As Variant
    Dim Item        As Long
    Dim Index       As Long
 
    ' Find count of elements to sort.
    Lower = LBound(Values)
    Upper = UBound(Values)
    If Lower = Upper Then
        ' One element only.
        ' Nothing to do.
        Exit Sub
    End If
    
    
    ' Choose pivot in the middle of the array.
    Pivot = Values(Int((Upper - Lower) / 2) + Lower)
    ' Construct arrays.
    For Each Value In Values
        If Value < Pivot Then
            ReDim Preserve Lows(UpperLows)
            Lows(UpperLows) = Value
            UpperLows = UpperLows + 1
        ElseIf Value > Pivot Then
            ReDim Preserve Tops(UpperTops)
            Tops(UpperTops) = Value
            UpperTops = UpperTops + 1
        Else
            ReDim Preserve Mids(UpperMids)
            Mids(UpperMids) = Value
            UpperMids = UpperMids + 1
        End If
    Next
    
    ' Sort the two split arrays, Lows and Tops.
    If UpperLows > 0 Then
        QuickSort Lows()
    End If
    If UpperTops > 0 Then
        QuickSort Tops()
    End If
    
    ' Concatenate the three arrays and return Values.
    Item = 0
    For Index = 0 To UpperLows - 1
        Values(Lower + Item) = Lows(Index)
        Item = Item + 1
    Next
    For Index = 0 To UpperMids - 1
        Values(Lower + Item) = Mids(Index)
        Item = Item + 1
    Next
    For Index = 0 To UpperTops - 1
        Values(Lower + Item) = Tops(Index)
        Item = Item + 1
    Next

End Sub

Open in new window

stephenlecomptejr

ASKER
Gustav, so you telling me it's not possible to sort descend on the modified date?  since they are always the same.  sheesh... I really need to be able to tell that - not created date.

There has to be some way to do identify that.  Maybe for each coding module, if I put in a unique line item that states a date and then sorts by that?
Gustav Brock

I thought this would, but LastUpdated seems not to be updated:

Public Sub ListModules()

    Dim Database    As DAO.Database
    Dim Modules     As DAO.Container
    Dim Module      As DAO.Document
    
    Set Database = CurrentDb
    Set Modules = Database.Containers(3)
    
    For Each Module In Modules.Documents
        Debug.Print Module.Name, Module.DateCreated, Module.LastUpdated
    Next
    
    Set Module = Nothing
    Set Modules = Nothing
    Set Database = Nothing
    
End Sub

Open in new window

All of life is about relationships, and EE has made a viirtual community a real community. It lifts everyone's boat
William Peck
Fabrice Lambert

For a more versatile solution, you can implement a sortable container:
    '// Class module: List
Option Explicit

Private mItems As Collection

Private Sub Class_Initialize()
    Set mItems = New Collection
End Sub

Public Sub Push_back(ByRef Item As Variant)
    mItems.Add Item
End Sub

    '// Default member
Public Property Get Item(ByVal Index As Long) As Variant
Attribute Item.VB_UserMemId = 0
    Debug.Assert Index >= 0 And Index < mItems.Count
    If (IsObject(Item)) Then
        Set Item = mItems(Index + 1)
    Else
        Item = mItems(Index + 1)
    End If
End Property

Public Property Let Item(ByVal Index As Long, ByRef Item As Variant)
    Debug.Assert Index >= 0 And Index < mItems.Count
    mItems.Remove Index + 1
On Error GoTo Error
    mItems.Add Item, before:=Index + 1
Exit Property
Error:
    mItems.Add Item
End Property

Public Property Set Item(ByVal Index As Long, ByRef Item As Variant)
    Debug.Assert Index >= 0 And Index < mItems.Count
    Set mItems(Index + 1) = Item
End Property

Public Sub Pop_front()
    mItems.Remove 1
End Sub

Public Sub Pop_back()
    mItems.Remove mItems.Count
End Sub

Public Sub Pop(ByVal Index As Long)
    Debug.Assert Index >= 0 And Index < mItems.Count
    mItems.Remove Index
End Sub

Public Function Count() As Long
    Count = mItems.Count
End Function

    '// Enumerator
Public Function NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
    Set NewEnum = mItems.[_NewEnum]
End Function

Public Sub Sort(ByRef Comparator As IComparator)
    Dim Item As Variant
    Dim i As Long
    For i = 1 To mItems.Count
        Dim j As Long
        For j = 1 To mItems.Count
            If (Comparator.IsInferior(mItems(i), mItems(j))) Then
                If (IsObject(mItems(i))) Then
                    Set Item = mItems(i)
                Else
                    Item = mItems(i)
                End If
                mItems.Remove i
                On Error GoTo Error
                mItems.Add Item, before:=j
                On Error GoTo 0
            End If
        Next
    Next
Exit Sub
Error:
    mItems.Add Item
    Resume Next
End Sub

Open in new window

The Sort member function require an object derived from the IComparator interface wich has the following definition:
    '// Class module: IComparator
    '// Interface
Option Explicit

Public Function IsInferior(ByRef First As Variant, ByRef Second As Variant) As Boolean
End Function

Open in new window


Sample code:
First, write a class that implement the IComparator interface (in this sample, it compare integers):
    '// Class module: IntegerComparator
Option Explicit
Implements IComparator
Private Function IComparator_IsInferior(First As Variant, Second As Variant) As Boolean
    IComparator_IsInferior = First < Second
End Function

Open in new window

To use it, just instanciate a List, fill it up, and call the Sort member function:
Public Sub test()
    Dim lst As List
    Set lst = New List
    lst.Push_back 3
    lst.Push_back 5
    lst.Push_back 1
    lst.Push_back 10
    lst.Push_back -1

    lst.Sort New IntegerComparator
   
    Dim Item As Variant
    For Each Item In lst
        Debug.Print Item
    Next
End Sub

Open in new window

Note that for this to work the list need to be homogenous.
Fabrice Lambert

Also,
The updated date can be retrieved from the MSysObjects table with the following query:
SELECT DateUpdate
FROM MSysObjects
WHERE MSysObjects.Name= "Desired Name";

Open in new window

Or if you want to use parameters:
PARAMETERS Name Text ( 255 );
SELECT DateUpdate
FROM MSysObjects
WHERE MSysObjects.Name = [Name];

Open in new window

Or with a simple Dlookup:
DLookup("DateUpdate", "MSysObjects", "Name = " & "Desired name")

Open in new window

Fabrice Lambert

Applied to your code, this can look like the following:
Note that you need a custom class to store data from modules.
    '// Class module: ModuleData
Option Explicit

Public Name As String
Public DateModified As Date

Open in new window

    '// Class Module: ModuleDataComparator
Option Explicit
Implements IComparator

Private Function IComparator_IsInferior(First As Variant, Second As Variant) As Boolean
    IComparator_IsInferior = First.DateModified < Second.DateModified
End Function

Open in new window

    '// Standard module
Option Compare Database
Option Explicit

Public Sub FILL_MODULES_BYDATE()
    Dim Project As Object
    Set Project = Application.CurrentProject

    Dim Modules As List
    Set Modules = New List
   
    Dim Module As Object
    For Each Module In Project.AllModules
        Dim Mdl As ModuleData
        Set Mdl = New ModuleData

        Mdl.Name = Module.Name
        Mdl.DateModified = DLookup("DateUpdate", "MSysObjects", "Name = """ & Module.Name & """")
        Modules.Push_back Mdl
    Next

    Call SendMsg("total no of modules: " & Modules.Count & " - sorting them...")
   
    Modules.Sort New ModuleDataComparator
   
    Call SendMsg("total no of modules: " & Modules.Count & " - adding to listbox...")
   
    For Each Module In Modules
        List6.AddItem Module.Name
    Next
End Sub

Open in new window

Get an unlimited membership to EE for less than $4 a week.
Unlimited question asking, solutions, articles and more.
stephenlecomptejr

ASKER
Fabrice, I think this solution is cool in a way to have a better sorting algorithm... however my concern is that the date modified on the objects are not accurate at all when it comes to coding modules when modified.
Fabrice Lambert

It is not about algorithm, it is about genericity.

And in case I repeat myself:
The updated date can be retrieved from the MSysObjects table
stephenlecomptejr

ASKER
Got it now.  Thank you for the code greatly.  Let me incorporate this into my code and get back to you sir.
Your help has saved me hundreds of hours of internet surfing.
fblack61
ASKER CERTIFIED SOLUTION
Gustav Brock

Log in or sign up to see answer
Become an EE member today7-DAY FREE TRIAL
Members can start a 7-Day Free trial then enjoy unlimited access to the platform
Sign up - Free for 7 days
or
Learn why we charge membership fees
We get it - no one likes a content blocker. Take one extra minute and find out why we block content.
Not exactly the question you had in mind?
Sign up for an EE membership and get your own personalized solution. With an EE membership, you can ask unlimited troubleshooting, research, or opinion questions.
ask a question
stephenlecomptejr

ASKER
And in case I repeat myself:
The updated date can be retrieved from the MSysObjects table

lol