Option Compare Database
Option Explicit
'declare private constants that exist in Excel vba but not Access vba
w/o using a reference
Private Const xlContinuous = 1
Private Const xlToRight = -4161, xlDown = -4121
Private Const xlLocationAsNewSheet = 1
Private Const xlPie = 5
Private Const xlDataLabelsShowLabelAndPercent = 5
Private Const xlDiagonalDown = 5, xlDiagonalUp = 6
Private Const xlEdgeLeft = 7, xlEdgeTop = 8, xlEdgeBottom = 9,
xlEdgeRight = 10
Private Const xlInsideVertical = 11, xlInsideHorizontal = 12
Private Const xlAutomatic = -4105
Private Const xlThin = 2, xlThick = 4
Private Const xlNone = -4142
Private Const xlUnderlineStyleNone = -4142
Private Const xlPortrait = 1, xlPaperLetter = 1
Private Const xlDownThenOver = 1
Private Const xlPrintNoComments = -4142
Private Const xlByRows = 1, xlByColumns = 2
Private Const xlNext = 1, xlPrevious = 2
Private Const xlSolid = 1
Private Const xlNormal = -4143
Private ary() 'Array to hold the contents of the souce table or query
Sub Dump_to_Excel_Sheets()
'this dump_to_Excel_Sheets is a generic wrapper for Dump_To_Excel
Dim objExcel As Object, Workbook As Object, fName As Variant, qdf As
QueryDef
Set objExcel = CreateObject("Excel.Application")
With objExcel.Workbooks
.Application.Visible = True
Set Workbook = .Add
End With
'---============= Begin Customize this section =============---
objExcel.worksheets.Add
objExcel.worksheets.Add
objExcel.worksheets("Sheet4").Move After:=objExcel.worksheets
("Sheet3")
Call Dump_To_Excel(objExcel, "Sheet1", "zqry_GETDATE")
Call Dump_To_Excel(objExcel, "Sheet2", "zqry_HOST_ID")
Call Dump_To_Excel(objExcel, "Sheet4", "zqry_HOST_NAME", 5, 1, False)
Call Dump_To_Excel(objExcel, "Sheet5", "zqry_IS_MEMBER", 5, 1, False)
'---============= End Customize this section =============---
Do
fName = Workbook.Application.GetSaveAsFilename
Loop Until fName <> False ' get file name from end user
If Right(Trim(fName), 3) <> "xls" Then 'if end user didn't specify
ext add it
fName = fName & "xls"
End If
Workbook.SaveAs FileName:=fName _
, fileformat:=xlNormal, Password:="", WriteResPassword:="",
ReadOnlyRecommended:=False _
, CreateBackup:=False 'Save file
Set fName = Nothing 'clean up memory
Set Workbook = Nothing
Set objExcel = Nothing
End Sub
Function Dump_To_Excel(objExcel As Object, strSheetname As String,
str_Recordset_Name As String, Optional lng_Row_Start, Optional
lng_Column_Start, Optional FreezePanes As Boolean, Optional
Exclude_Headers As Boolean)
'2009-01-09 egerds wrote to work with passed instace of excel and
fill with passed recordset name
'purpose to read the recordset data type format, and fill passed
excel object
'dependant upon
' Private Function format_Range_from_RST (Format columns based on
data source type)
' Function Get_Excel_Column (resolve column names
from #)
' Function rst_fld_Count (get width/column count)
' Function rst_row_Count (get row count)
' Function Has_Params (indicate if data source
is query with parameters)
'required
' objExcel is the instance of excel to work with
' strSheetname is the desired worksheet to dump data to
' str_Recordset_Name is the source data
' Optional lng_Row_Start which row to start at
' Optional lng_Column_Start which column to start at
' Optional FreezePanes As Boolean if you want to freeze panes (if
not passed then freezepanes is automatic A2)
' Optional Exclude_Headers but bugged to be false if not passed, is
to exclude the field names or not
'Missing
' Resolving that query might exceed excel dimenstions
' Resolving that parameters in data source can not be resolved
' That desired Excel tab miss named
' Optional vars not fully passes if some are passed
Dim Workbooks As Object, xlSheet As Object 'Excel
objects
Dim lng_Field_Count As Long, lng_Record_Count As Long,
lng_Counter_Outer As Long, lng_Counter_Inner As Long 'counters
Dim rst As Recordset
lng_Field_Count = rst_fld_Count(str_Recordset_Name) - 1 'get the
column count
lng_Record_Count = rst_row_Count(str_Recordset_Name) + 1 'get the row
count
ReDim ary(lng_Record_Count, lng_Field_Count) 'size the
array accordingly
Set xlSheet = objExcel.worksheets(strSheetname)
With xlSheet
.Activate
If Has_Params(str_Recordset_Name) Then 'check if
data source has params
Dim qdf As QueryDef, prm As Parameter
Set qdf = CurrentDb.QueryDefs(str_Recordset_Name)
For Each prm In qdf.Parameters
prm.Value = Eval(prm.Name)
Next
Set rst = qdf.OpenRecordset(dbOpenDynaset)
Else
Set rst = CurrentDb.OpenRecordset(str_Recordset_Name)
End If
If Not Exclude_Headers Then
For lng_Counter_Outer = 0 To lng_Field_Count 'set the column
headings name
If IsMissing(lng_Row_Start) Then
.range(Get_Excel_Column(lng_Counter_Outer) & "1") = rst.Fields
(lng_Counter_Outer).Name
Else
.range(Get_Excel_Column(lng_Counter_Outer + lng_Column_Start) & 1
+ lng_Row_Start) = rst.Fields(lng_Counter_Outer).Name
End If
Call format_Range_from_RST(rst, objExcel, strSheetname,
lng_Counter_Outer)
Next
End If
With rst
lng_Counter_Outer = -1 'reset the outer counter
While Not .EOF 'fill array
lng_Counter_Outer = lng_Counter_Outer + 1
For lng_Counter_Inner = 0 To lng_Field_Count
ary(lng_Counter_Outer, lng_Counter_Inner) = rst
(lng_Counter_Inner)
Next
.MoveNext
Wend
.Close
End With 'rs
Set rst = Nothing
.Name = str_Recordset_Name 'set the worksheet name to the query name
If IsMissing(lng_Row_Start) Then
.range("A2:" & Get_Excel_Column(lng_Field_Count) & lng_Record_Count
+ 1 - Abs(Not Exclude_Headers)) = ary() 'dump array to excel
.range("A2").Select
Else
.range(Get_Excel_Column(lng_Column_Start) & lng_Row_Start + 2 - Abs
(Not Exclude_Headers) & ":" & _
Get_Excel_Column(lng_Field_Count + lng_Column_Start) &
lng_Record_Count + lng_Row_Start + 2 - Abs(Not Exclude_Headers)) = ary
()
.range(Get_Excel_Column(lng_Column_Start) & lng_Row_Start + 2 - Abs
(Not Exclude_Headers)).Select
End If
.Cells.EntireColumn.AutoFit
If Not IsMissing(FreezePanes) Then 'Freeze pane in excel if not
passed or set true
objExcel.ActiveWindow.FreezePanes = True
Else
If FreezePanes Then
objExcel.ActiveWindow.FreezePanes = True
End If
End If
End With 'xlSheet
Set xlSheet = Nothing
End Function
Private Function format_Range_from_RST(rst As Recordset, objExcel As
Object, strSheetname As String, lng_Counter_Outer As Long, Optional
lng_Row_Start, Optional lng_Column_Start)
'this private function is written to format entire column with data
type from source recordset
Dim obj As Object
With objExcel.worksheets(strSheetname)
If IsMissing(lng_Row_Start) Then 'set obj = desired excel range
Set obj = .range(Get_Excel_Column(lng_Counter_Outer) & ":" &
Get_Excel_Column(lng_Counter_Outer))
Else
Set obj = .range(Chr(lng_Counter_Outer + 65 + lng_Column_Start) &
":" & Chr(lng_Counter_Outer + 65 + lng_Row_Start))
End If
With obj
Select Case rst.Fields(lng_Counter_Outer).Type
Case 2, 3, 4, 7 '2 number Byte, 3 number Integer, 4 number Long
Integer, 7 'number Double
.NumberFormat = "0"
Case 6 'number Single
'If rst.Fields(lng_Counter_Outer).Properties("format") =
"Percent" Then
'.NumberFormat = "0.00%"
'Else
.NumberFormat = "0.00"
'End If
Case 15 'number Replication ID
.NumberFormat = "@"
Case 8 ' Date/Time
.NumberFormat = "mm/dd/yyyy;@"
Case 5 ' Currency
.NumberFormat = "$#,##0.00"
Case 10, 1, 12, 11 ' 10 text, 1 Yes/No, 12 Hyperlink, 11 OLE
Object
.NumberFormat = "@"
Case Else
With rst.Fields(lng_Counter_Outer)
MsgBox "this datatype has not been tested by Eric Gerds" & _
vbCrLf & "Field " & .Name * " Type is " & .Type
End With
End Select
End With 'object
Set obj = Nothing
End With 'xlSheet
End Function
Function Get_Excel_Column(ByVal lng_Num As Long) As String
'2009-01-07 14:22 egerds wrote to return the relative excel column
'examples 0=A 1=B 26=AA
If lng_Num < 26 Then
Get_Excel_Column = Chr(lng_Num + 65)
Else
Get_Excel_Column = Chr(lng_Num \ 26 + 64) & Chr(lng_Num Mod 26 + 65)
End If
End Function
Function rst_fld_Count(ByVal doc_Name As String) As Long
'written by egerds 2008-12-10 for a more generic reference to source
data
'
http://www.mvps.org/access/queries/qry0013.htm
On Error GoTo rst_fld_Count_Error 'if recordset is a query with form
param's then attempt to resolve them
Dim rst As Recordset
Set rst = CurrentDb.OpenRecordset(doc_Name)
With rst
rst_fld_Count = .Fields.count
.Close
End With
Set rst = Nothing
Exit Function
rst_fld_Count_Error:
Select Case Err.Number
Case 3021
MsgBox "The source Recordset is empty"
Case 3061 ' data source if a query with parameters
On Error Resume Next
Dim qdf As QueryDef, prm As Parameter
Set qdf = CurrentDb.QueryDefs(doc_Name)
For Each prm In qdf.Parameters
prm.Value = Eval(prm.Name)
Next prm
Set rst = qdf.OpenRecordset(dbOpenDynaset)
With rst
rst_fld_Count = .Fields.count
.Close
End With
Set rst = Nothing
Set prm = Nothing
Set qdf = Nothing
Case Else
MsgBox Err.Number & vbCrLf & Err.description
End Select
End Function
Function rst_row_Count(ByVal doc_Name As String) As Long
'written by egerds 2008-12-10 for a more generic reference to source
data
'
http://www.mvps.org/access/queries/qry0013.htm
On Error GoTo rst_row_Count_Error 'if recordset is a query with form
param's then attempt to resolve them
Dim rst As Recordset
Set rst = CurrentDb.OpenRecordset(doc_Name)
With rst
.MoveLast
rst_row_Count = .RecordCount
.Close
End With
Set rst = Nothing
Exit Function
rst_row_Count_Error:
Select Case Err.Number
Case 3021
MsgBox "The source Recordset is empty"
Case 3061 ' data source if a query with parameters
On Error Resume Next
Dim qdf As QueryDef, prm As Parameter
Set qdf = CurrentDb.QueryDefs(doc_Name)
For Each prm In qdf.Parameters
prm.Value = Eval(prm.Name)
Next prm
Set rst = qdf.OpenRecordset(dbOpenDynaset)
With rst
.MoveLast
rst_row_Count = .RecordCount
.Close
End With
Set rst = Nothing
Set prm = Nothing
Set qdf = Nothing
Case Else
MsgBox Err.Number & vbCrLf & Err.description
End Select
End Function
Function Has_Params(str_Obj_Name As String)
'2009-01-09 13:19 egerds wrote to test if str_obj_name has parameters
On Error GoTo Err_Has_Params_Error
Has_Params = False
Dim qdf As QueryDef, prm As Parameter
Set qdf = CurrentDb.QueryDefs(str_Obj_Name)
For Each prm In qdf.Parameters
Has_Params = True
Next
Err_Has_Params_Resume:
Set prm = Nothing
Set qdf = Nothing
Exit Function
Err_Has_Params_Error:
Resume Err_Has_Params_Resume
End Function
