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
.Range("B2").Select End With 'Worksheet 'freeze panes and turn on the auto filter xlApp.ActiveWindow.FreezePanes = True xlApp.Selection.AutoFilter
'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! DoEvents On Error GoTo Proc_Err End If
'save and close workbook With xlWb .Close True, sPathFileWithoutExtension End With booMsg = True Proc_Exit: On Error Resume Next If Not rs Is Nothing Then rs.Close Set rs = Nothing End If If Not booMsg Then xlWb.Close False Set xlWb = Nothing End If If TypeName(xlApp) <> "Nothing" Then xlApp.Quit 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
Proc_Err: MsgBox Err.Description _ , , "ERROR " & Err.Number _ & " DocumentQueryCalculatedFields"
Resume Proc_Exit Resume End Sub |