Roger's Access Library Homepage
Forum Home Forum Home > Other Download Libraries > MS Access MVP Libraries > Long, Crystal
  New Posts New Posts RSS Feed - Document Calculated Fields in Queries
  FAQ FAQ  Forum Search   Events   Register Register  Login Login

Please consider donating $1 per sample downloaded, (find out why here)

Document Calculated Fields in Queries

 Post Reply Post Reply
Message Reverse Sort Order
Crystal Long View Drop Down
Microsoft MVP
Microsoft MVP

Joined: 21 May 2012
Location: Colorado
Status: Offline
Points: 35
Post Options Post Options   Thanks (0) Thanks(0)   Quote Crystal Long Quote  Post ReplyReply Direct Link To This Post Topic: Document Calculated Fields in Queries
    Posted: 19 May 2014 at 11:51pm
Document Calculated Fields in Queries

Do you have calculated fields in queries of your database? To see all your equations and fields with aliases, make a query with this SQL statement:

SELECT mQ.Name1 AS FieldName
     , mo.Name AS QryName
     , mQ.Expression  
 FROM MSysObjects AS mo
     INNER JOIN MSysQueries AS mQ
         ON mo.Id = mQ.ObjectId  
 WHERE ( (mQ.Name1 Is Not Null)
     AND (left(mo.Name,1) Not IN ("~","{"))
     AND (mQ.Expression Is Not Null)
     AND (mQ.Attribute=6) )  
 ORDER BY mQ.Name1
     , mo.Name;

I put the results into Excel and formatted them -- and wrote code to do it again :)

This download is a zipped up BAS file you can import into an Access database.  There is one public sub called DocumentQueryCalculatedFields
When you run it, it will make a file in the CurrentProject.Path called CalculatedQueryFields.xl? (saves in whatever version you are using) with the formatted results.


example documentation:

DocumentCalculatedQueryFields Results in Excel

The first database I ran this on had nearly 500 equations in queries! This documentation was a huge help to figure out where fields were being calculated that did not show up in the Field List generated by my Analyzer*.  One report I looked at had a RecordSource based on 3 queries ... by the time I was done tracing the nested queries down to tables, I had opened about 20 more queries. 


It is also nice to see the long equations that would be better in a global function ~ and where they are used.  For example, if you are reporting a date range that may have both beginning and ending dates filled, neither, or one, this will require several IIF statements if you want to customize each set of conditions.  The formula gets long and hard to trace.  By putting logic into a public function that everything calls, it is easy to reference and change.

Here is an example of a function that returns a string representing a date range.

Public Function GetDatesTerm(pDate1 As Variant _
   , pDate2 As Variant _
   , Optional ByVal psDescription As String _
   ) As String
'140520 Crystal, strive4peace

   ' return a string describing a date range
   '  example: Loan Term: 5/20/2014 - 5/19/2044
   ' future: Format Dates
   On Error GoTo Proc_Err
   If Len(psDescription) > 0 Then
      psDescription = RTrim(psDescription) & " "
   End If

   Select Case True
   Case Not IsNull(pDate1) And Not IsNull(pDate2)
      GetDatesTerm = psDescription _
         & "Term: " & pDate1 & " - " & pDate2
   Case Not IsNull(pDate1) And IsNull(pDate2)
      GetDatesTerm = psDescription _
         & "Start Date: " & pDate1
   Case IsNull(pDate1) And Not IsNull(pDate2)
      GetDatesTerm = psDescription _
         & "End Date: " & pDate2
   Case Else
      GetDatesTerm = "No " & psDescription _
         & "Term specified"
   End Select

   On Error Resume Next
   Exit Function
'   MsgBox Err.Description, , _
        "ERROR " & Err.Number _
        & "   GetDatesTerm"

   Resume Proc_Exit
End Function

Can you imagine how long the equation was that did this? ... and it was in several queries ...

Naturally, the code is also longer because of the optional psDescription parameter, which gets added to the result if specified, error handling, and comments (nice!).

After running this, I also found equations that were different but getting the same result ... just written at different times so different logic was used.

A bonus on the download is that you can see how to write the results of an SQL statement to Excel and do some nice formatting.  Field names are stacked into an array, which is used to write the labels across the top.  CopyFromRecordset is used to write the data.  Data filters are added, whatever value is in the first column is bolded each time it changes (along with a top border stretching across the data), margins and Page Header are set, columns are best-fit, columns wider than 60 (you can change this of course) are wrapped and width is set to 60, and the top row and left column are frozen.

Late Binding is used, so no libraries need to be referenced.  Constant names for early binding are in the comments.

here is the code in the BAS download:

Public Sub DocumentQueryCalculatedFields()
'140519, 20, 21 strive4peace
'based on code originally written by NateO

   On Error GoTo Proc_Err

   'Dimension object variables
   Dim rs As Object _
         , xlApp As Object _
         , xlWb As Object

   'Dimension regular variables
   Dim sSQL As String _
         , nRow As Long _
         , nCol As Long _
         , nFields As Long _
         , nRecords As Long _
         , sFilename As String _
         , sPathFileWithoutExtension As String _
         , sPathFileThere As String _
         , sSheetname As String _
         , i As Integer _
         , booMsg As Boolean _
         , nTimerStart As Single

   'Dimension Array for Fieldnames
   Dim asFieldname() As String
   nTimerStart = Timer()
   sFilename = "QryCalcFields_" _
      & Replace(Replace(CurrentProject.Name, ".", "-"), " ", "_")
   sSheetname = CurrentProject.Name
   'truncate database name to first word
   i = InStr(sSheetname, " ")
   If i > 0 Then
      sSheetname = Trim(Left(sSheetname, i))
   End If
   sSheetname = Left(sSheetname & "_" & "QryCalcFields", 30)
   booMsg = False 'give message that workbook was created
'here is the SQL, easy to uncomment and paste into a query if you want it:
'   SELECT mQ.Name1 AS FieldName
'      , mo.Name AS QryName
'      , mQ.Expression
'    FROM MSysObjects AS mo
'      INNER JOIN MSysQueries AS mQ
'         ON mo.Id = mQ.ObjectId
'    WHERE ( (mQ.Name1 Is Not Null)
'      AND (left(mo.Name,1) Not IN ("~","{"))
'      AND (mQ.Expression Is Not Null)
'      AND (mQ.Attribute=6) )
'    ORDER BY mQ.Name1
'      , mo.Name;

   sSQL = "SELECT mQ.Name1 AS FieldName, mo.Name AS QryName, mQ.Expression" _
         & " FROM MSysObjects AS mo " _
         & " INNER JOIN MSysQueries AS mQ ON mo.Id = mQ.ObjectId" _
         & " WHERE ( (mQ.Name1 Is Not Null) " _
         & " AND (left(mo.Name,1) Not IN (""~"",""{"")) " _
         & " AND (mQ.Expression Is Not Null) " _
         & " AND (mQ.Attribute=6) )" _
         & " ORDER BY mQ.Name1, mo.Name;"

   'Open an ADODB.Recordset
   Set rs = CreateObject("ADODB.Recordset")
   With rs
      .CursorLocation = 3 'adUseClient
      'adOpenStatic = 3
      'adLockReadOnly = 1
      rs.Open sSQL _
            , CodeProject.Connection _
            , 3 _
            , 1

      'count records and fields
      nFields = .Fields.Count
      nRecords = .RecordCount
   End With

   If Not nRecords > 0 Then
      MsgBox "there is no data to write to Excel", , "Aborting"
      GoTo Proc_Exit
   End If

   'create a new instance of an Excel application
   Set xlApp = CreateObject("Excel.Application")

   With xlApp
      .Visible = True 'let user see what is happening
      .EnableEvents = False 'don't run any code
      'Add a new Workbook with one Worksheet
      Set xlWb = .Workbooks.Add(1)
   End With

   'Stack a String Array with the Field Names
   ReDim asFieldname(1 To nFields)
   With rs
      For nCol = 1 To nFields
         Let asFieldname(nCol) = .Fields(nCol - 1).Name
      Next nCol
   End With 'rs

   'Time to Pass some Data to Excel!
   'Worksheets Collection is 1-based
   With xlWb.Worksheets.Item(1)

      'Write Label names from Field Name array
      'stretched to the Right for number of Elements in the array (number of columns)
      Let .Range("a1").Resize(, nFields).Value = asFieldname

      'Copy our Current Recordset to A2
      .Range("a2").CopyFromRecordset rs

      'Rename Individual Worksheet
      .Name = sSheetname

      sPathFileWithoutExtension = CurrentProject.Path & "\" & sFilename    '---- extension will be added

      With .Cells.Font
         .Name = "Calibri"
         .Size = 10
      End With

      'label row
      With .Range(.Cells(1, 1), .Cells(1, nFields))
         .Font.Size = 8
         With .Interior
            .Color = RGB(225, 225, 225)
         End With
      End With

      'xlDiagonalDown 5
      'xlDiagonalUp 6
      'xlEdgeLeft 7
      'xlEdgeTop 8
      'xlEdgeBottom 9
      'xlEdgeRight 10
      'xlInsideVertical 11
      'xlInsideHorizontal 12

      'all data
      With .Range(.Cells(1, 1), .Cells(nRecords, nFields))
         For i = 7 To 12
            With .Borders(i)
               .LineStyle = 1 'xlContinuous
               .Color = RGB(150, 150, 150)
               .Weight = 2 'xlThin
            End With
         Next i
         .VerticalAlignment = -4108 'xlCenter
      End With

      'format when value changes in Column A
      For nRow = 2 To nRecords + 1
         ' if the value in the first column changed,
         ' bold the first cell and add a line above
         If .Cells(nRow, 1) <> .Cells(nRow - 1, 1) Then
            With .Range(.Cells(nRow, 1), .Cells(nRow, nFields))
               With .Borders(8)
                  .LineStyle = 1 'xlContinuous
                  .Color = RGB(100, 100, 100)
                  .Weight = 3 'xlThick=4
               End With
            End With
            .Cells(nRow, 1).Font.Bold = True
         End If
      Next nRow
      'best-fit columns
      .Range(.Columns(1), .Columns(nFields)).EntireColumn.AutoFit

      For nCol = 1 To nFields
         'if any column widths > 60, reduce it.  Wrap Text
         If .Columns(nCol).ColumnWidth > 60 Then
            .Columns(nCol).ColumnWidth = 60
            .Columns(nCol).WrapText = True
         End If
      Next nCol

      'set margins, orientation, header
      With .PageSetup
        .PrintTitleRows = "1:1"
        .PrintTitleColumns = "A:A"
        .RightHeader = "&""Times New Roman,Italic""&10&A - " & Now() & " - &P/&N"
        .LeftMargin = xlApp.InchesToPoints(0.5)
        .RightMargin = xlApp.InchesToPoints(0.5)
        .TopMargin = xlApp.InchesToPoints(0.5)
        .BottomMargin = xlApp.InchesToPoints(0.5)
        .HeaderMargin = xlApp.InchesToPoints(0.3)
        .FooterMargin = xlApp.InchesToPoints(0.3)
        .CenterHorizontally = True
        .Orientation = 2 'xlLandscape
      End With

   End With   'Worksheet
   'freeze panes and turn on the auto filter
   xlApp.ActiveWindow.FreezePanes = True

   'delete file if it already exists
   sPathFileThere = Dir(sPathFileWithoutExtension & ".xl*")
   If sPathFileThere <> "" Then
      sPathFileThere = CurrentProject.Path & "\" & sPathFileThere
      On Error Resume Next
      Kill sPathFileThere 'hopefully this won't get the wrong file!
      On Error GoTo Proc_Err
   End If

   'save and close workbook
   With xlWb
      .Close True, sPathFileWithoutExtension
   End With
   booMsg = True
   On Error Resume Next
   If Not rs Is Nothing Then
      Set rs = Nothing
   End If
   If Not booMsg Then
      xlWb.Close False
      Set xlWb = Nothing
   End If
   If TypeName(xlApp) <> "Nothing" Then
      Set xlApp = Nothing
   End If
   If booMsg Then
      MsgBox sPathFileWithoutExtension _
         & vbCrLf & vbCrLf & " has been created for current version of Excel" _
         & vbCrLf & vbCrLf & nRecords & " Records" _
         & vbCrLf & vbCrLf & "Time to execute: " _
         & Format(Timer - nTimerStart, "#,###.##") & " seconds" _
         , , "Done"
   End If

   Exit Sub

   MsgBox Err.Description _
         , , "ERROR " & Err.Number _
         & "   DocumentQueryCalculatedFields"

   Resume Proc_Exit
End Sub

Warm Regards,

Remote Training and Programming
connect to me, let's build it together

   (: have an awesome day :)

Warm Regards,
Microsoft MVP
Remote Training & Programming
Let's Connect and Build Together
~have an awesome day ~
Back to Top
Sponsored Links

Back to Top
 Post Reply Post Reply
  Share Topic   

Forum Jump Forum Permissions View Drop Down

Forum Software by Web Wiz Forums® version 12.03
Copyright ©2001-2019 Web Wiz Ltd.