Private Sub cmdAnalyze_Click()
Dim ctl As Control
For Each ctl In Me.reportSubForm.Controls
If ctl.Name <> "_Label" Then
If CBool("Me.[reportSubForm].Form.[" & ctl.Name & "].ColumnHidden") = False Then
Debug.Print ctl.Name
End If
End If
Next
End Sub
Private Sub cmdAnalyze_Click()
Dim ctl As Control
For Each ctl In Me.reportSubForm.Controls
If ctl.Name <> "_Label" Then
If Me.[reportSubForm].Form.[LastName].ColumnHidden = False Then
Debug.Print ctl.Name
End If
End If
Next
Dim ctl As Control, varProperty As Variant
' For Each ctl In Me.reportSubForm.Controls
For Each ctl In Me.Controls
If ctl.Name <> "_Label" Then
varProperty = ctl.Visible
' If CBool("Me.[reportSubForm].Form.[" & ctl.Name & "].ColumnHidden") = False Then
If varProperty = "True" Then
Debug.Print ctl.Name
End If
End If
Next
Dim strSQL As String
Dim strSQLSelect As String
Dim strSQLFrom As String
Dim strSQLGroup As String
Dim strSQLHaving As String
Dim strSQLOrder As String
Dim strFile As String
Dim strQry As String
Dim db As dao.Database
Dim Qdf As dao.QueryDef
Dim ctl As Control
Dim rs As dao.Recordset
Dim i, j, k, l As Integer
strSQL = GetQuerySQL(Me.[reportSubForm].Form.RecordSource) 'Get the current SQL String and parse it
i = InStr(1, strSQL, "FROM")
j = InStr(1, strSQL, "GROUP")
k = InStr(1, strSQL, "HAVING")
l = InStr(1, strSQL, "ORDER BY")
strSQLSelect = Mid(strSQL, 1, i - 1) 'SELECT part
For Each ctl In Me.reportSubForm.Controls
If CStr(Right(ctl.Name, 6)) <> "_Label" Then
If (ctl.ColumnHidden) <> False Then
If InStr(1, strSQLSelect, "[") > 0 Then
If Mid(strSQLSelect, InStr(1, strSQLSelect, ctl.Name) - 1, 1) = "[" Then
strSQLSelect = Replace(strSQLSelect, "FamilyTbl.[" & ctl.Name & "],", "")
Else
strSQLSelect = Replace(strSQLSelect, "FamilyTbl." & ctl.Name & ",", "")
End If
Else
strSQLSelect = Replace(strSQLSelect, "FamilyTbl." & ctl.Name & ",", "")
End If
End If
End If
Next
strSQLSelect = TrimMultiSpaces(strSQLSelect)
If i > 0 Then strSQLSelect = strSQLSelect & Mid(strSQL, i, (j - i) - 1) 'FROM
If j > 0 Then strSQLSelect = strSQLSelect & Mid(strSQL, j - 1, (k - j) - 1) 'GROUP
If k > 0 Then strSQLSelect = strSQLSelect & Mid(strSQL, k - 1, (l - k) - 1) 'HAVING
If l > 0 Then strSQLSelect = strSQLSelect & Mid(strSQL, l - 1, Len(strSQL)) 'ORDER BY
'start the excel process
strFile = SpecialFolderPath("desktop") & "\Export.xls"
'If the temp target file exists, delete it first
If FileExists(strFile) Then
KillProperly strFile
End If
strQry = "qryTempFile"
Set db = CurrentDb
On Error Resume Next
With db
.QueryDefs.Delete (strQry)
Set Qdf = .CreateQueryDef(strQry, strSQLSelect)
End With
Set rs = Qdf.OpenRecordset
Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")
With xlApp
.Visible = True
.Workbooks.Add
.Sheets("sheet1").Select
.ActiveSheet.Range("A2").CopyFromRecordset rs
For i = 1 To rs.Fields.Count
xlApp.ActiveSheet.Cells(1, i).value = rs.Fields(i - 1).Name
Next i
xlApp.Cells.EntireColumn.AutoFit
End With
Public Function GetQuerySQL(MyQueryName As String) As String
Dim QD As dao.QueryDef
Set QD = CurrentDb.QueryDefs(MyQueryName)
GetQuerySQL = QD.SQL
End Function
Public Function TrimMultiSpaces(strSample As String)
Do While InStr(1, strSample, " ")
strSample = Replace(strSample, " ", " ")
Loop
TrimMultiSpaces = Trim(strSample)
End Function
' Options For specical folders
' AllUsersDesktop
' AllUsersStartMenu
' AllUsersPrograms
' AllUsersStartup
' Desktop
' Favorites
' Fonts
' MyDocuments
' NetHood
' PrintHood
' Programs
' Recent
' SendTo
' StartMenu
' Startup
' Templates
Function SpecialFolderPath(strFolder As String) As String
Dim objWSHShell As Object
Dim strSpecialFolderPath
'On Error GoTo ErrorHandler
' Create a shell object
Set objWSHShell = CreateObject("WScript.Shell")
' Find out the path to the passed special folder,
' just change the "Desktop" for one of the other options
SpecialFolderPath = objWSHShell.SpecialFolders.Item(CVar(strFolder))
'SpecialFolderPath = objWSHShell.SpecialFolders(strFolder)
' Clean up
Set objWSHShell = Nothing
Exit Function
ErrorHandler:
MsgBox "Error finding " & strSpecialFolder, vbCritical + vbOKOnly, "Error"
End Function
Function FileExists(ByVal FileToTest As String) As Boolean
FileExists = FileToTest <> ""
End Function
Public Function KillProperly(Killfile As String)
If Len(Dir(Killfile)) > 0 Then
SetAttr Killfile, vbNormal
Kill Killfile
End If
End Function
Open in new window