SHARE
TWEET

Access Listbox Resize Class

Ben_S May 23rd, 2019 125 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Option Compare Database
  2. Option Explicit
  3. Option Base 0
  4.  
  5. ' Allows the columns on a ListBox control to be resized.
  6. '
  7. ' Written by Alex Wellerstein in 2007, released without any stipulations or warranties.
  8. '  http://alexwellerstein.com/msaccess/
  9. '
  10. ' Ben Sacherich - 3/28/2016:  Turned this into a class module.  I will note that I experimented with another column
  11. ' resizing class made by Stephen Lebans but didn't like the way it resized columns.  This code seemed simpler to implement.
  12. '
  13. '
  14. ' Usage:
  15. '
  16. '    '//// Add this line to the module header ////
  17. '    Private ListboxColumnResize As clsListboxColumnResize
  18. '
  19. '
  20. '    '//// Add these lines to the Form_Load() event. ////
  21. '    ' Create a new instance of our class
  22. '    Set ListboxColumnResize = New clsListboxColumnResize
  23. '
  24. '    ' We must tell the Class which control we want to work with.
  25. '    ListboxColumnResize.SetupListbox <ListBox Control>
  26. '
  27. '    ' Turn on our flag to allow column heading sort.  This defaults to True when the list has column headings.
  28. '    ListboxColumnResize.EnableColumnHeadingSort = True
  29. '
  30. '    ' Identify clickable column heading labels for sorting.
  31. '    ' If you have a hidden column with no heading, like when column 0 is hidden, just pass the next visible
  32. '    ' column heading label twice in a row.
  33. '    'ListboxColumnResize.SetupColumnLabels lblCode, lblItem, lblName, lblLength
  34. '
  35. '    '//// Add this to the Form_Unload() for proper cleanup ////
  36. '    Private Sub Form_Unload(Cancel As Integer)
  37. '        ' Release the reference to our class
  38. '        Set ListboxColumnResize = Nothing
  39. '    End Sub
  40. '
  41. ' In each case of <ListBox Control>, substitute the name of the ListBox control.
  42. '
  43. ' That's it! If you want to make captions move along with the columns that are being
  44. ' resized, you can use the DividerLeft function to get the .Left position for the
  45. ' caption on the form based on the current column positions.
  46. '
  47. ' You can adjust the ListResizeMouseTolerance constant if you want to change how
  48. ' "sticky" the column dividers are (how close to them you need to click).
  49.  
  50. '############ WARNING ############
  51. ' This routine causes Access 2010 to crash hard if the .ColumnWidths is modfied during the MouseMove event.
  52. ' The suggested work around is to call the ListColumnResizeMouseDown() function from the MouseUp event.  The
  53. ' only downside of this seems to be the visual feedback of seeing the column resize as you drag.
  54. ' Ben Sacherich and Anders Ebro ("The Smiley Coder") - March 2016
  55.  
  56. ' Ben Sacherich - 3/28/2016:  Turned this into a class module.  I will note that I experimented with another column
  57. ' resizing class made by Stephen Lebans but didn't like the way it resized columns.  This code seemed simpler to convert.
  58. '
  59. ' Limitations:
  60. '   - The user may not discover that columns are resizable because the mouse cursor does not
  61. '       change as it hovers over a column divider.
  62. '   - The user does not see the column resize until they release the mouse button.
  63. '   - The columns can be resized by grabbing any visible divider, not just in the column heading.
  64. '       This allows it to work even when column headings are not visible, but then requires
  65. '       additional work to get the headings to resposition.  The SetupColumnLabels() method
  66. '       may help with this but it has limitations, like not handling hidden columns.
  67. '   - You can't drag a column width past the next column divider in one drag.  It takes multiple steps.
  68. '   - In my testing DividerLeft() was not positioning the last column after the first resize.
  69. '       I ran out of time debugging this so it will have to wait until another day.
  70. '
  71. ' BS 7/5/2016:  I was getting annoyed by the resize routine intercepting regular row clicks so I modified
  72. '       it to only let the columns resize if clicking dividers near the top of the list.
  73. '       MouseY of 400 is about two list rows of Tahoma 8.
  74.  
  75. 'this is how many twips to the left or right of a column divider that will be recogized as having clicked on it
  76. Private Const ListResizeMouseTolerance = 100 '200
  77.  
  78. 'these are used to keep track of when it is dragging
  79. Private IsColumnResizing As Boolean
  80. Private ResizingColumn As Integer
  81.  
  82. Private Const EnableEvents As String = "[Event Procedure]"
  83.  
  84. Private WithEvents mListbox As ListBox
  85. Private WithEvents mForm    As Access.Form
  86.  
  87. Private mbolColumnHeadingSortEnabled As Boolean
  88. Private mbolColumnResizingEnabled As Boolean
  89.  
  90. Public ColumnLabels As New Collection ' A collection of label control names to reposition.
  91.  
  92. Private Sub ListColumnResizeMouseDown(listCtrl As Control, MouseButton As Integer, MouseX As Single, MouseY As Single)
  93. 'This sub is for the initial click of the click-and-drag.
  94.  
  95.     Dim i As Integer
  96.    
  97.     If MouseButton <> 1 Then Exit Sub 'If it is not a simple left click, we ignore it.
  98.    
  99.     If MouseY > 400 Then Exit Sub   ' Only let the columns resize if clicking dividers near the top of the list.
  100.                                    ' BS 7/5/2016:  I was getting annoyed by this routine intercepting regular row clicks
  101.                                    ' so this is a way to ignore the divider clicks lower in the list.
  102.                                    ' MouseY of 400 is about two list rows of Tahoma 8.
  103.                                    
  104.     ' First we get the existing column widths and calculate where the divider lines should be.
  105.    Dim colWidths, ColPositions
  106.     colWidths = Split(listCtrl.ColumnWidths, ";")
  107.     ColPositions = Split(listCtrl.ColumnWidths, ";")
  108.     For i = 1 To UBound(colWidths)
  109.         ColPositions(i) = CInt(ColPositions(i - 1)) + CInt(colWidths(i))
  110.     Next i
  111.    
  112.     ' Then we see if the mouse is within the tolerance of a given divider line.
  113.    For i = 0 To UBound(ColPositions)
  114.         If (MouseX >= ColPositions(i) - ListResizeMouseTolerance) And (MouseX <= ColPositions(i) + ListResizeMouseTolerance) Then
  115.        
  116.             Debug.Print MouseX, MouseY
  117.        
  118.             Screen.MousePointer = 9 'change mouse pointer to "horizontal resize'
  119.            IsColumnResizing = True 'trigger our private dragging variable
  120.            ResizingColumn = i 'indicate which column we are changing
  121.        End If
  122.     Next i
  123.  
  124. End Sub
  125.  
  126. Private Sub ListColumnResizeMouseMove(listCtrl As Control, MouseButton As Integer, MouseX As Single)
  127. ' This sub takes care of mouse dragging.
  128. ' Unfrortunately after Access 2007 this event can no longer be called from the MouseMove event without
  129. ' crashing Access.  It is now called from the MouseUp event which limits the screen refresh.
  130.    
  131.     Dim i As Integer
  132.    
  133.     'if they've somehow released the mouse button, and we think we are resizing, then we stop resizing
  134.    On Error GoTo ErrorHandler
  135.  
  136.     If IsColumnResizing And MouseButton <> 1 Then ListColumnResizeMouseUp
  137.    
  138.     'again we calculate the column widths and positions.
  139.    Dim colWidths, oldWidths, ColPositions, newWidths
  140.     colWidths = Split(listCtrl.ColumnWidths, ";")
  141.     oldWidths = Join(colWidths, ";") 'this is just to compare with later, just in case Join gives us slightly different results than just taking the ColumnWidths property
  142.    ColPositions = Split(listCtrl.ColumnWidths, ";")
  143.     For i = 1 To UBound(colWidths)
  144.         ColPositions(i) = CInt(ColPositions(i - 1)) + CInt(colWidths(i))
  145.     Next i
  146.      
  147.     'The main resizing calculation:
  148.    If IsColumnResizing = True Then 'Are they resizing?
  149.        If MouseX < ColPositions(ResizingColumn) Then 'Are they moving it to the left?
  150.            If ResizingColumn > 0 Then 'If it is not the furthest left column we are resizing...
  151.                If MouseX > ColPositions(ResizingColumn - 1) Then 'Make sure it isn't going over the one to the left.
  152.                    'Here we just calculate the size of the changed column by taking the difference between the divider
  153.                    'and the mouse position and subtracting it from the original column size. Simple, no?
  154.                    colWidths(ResizingColumn) = CInt(colWidths(ResizingColumn) - (ColPositions(ResizingColumn) - MouseX))
  155.                 End If
  156.             Else 'If it IS the furthest left column we are resizing...
  157.                If MouseX > 0 Then 'Then just make sure the size is going to be greater than zero
  158.                    'Calculate the size again (same as before)
  159.                    colWidths(ResizingColumn) = CInt(colWidths(ResizingColumn) - (ColPositions(ResizingColumn) - MouseX))
  160.                 End If
  161.             End If
  162.         Else 'If they aren't moving to the left, then they're moving to the right (or not moving at all, but we can ignore that)
  163.            If ResizingColumn < UBound(ColPositions) Then 'If it not the furthest right column we are resizing...
  164.                If MouseX < ColPositions(ResizingColumn + 1) Then 'Make sure it isn't running over the next column.
  165.                    'Same calculation as before, except that the mouse position will be larger than the divider position,
  166.                    'and we are expanding the column rather than shrinking it.
  167.                    colWidths(ResizingColumn) = CInt(colWidths(ResizingColumn) + (MouseX - ColPositions(ResizingColumn)))
  168.                 End If
  169.             Else 'If it IS the furthest right column we are resizing...
  170.                If MouseX < listCtrl.Width Then 'Make sure we aren't going outside the control...
  171.                    'Same expanding calculation as before
  172.                    colWidths(ResizingColumn) = CInt(colWidths(ResizingColumn) + (MouseX - ColPositions(ResizingColumn)))
  173.                 End If
  174.             End If
  175.         End If
  176.         newWidths = Join(colWidths, ";") 'Now we put the widths back together again, and...
  177.        If newWidths <> oldWidths Then listCtrl.ColumnWidths = newWidths 'if it is a different result, then resize the columns.
  178.    End If
  179.    
  180.     Exit Sub
  181.  
  182. ErrorHandler:
  183.  
  184.     MsgBox "Error #" & err.Number & " - " & err.Description & vbCrLf & "in procedure ListColumnResizeMouseMove of clsListboxColumnResize"
  185.  
  186. End Sub
  187.  
  188. Private Sub ListColumnResizeMouseUp()
  189. 'This sub takes care of releasing the mouse button.
  190.  
  191.     If Screen.MousePointer = 9 Then Screen.MousePointer = 0 'If the mouse is a horizontal-resizer, make it a regular pointer.
  192.    If IsColumnResizing = True Then IsColumnResizing = False 'Indicate that we are no longer dragging.
  193.  
  194.     If ColumnLabels.count > 1 Then
  195.         ' Reposition the column headings that were pass to SetupColumnLabels()
  196.        '(Note that the first label never moves as it is the farthest left.)
  197.        Dim i As Integer
  198.        
  199.         For i = 2 To ColumnLabels.count
  200.             mListbox.Parent.Controls(ColumnLabels(i)).Left = DividerLeft(mListbox, i - 1)
  201.         Next
  202.     End If
  203.  
  204. End Sub
  205.  
  206. Private Function DividerLeft(listCtrl As Control, DividerNumber)
  207. 'This function just calculates where the left point of a column is relevant to the
  208. 'form as a whole. This is useful for moving labels along with columns.
  209.  
  210.     Dim colWidths, ColPositions
  211.     Dim i As Integer
  212.  
  213. '    If IsColumnResizing Then '<- use this if calling from the MouseMove event to reduce overhead.
  214.  
  215.         colWidths = Split(listCtrl.ColumnWidths, ";")
  216.         ColPositions = Split(listCtrl.ColumnWidths, ";")
  217.  
  218.         For i = 1 To UBound(colWidths)
  219.             ColPositions(i) = CInt(ColPositions(i - 1)) + CInt(colWidths(i))
  220.         Next i
  221.  
  222.         If DividerNumber > listCtrl.ColumnCount Then
  223.             ' The DividerNumber is higher than the number of defined columns.
  224.            ' Catch this instead of generating an error.  BS 4/3/2019
  225.            DividerLeft = listCtrl.Left + listCtrl.Width - 1000
  226.         Else
  227.             DividerLeft = listCtrl.Left + ColPositions(DividerNumber - 1)
  228.         End If
  229.  
  230.         ' Don't let the label move too far.
  231.        If DividerLeft > (listCtrl.Left + listCtrl.Width) Then
  232.             DividerLeft = listCtrl.Left + listCtrl.Width
  233.         End If
  234. '    End If
  235.  
  236. End Function
  237.  
  238.  
  239. '--------------------------------------------------------------------------------------------------
  240. Private Sub Class_Initialize()
  241.    
  242.     mbolColumnResizingEnabled = True
  243.     mbolColumnHeadingSortEnabled = False
  244.  
  245. End Sub
  246.  
  247. Private Sub Class_Terminate()
  248.  
  249.     Set mListbox = Nothing
  250.     Set mForm = Nothing
  251.    
  252. End Sub
  253.  
  254.  
  255. Public Sub SetupListbox(ctlListbox As Access.ListBox)
  256.  
  257.     ' Save a local reference
  258.    Set mListbox = ctlListbox
  259.    
  260. ' This IS necessary.  If you don't have this and change from form view to design view Access will crash.  BS 11/8/2016
  261. '''' This may not be necessary.  If this class doesn't open any objects we may not need to cleanup.
  262. '    Set mForm = Forms("frm_Hex").Form
  263. '    Set mForm = ctlListbox.Parent.Parent.Parent
  264.    Set mForm = fGetParentForm(ctlListbox)      ' Use this function to get the parent form in case the control is on a tab control.
  265.    mForm.OnClose = "[Event Procedure]"         ' For proper termination.
  266.  
  267.     mListbox.OnMouseDown = EnableEvents
  268.     mListbox.OnMouseMove = EnableEvents
  269.     mListbox.OnMouseUp = EnableEvents
  270.    
  271.     If mListbox.ColumnHeads = True Then
  272.         ' If this list has column headings enabled, enable the column heading sort feature as the default.
  273.        mbolColumnHeadingSortEnabled = True
  274.     End If
  275.  
  276.     ' If we access the ListIndex property
  277.    ' then the entire Index for the RowSource
  278.    ' behind each ListBox is loaded.
  279.    ' Allows for smoother initial scrolling.
  280.    Dim lngTemp As Long
  281.     lngTemp = mListbox.ListCount
  282.    
  283. End Sub
  284.  
  285. Public Sub SetupColumnLabels(ParamArray arryLabelControls())
  286. ' Pass in the column label controls so they are repositioned above each list column as it is resized.
  287. ' Example call:  ListboxColumnResize.SetupColumnLabels lblCode, lblItem, lblName
  288. ' YMMV.  This doesn't account for hidden columns or columns with no label control, or overlapping.
  289. ' If you have a hidden column with no heading, like when column 0 is hidden, just pass the next visible
  290. ' column heading label twice in a row.
  291.  
  292.     Dim i As Integer
  293.    
  294.     ' Store the passed control names into a collection.
  295.    For i = 0 To UBound(arryLabelControls)
  296.         ColumnLabels.Add arryLabelControls(i).Name
  297.     Next
  298.    
  299. End Sub
  300.  
  301.  
  302.  
  303. Property Let EnableColumnHeadingSort(bolEnable As Boolean)
  304.  
  305.     On Error GoTo ErrorHandler
  306.  
  307.     If mListbox Is Nothing Then
  308.         MsgBox "The program tried to set a property without calling SetupListbox first.", vbExclamation, "Warning from clsListboxColumnResize"
  309.     ElseIf mListbox.ColumnHeads = False And bolEnable = True Then
  310.         ' Ignore this
  311.        MsgBox "The program tried to enable Column Heading Sort in listbox '" & mListbox.Name & "' but column headings are not visible.", vbExclamation, "Warning from clsListboxColumnResize"
  312.     Else
  313.         mbolColumnHeadingSortEnabled = bolEnable
  314.     End If
  315.  
  316.     Exit Property
  317.  
  318. ErrorHandler:
  319.  
  320.     MsgBox "Error #" & err.Number & " - " & err.Description & vbCrLf & "in procedure EnableColumnHeadingSort of clsListboxColumnResize"
  321.    
  322. End Property
  323.  
  324. Property Let EnableColumnResizing(bolEnable As Boolean)
  325. ' This property is assumed to be true when using this class but give the
  326. ' user the ability to disable it if they need to for some other operation.
  327.    mbolColumnResizingEnabled = bolEnable
  328.  
  329. End Property
  330.  
  331. Property Get EnableColumnResizing() As Boolean
  332.  
  333.     EnableColumnResizing = mbolColumnResizingEnabled
  334.  
  335. End Property
  336.  
  337. Private Sub mListbox_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  338.  
  339.     ListColumnResizeMouseDown mListbox, Button, x, y
  340.    
  341.     If IsColumnResizing Then
  342.         ' Don't sort when in column resize mode.
  343.    Else
  344.         ' Sort list when column heading is clicked.
  345.        sColumnHeadingClickSort mListbox, Button, Shift, x, y
  346.     End If
  347. End Sub
  348.  
  349. Private Sub mListbox_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  350.     If IsColumnResizing Then
  351.         ListColumnResizeMouseMove mListbox, Button, x
  352.         ListColumnResizeMouseUp
  353.     End If
  354. End Sub
  355.  
  356.  
  357.  
  358. '-------------------------------------
  359.  
  360.  
  361. Private Sub sColumnHeadingClickSort(objList As ListBox, MouseButton As Integer, Shift As Integer, x As Single, y As Single)
  362. ' Attempt to sort when column heading is clicked.  I couldn't find anyone on the Internet
  363. ' who has done this before.  Call this from the MouseDown event.
  364. '
  365. ' This sorts by updating OrderBy in the rowsource of the listbox, causing a requery.
  366. ' I did consider sorting the DAO recordset that is already in the listbox but Microsoft
  367. ' documentation suggested that it may not be any faster, and another article suggested
  368. ' that a requery is still necessary with a DAO sort.
  369. '
  370. ' Ben Sacherich - 7/13/2014
  371. ' BS 8/10/2014: Updated the secondary sort to be copied properly.
  372. ' BS 3/8/2016:  Changed this to be its own sub.
  373. ' BS 3/28/2016: Changed to be part of this class.
  374. ' BS 8/4/2016:  Added ability to sort if column headings are not visible but user shift-clicks in the top row.
  375.  
  376.     Dim strNewOrder         As String
  377.     Dim strColumn           As String
  378.     Static strDirection     As String  ' Direction of sort, Ascending or Descending
  379.    Static strPrevColumn    As String  ' Preserve the previous click for sort stacking.
  380.    Static strSecondarySort As String  ' Preserve the secondary sort.
  381.  
  382.     On Error GoTo ErrorHandler
  383.  
  384.     If MouseButton <> 1 Then Exit Sub 'If it is not a simple left click, we ignore it.
  385.  
  386.     If (objList.ColumnHeads = False) And (Shift = 1) And (y < 200) Then
  387.         ' When column heads are not visible let the user shift-click in
  388.        ' the first row to sort by that column.
  389.        strColumn = fGetColumnHeadingClicked(objList, x, y, True)
  390.     Else
  391.         strColumn = fGetColumnHeadingClicked(objList, x, y)
  392.     End If
  393.  
  394.     If strColumn <> "" Then ' It appears that a column heading has been clicked.
  395.        
  396.         If strPrevColumn = "" Then
  397.             ' This is the first time a column was selected.
  398.            strSecondarySort = strColumn
  399.  
  400.         ElseIf strColumn = strPrevColumn Then
  401.             ' Same column heading selected twice.  Change the sort direction.
  402.            If strDirection = " Desc" Then
  403.                 ' Change back to Ascending (or just leave it blank)
  404.                strDirection = ""
  405.             Else
  406.                 strDirection = " Desc"
  407.             End If
  408.        
  409.         Else
  410.             ' Another column was selected.  The previous column will be the secondary sort and the new column will be Ascending.
  411.            strSecondarySort = strPrevColumn & strDirection
  412.            
  413.             ' Always set the direction to Ascending when a new column is clicked
  414.            strDirection = ""
  415.        
  416.         End If
  417.            
  418.         strNewOrder = "ORDER BY " & strColumn & strDirection & ", " & strSecondarySort
  419.        
  420. '        txtOrderBy = strNewOrder ' Update the barely visible text box on the screen.
  421.        objList.StatusBarText = strNewOrder ' Update the status bar text for the listbox to show the current sort.
  422.  
  423.        
  424. '        Debug.Print strNewOrder
  425.        objList.RowSource = ReplaceOrderByClause(objList.RowSource, strNewOrder)
  426.         strPrevColumn = strColumn
  427.     End If
  428.  
  429.     Exit Sub
  430.  
  431. ErrorHandler:
  432.  
  433.     MsgBox "Error #" & err.Number & " - " & err.Description & vbCrLf & "in procedure sColumnHeadingClickSort of Form_frm_dialog_Quick_Search"
  434.  
  435. End Sub
  436.  
  437.    
  438. Private Function fGetColumnHeadingClicked(oList As Object, x As Single, y As Single, Optional ColumnHeadOverride As Boolean = False) As String
  439. ' Return the column heading number of the column clicked.
  440. ' This could return the column heading name but the number is more useful for an Order By statement.
  441. ' Ben Sacherich 7/13/2014
  442. ' BS 8/4/2016:  Added optional ColumnHeadOverride parameter to support lists without column headings.
  443.  
  444.     Dim lColumn As Long
  445.     Dim arryColumnWidths() As String
  446.     Dim lngTwipsFromLeft As Long
  447.    
  448.     On Error GoTo ErrorHandler
  449.  
  450.     If ((oList.ColumnHeads = True) And (y < 200)) Or (ColumnHeadOverride = True) Then
  451.         ' User clicked in the area of the column heading.
  452.        ' You may have to adjust the Y value for your font size.
  453.        
  454.         ' Find out which column they clicked on.
  455.        ' The neat thing about this is the .ColumnWidths is returned in Twips.
  456.        arryColumnWidths = Split(oList.ColumnWidths, ";")
  457.        
  458.         For lColumn = LBound(arryColumnWidths) To UBound(arryColumnWidths)
  459.             lngTwipsFromLeft = lngTwipsFromLeft + arryColumnWidths(lColumn)
  460.             If x < lngTwipsFromLeft Then
  461. '                Debug.Print "[" & oList.Column(lColumn, 0) & "]", lColumn
  462. '                fGetColumnHeadingClicked = "[" & oList.Column(lColumn, 0) & "]"
  463.                fGetColumnHeadingClicked = lColumn + 1
  464.                 Exit For
  465.             End If
  466.         Next
  467.        
  468.     End If
  469.  
  470.     Exit Function
  471.  
  472. ErrorHandler:
  473.     MsgBox "Error #" & err.Number & " - " & err.Description & vbCrLf & "in Function fGetColumnHeadingClicked()"
  474.    
  475. End Function
  476.  
  477.  
  478. '=========================================================================================================
  479. ' BS 3/28/2016:  The code below was copied into this class so the class is independent and can be shared.
  480. '=========================================================================================================
  481.  
  482.  
  483. ' You may use the code and techniques in this database as long as you do not publish
  484. ' as your own work; this copyright notice must remain complete and intact.
  485. '
  486. ' www.JStreetTech.com
  487. ' Copyright © 2000 J Street Technology, Inc.  All Rights Reserved.
  488.  
  489.  
  490. Private Sub ParseSQL(strSQL As Variant, strSELECT As Variant, strWHERE As Variant, strORDERBY As Variant, strGROUPBY As Variant, strHAVING As Variant)
  491. On Error GoTo Err_ParseSQL
  492. '12/4/95  CM            Created
  493. '2/15/96  Armen Stein   Converted to Sub from Function
  494. '10/27/97 Armen Stein   Added GroupBy capability
  495. '5/13/2014 Ben Sacherich    Added support for strSQL input being a Query object.
  496. '5/22/2014 Ben Sacherich    If this routine is called from within a loop and parameters 2-6 get old values
  497. '                           passed in, this was returning those old values. It will now clear those values
  498. '                           when starting.
  499. 'Limitations:
  500. '   This does not properly handle UNION queries.
  501. '
  502. 'This subroutine accepts a valid SQL string and passes back separated SELECT, WHERE, ORDER BY and GROUP BY clauses.
  503. '
  504. 'INPUT:
  505. '    strSQL      valid SQL string or Query Object name to parse
  506. 'OUTPUT:
  507. '    strSELECT   SELECT portion of SQL (includes JOIN info)
  508. '    strWHERE    WHERE portion of SQL
  509. '    strORDERBY  ORDER BY portion of SQL
  510. '    strGROUPBY  GROUP BY portion of SQL
  511. '    strHAVING   HAVING portion of SQL
  512. '
  513. 'Note:  While the subroutine will accept the ';' character in strSQL,
  514. '       there is no ';' character passed back at any time.
  515. '       BS 5/22/2014: Note that the ';' is now ignored because it did not handle
  516. '       PARAMETERS or intentionally embedded semicolons.
  517. '
  518.  
  519.     Dim intStartSELECT As Integer
  520.     Dim intStartWHERE As Integer
  521.     Dim intStartORDERBY As Integer
  522.     Dim intStartGROUPBY As Integer
  523.     Dim intStartHAVING As Integer
  524.    
  525.     Dim intLenSELECT As Integer
  526.     Dim intLenWHERE As Integer
  527.     Dim intLenORDERBY As Integer
  528.     Dim intLenGROUPBY As Integer
  529.     Dim intLenHAVING As Integer
  530.        
  531.     Dim intLenSQL As Integer
  532.    
  533.     ' Clear the values so if they had data when they were passed in,
  534.    ' it would not be returned.  BS 5/22/2014
  535.    strSELECT = ""
  536.     strWHERE = ""
  537.     strORDERBY = ""
  538.     strGROUPBY = ""
  539.     strHAVING = ""
  540.    
  541.     intStartSELECT = InStr(strSQL, "SELECT ")
  542.    
  543.     If intStartSELECT = 0 Then
  544.         ' This may be a query object instead of a SQL statement.  BS 5/13/2014
  545.        If CurrentDb.QueryDefs(strSQL).Name <> "" Then
  546.             ' This is a QueryDef.  Retrieve the SQL from it.
  547.            strSQL = CurrentDb.QueryDefs(strSQL).SQL
  548.             intStartSELECT = InStr(strSQL, "SELECT ")
  549.         End If
  550.     End If
  551.        
  552.     intStartWHERE = InStr(strSQL, "WHERE ")
  553.     intStartORDERBY = InStr(strSQL, "ORDER BY ")
  554.     intStartGROUPBY = InStr(strSQL, "GROUP BY ")
  555.     intStartHAVING = InStr(strSQL, "HAVING ")
  556.    
  557.     'if there's no GROUP BY, there can't be a HAVING
  558.    If intStartGROUPBY = 0 Then
  559.         intStartHAVING = 0
  560.     End If
  561.    
  562.    
  563.     ' BS 5/22/2014:  If the passed query has parameters, the PARAMETER statement will end with ';'.
  564.    ' The following condition was removing everything after the ';' so I have commented out this feature.
  565.    ' The following code would only respond to the first ';' found, even if it was embedded as part of
  566.    ' static text in the SQL statement.
  567.    If InStr(strSQL, ";") Then       'if it exists, trim off the ';'
  568.        strSQL = Left(strSQL, InStr(strSQL, ";") - 1)
  569.     End If
  570.  
  571.     intLenSQL = Len(strSQL)
  572.  
  573.     ' find length of Select portion
  574.    If intStartSELECT > 0 Then
  575.         ' start with longest it could be
  576.        intLenSELECT = intLenSQL - intStartSELECT + 1
  577.         If intStartWHERE > 0 And intStartWHERE > intStartSELECT And intStartWHERE < intStartSELECT + intLenSELECT Then
  578.             'we found a new portion closer to this one
  579.            intLenSELECT = intStartWHERE - intStartSELECT
  580.         End If
  581.         If intStartORDERBY > 0 And intStartORDERBY > intStartSELECT And intStartORDERBY < intStartSELECT + intLenSELECT Then
  582.             'we found a new portion closer to this one
  583.            intLenSELECT = intStartORDERBY - intStartSELECT
  584.         End If
  585.         If intStartGROUPBY > 0 And intStartGROUPBY > intStartSELECT And intStartGROUPBY < intStartSELECT + intLenSELECT Then
  586.             'we found a new portion closer to this one
  587.            intLenSELECT = intStartGROUPBY - intStartSELECT
  588.         End If
  589.         If intStartHAVING > 0 And intStartHAVING > intStartSELECT And intStartHAVING < intStartSELECT + intLenSELECT Then
  590.             'we found a new portion closer to this one
  591.            intLenSELECT = intStartHAVING - intStartSELECT
  592.         End If
  593.     End If
  594.  
  595.     ' find length of GROUPBY portion
  596.    If intStartGROUPBY > 0 Then
  597.         ' start with longest it could be
  598.        intLenGROUPBY = intLenSQL - intStartGROUPBY + 1
  599.         If intStartWHERE > 0 And intStartWHERE > intStartGROUPBY And intStartWHERE < intStartGROUPBY + intLenGROUPBY Then
  600.             'we found a new portion closer to this one
  601.            intLenGROUPBY = intStartWHERE - intStartGROUPBY
  602.         End If
  603.         If intStartORDERBY > 0 And intStartORDERBY > intStartGROUPBY And intStartORDERBY < intStartGROUPBY + intLenGROUPBY Then
  604.             'we found a new portion closer to this one
  605.            intLenGROUPBY = intStartORDERBY - intStartGROUPBY
  606.         End If
  607.         If intStartHAVING > 0 And intStartHAVING > intStartGROUPBY And intStartHAVING < intStartGROUPBY + intLenGROUPBY Then
  608.             'we found a new portion closer to this one
  609.            intLenGROUPBY = intStartHAVING - intStartGROUPBY
  610.         End If
  611.     End If
  612.    
  613.     ' find length of HAVING portion
  614.    If intStartHAVING > 0 Then
  615.         ' start with longest it could be
  616.        intLenHAVING = intLenSQL - intStartHAVING + 1
  617.         If intStartWHERE > 0 And intStartWHERE > intStartHAVING And intStartWHERE < intStartHAVING + intLenHAVING Then
  618.             'we found a new portion closer to this one
  619.            intLenHAVING = intStartWHERE - intStartHAVING
  620.         End If
  621.         If intStartORDERBY > 0 And intStartORDERBY > intStartHAVING And intStartORDERBY < intStartHAVING + intLenHAVING Then
  622.             'we found a new portion closer to this one
  623.            intLenHAVING = intStartORDERBY - intStartHAVING
  624.         End If
  625.         If intStartGROUPBY > 0 And intStartGROUPBY > intStartHAVING And intStartGROUPBY < intStartHAVING + intLenHAVING Then
  626.             'we found a new portion closer to this one
  627.            intLenHAVING = intStartGROUPBY - intStartHAVING
  628.         End If
  629.     End If
  630.    
  631.    
  632.     ' find length of ORDERBY portion
  633.    If intStartORDERBY > 0 Then
  634.         ' start with longest it could be
  635.        intLenORDERBY = intLenSQL - intStartORDERBY + 1
  636.         If intStartWHERE > 0 And intStartWHERE > intStartORDERBY And intStartWHERE < intStartORDERBY + intLenORDERBY Then
  637.             'we found a new portion closer to this one
  638.            intLenORDERBY = intStartWHERE - intStartORDERBY
  639.         End If
  640.         If intStartGROUPBY > 0 And intStartGROUPBY > intStartORDERBY And intStartGROUPBY < intStartORDERBY + intLenORDERBY Then
  641.             'we found a new portion closer to this one
  642.            intLenORDERBY = intStartGROUPBY - intStartORDERBY
  643.         End If
  644.         If intStartHAVING > 0 And intStartHAVING > intStartORDERBY And intStartHAVING < intStartORDERBY + intLenORDERBY Then
  645.             'we found a new portion closer to this one
  646.            intLenORDERBY = intStartHAVING - intStartORDERBY
  647.         End If
  648.     End If
  649.    
  650.     ' find length of WHERE portion
  651.    If intStartWHERE > 0 Then
  652.         ' start with longest it could be
  653.        intLenWHERE = intLenSQL - intStartWHERE + 1
  654.         If intStartGROUPBY > 0 And intStartGROUPBY > intStartWHERE And intStartGROUPBY < intStartWHERE + intLenWHERE Then
  655.             'we found a new portion closer to this one
  656.            intLenWHERE = intStartGROUPBY - intStartWHERE
  657.         End If
  658.         If intStartORDERBY > 0 And intStartORDERBY > intStartWHERE And intStartORDERBY < intStartWHERE + intLenWHERE Then
  659.             'we found a new portion closer to this one
  660.            intLenWHERE = intStartORDERBY - intStartWHERE
  661.         End If
  662.         If intStartHAVING > 0 And intStartHAVING > intStartWHERE And intStartHAVING < intStartWHERE + intLenWHERE Then
  663.             'we found a new portion closer to this one
  664.            intLenWHERE = intStartHAVING - intStartWHERE
  665.         End If
  666.     End If
  667.  
  668.     ' set each output portion
  669.    If intStartSELECT > 0 Then
  670.         strSELECT = Mid$(strSQL, intStartSELECT, intLenSELECT)
  671.     End If
  672.     If intStartGROUPBY > 0 Then
  673.         strGROUPBY = Mid$(strSQL, intStartGROUPBY, intLenGROUPBY)
  674.     End If
  675.     If intStartHAVING > 0 Then
  676.         strHAVING = Mid$(strSQL, intStartHAVING, intLenHAVING)
  677.     End If
  678.     If intStartORDERBY > 0 Then
  679.         strORDERBY = Mid$(strSQL, intStartORDERBY, intLenORDERBY)
  680.     End If
  681.     If intStartWHERE > 0 Then
  682.         strWHERE = Mid$(strSQL, intStartWHERE, intLenWHERE)
  683.     End If
  684.  
  685. Exit_ParseSQL:
  686.     Exit Sub
  687.  
  688. Err_ParseSQL:
  689.     If err.Number = 3265 Then ' NAME_NOT_IN_COLLECTION (QueryDef not found)
  690.        Resume Next
  691.     Else
  692.         MsgBox Error.Number & ": " & Error.Description
  693.         Resume Exit_ParseSQL
  694.     End If
  695. End Sub
  696.  
  697.  
  698. Private Function ReplaceOrderByClause(strSQL As Variant, strNewOrder As Variant) As String
  699. ' 7/14/2014 - Ben Sacherich
  700. '
  701. 'This subroutine accepts a valid SQL string and ORDER BY clause, and
  702. 'returns the same SQL statement with the original Order By clause (if any)
  703. 'replaced by the passed in Order By clause.
  704. '
  705. 'INPUT:
  706. '    strSQL      valid SQL string to change
  707. 'OUTPUT:
  708. '    strNewORDER New Order By clause to insert into SQL statement
  709. '
  710.  
  711.     Dim strSELECT As String, strWHERE As String, strORDERBY As String, strGROUPBY As String, strHAVING As String
  712.    
  713.     On Error GoTo ErrorHandler
  714.  
  715.     Call ParseSQL(strSQL, strSELECT, strWHERE, strORDERBY, strGROUPBY, strHAVING)
  716.    
  717. '    If strORDERBY = "" Then
  718. '        strNewORDER = vbCrLf & " ORDER BY " & strNewORDER
  719. '    End If
  720.    
  721.     ReplaceOrderByClause = strSELECT & " " & strWHERE & " " & strGROUPBY & " " & strHAVING & " " & strNewOrder
  722.  
  723. Exit_Function:
  724.     Exit Function
  725. ErrorHandler:
  726.     MsgBox err.Number & ", " & err.Description
  727.     Resume Exit_Function
  728. End Function
  729.  
  730. Private Sub mForm_Close()
  731. ' By tapping into the form events FROM the class, I can tap into the close event
  732. ' so I don't need to have the cleanup code in the form. "cleaner" that way I think. -TSC
  733.  
  734.     Call Class_Terminate
  735.  
  736. End Sub
  737.  
  738. Private Function fGetParentForm(ctl As Control) As Object
  739. ' Return the Parent Form object of the passed control.  Normally this
  740. ' is ctl.Parent, but could be different if the control is on a tab control.
  741. ' BS 7/5/2016
  742.  
  743.     Dim obj As Object
  744.  
  745.     Set obj = ctl
  746.     While Not (obj Is Nothing)
  747.         If TypeOf obj.Parent Is Form Then
  748.             Set fGetParentForm = obj.Parent
  749.             Set obj = Nothing ' To clear the memory used by this.
  750.            Exit Function
  751.         Else
  752.             Set obj = obj.Parent
  753.         End If
  754.     Wend
  755.  
  756. End Function
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top