____________________________________

Attribute VB_Name = "ModAutoExcel"
Option Compare Database
Option Explicit
__________________________________________________

Sub sExcelArray()
Dim oExcel As Object
Dim oBook As Object
Dim oSheet As Object

'Start a new workbook in Excel
Set oExcel = CreateObject("Excel.Application")
Set oBook = oExcel.Workbooks.Add

'Create an array with 3 columns and 100 rows
Dim DataArray(1 To 100, 1 To 3) As Variant
Dim r As Integer
For r = 1 To 100
   DataArray(r, 1) = "ORD" & Format(r, "0000")
   DataArray(r, 2) = Rnd() * 1000
   DataArray(r, 3) = DataArray(r, 2) * 0.7
Next

'Add headers to the worksheet on row 1
Set oSheet = oBook.Worksheets(1)
oSheet.range("A1:C1").Value = Array("Order ID", "Amount", "Tax")

'Transfer the array to the worksheet starting at cell A2
oSheet.range("A2").Resize(100, 3).Value = DataArray

'Save the Workbook and Quit Excel
'oBook.SaveAs "C:\TestReportSheet.xls"
oExcel.Application.Visible = True
'oExcel.Quit
'MsgBox "Done"
Set oExcel = Nothing
Set oBook = Nothing
Set oSheet = Nothing
End Sub
__________________________________________________

Sub sExcelRecordSetArray(strOutSQL As String)
Dim oExcel As Object
Dim oBook As Object
Dim oSheet As Object
Dim Cdb As Database
Dim Rst As Recordset
Dim intFieldCount As Integer
Dim lngMax As Long
Dim Fld As Field
Dim lngRayCur As Long
Dim intFieldCur As Integer
Dim rayData() As Variant
Dim rayHeader() As String

Set Cdb = CurrentDb
Set Rst = Cdb.OpenRecordset(strOutSQL)
intFieldCount = Rst.Fields.Count
Rst.MoveLast
lngMax = Rst.RecordCount
Rst.MoveFirst
ReDim rayHeader(intFieldCount) As String

'Start a new workbook in Excel
Set oExcel = CreateObject("Excel.Application")
Set oBook = oExcel.Workbooks.Add
For Each Fld In Rst.Fields
    rayHeader(intFieldCur) = Fld.name
    intFieldCur = intFieldCur + 1
Next
intFieldCur = 0
'Add headers to the worksheet on row 1
Set oSheet = oBook.Worksheets(1)
oSheet.range("A1").Resize(1, intFieldCount).Value = rayHeader

'Create an array and populate with Rst data
ReDim rayData(lngMax, intFieldCount) As Variant
Do Until Rst.EOF
        intFieldCur = 0
    For Each Fld In Rst.Fields
        rayData(lngRayCur, intFieldCur) = Fld
        intFieldCur = intFieldCur + 1
    Next
    lngRayCur = lngRayCur + 1
    Rst.MoveNext
Loop

'Transfer the array to the worksheet starting at cell A2
oSheet.range("A2").Resize(lngMax, intFieldCount).Value = rayData

'Save the Workbook and Quit Excel
'oBook.SaveAs "C:\TestReportSheet.xls"
oExcel.Application.Visible = True
'oExcel.Quit
'MsgBox "Done"

Set oSheet = Nothing
Set oBook = Nothing
Set oExcel = Nothing
Set Rst = Nothing
Set Fld = Nothing
Set Cdb = Nothing
Erase rayData()
Erase rayHeader()

End Sub
__________________________________________________

Sub sExcelControl()
Dim strSQL As String

strSQL = "SELECT TOP 5 tblBaseReportData.saDivision, tblBaseReportData.SaDepartment, " _
        & "tblBaseReportData.saClass, tblBaseReportData.SaSKU, tblBaseReportData.SKU_Desc " _
        & "FROM tblBaseReportData;"
sExcelRecordSetArray strSQL
End Sub
__________________________________________________

Sub sExportReport(strReport As String, bolOpenExcel As Boolean)
Dim Cdb As Database
Dim Qdef As QueryDef
Dim RstData As Recordset
Dim RstFieldList As Recordset
Dim rayOut() As Variant
Dim Fld As Field
Dim oExcel As Object
Dim oBook As Object
Dim oSheet As Object
Dim strField As String
Dim lngRowMax As Long
Dim lngRowCur As Long
Dim intColMax As Integer
Dim intColCur As Integer
Dim strExcelWorkBook As String
Dim strStartPath As String
Dim strSQL As String
Dim Prm As Parameter


Set Cdb = CurrentDb
'get the name of the new excel file from the user
strStartPath = fCurrentPath()
strExcelWorkBook = GetSaveFullPath("New WorkBook", "Excel|*.xls|All Files|*.*", _
strStartPath, strReport, ".xls")
'ShowWait True
'Get the SQL String
strSQL = Forms!frmReportCriteria!txtReportSQL

Set Qdef = Cdb.CreateQueryDef("", strSQL)
'open a recordset against the sql statement

For Each Prm In Qdef.Parameters
        Prm.Value = Eval(Prm.name)
Next Prm

Set RstData = Qdef.OpenRecordset(dbOpenDynaset)
RstData.MoveLast
lngRowMax = RstData.RecordCount
RstData.MoveFirst

'get the field list
strSQL = "SELECT tblReportList.ReportName, tblReportList.ControlName, tblReportList.ControlSource, " _
            & "tblReportList.ReportLabel, tblReportList.Rank " _
            & "FROM tblReportList " _
            & "WHERE (((tblReportList.ReportName) = '" & strReport & "')) " _
            & "ORDER BY tblReportList.Rank;"
Set RstFieldList = Cdb.OpenRecordset(strSQL)

'determine the number of fields needed for the output array
RstFieldList.MoveLast
intColMax = RstFieldList.RecordCount
RstFieldList.MoveFirst

'create an array with the field names in order as the first row
ReDim rayOut(0 To lngRowMax, 0 To intColMax)
Do Until RstFieldList.EOF
    rayOut(0, intColCur) = RstFieldList!ReportLabel
    intColCur = intColCur + 1
    RstFieldList.MoveNext
Loop
'call the elements in order pulling the data from the apporpiate field or formula
Do Until RstData.EOF
'add the new row to the output array
lngRowCur = lngRowCur + 1
'ReDim Preserve rayOut(intColMax, lngRowMax)
RstFieldList.MoveFirst
    intColCur = 0
    Do Until RstFieldList.EOF
        strField = RstFieldList!ControlSource
        If Left(strField, 1) = "=" Then
'choose formula
Else
            rayOut(lngRowCur, intColCur) = RstData(strField)
        End If
        intColCur = intColCur + 1
        RstFieldList.MoveNext
    Loop
'get the next rst record
RstData.MoveNext
Loop
'ShowWait False
'test for a running copy of Excel and link to it
If fIsAppRunning("XLMain") Then
    Set oExcel = GetObject("Excel.Application")
Else
'if not running then open a copy of Excel
Set oExcel = CreateObject("Excel.Application")
End If

'create a new workbook
Set oBook = oExcel.Workbooks.Add

'paste the output array into the spreadsheet
Set oSheet = oBook.Worksheets(1)
oSheet.range("A1").Resize(lngRowMax, intColMax).Value = rayOut

'Save the Workbook and Quit Excel
oBook.SaveAs strExcelWorkBook

'if the user wants to view the spreadsheet then make excel visible
If bolOpenExcel Then
    oExcel.Application.Visible = True
Else
    oExcel.Quit
End If

Exit_sExportReport:
Set RstData = Nothing
Set RstFieldList = Nothing
Set Qdef = Nothing
Set Cdb = Nothing
Erase rayOut()
Set Fld = Nothing
Set oExcel = Nothing
Set oBook = Nothing
Set oSheet = Nothing


End Sub
__________________________________________________

Function fCurrentPath()
Dim intSlash As Integer
Dim intLast As Integer
Dim strFullName As String
Dim strPath As String

strFullName = CurrentDb.name

Do
    intLast = InStr(intSlash + 1, strFullName, "\")
    If intLast = 0 Then
        Exit Do
    Else
        intSlash = intLast
    End If
Loop
strPath = Left(strFullName, intSlash - 1)
fCurrentPath = strPath
End Function
__________________________________________________

Sub sExportReport1(strReport As String, bolOpenExcel As Boolean)
Dim Cdb As Database
Dim Qdef As QueryDef
Dim RstData As Recordset
Dim RstFieldList As Recordset
Dim rayOut() As Variant
Dim Fld As Field
Dim oExcel As Object
Dim oBook As Object
Dim oSheet As Object
Dim strField As String
Dim lngRowMax As Long
Dim lngRowCur As Long
Dim intColMax As Integer
Dim intColCur As Integer
Dim strExcelWorkBook As String
Dim strStartPath As String
Dim strSQL As String
Dim Prm As Parameter
Dim varBookMark As Variant
Dim varOne As Variant
Dim varTwo As Variant
Dim strMsg As String

ShowWait False
Set Cdb = CurrentDb
'get the name of the new excel file from the user
strStartPath = fCurrentPath()
strExcelWorkBook = GetSaveFullPath("New WorkBook", "Excel|*.xls|All Files|*.*", _
strStartPath, strReport, ".xls")
Forms!frmReportCriteria.Repaint
ShowWait True
'Get the SQL String
strSQL = Forms!frmReportCriteria!txtReportSQL

Set Qdef = Cdb.CreateQueryDef("", strSQL)
'open a recordset against the sql statement

For Each Prm In Qdef.Parameters
        Prm.Value = Eval(Prm.name)
Next Prm

Set RstData = Qdef.OpenRecordset(dbOpenDynaset)
RstData.MoveLast
lngRowMax = RstData.RecordCount + 1
RstData.MoveFirst

If lngRowMax > 65536 Then
    ShowWait False
    strMsg = "The number of rows needed - " & lngRowMax & vbCrLf _
            & "Exceeds the Maximum size of an Excel Spreadsheet 65,536 Rows" & vbCrLf _
            & "Please select a report with fewer rows."
    MsgBox strMsg, vbCritical, "Too Many Rows in Report"
    GoTo Exit_sExportReport1
End If

'get the field list
strSQL = "SELECT tblReportList.ReportName, tblReportList.ControlName, tblReportList.ControlSource, " _
            & "tblReportList.ReportLabel, tblReportList.Rank " _
            & "FROM tblReportList " _
            & "WHERE (((tblReportList.ReportName) = '" & strReport & "')) " _
            & "ORDER BY tblReportList.Rank;"
Set RstFieldList = Cdb.OpenRecordset(strSQL)

'determine the number of fields needed for the output array
RstFieldList.MoveLast
intColMax = RstFieldList.RecordCount - 2
RstFieldList.MoveFirst

'create an array with the field names in order as the first row
ReDim rayOut(0 To lngRowMax, 0 To intColMax)
Do Until RstFieldList.EOF
    If Not IsNull(RstFieldList!ReportLabel) Then
        rayOut(0, intColCur) = RstFieldList!ReportLabel
        intColCur = intColCur + 1
    End If
    RstFieldList.MoveNext
Loop

'call the elements in order pulling the data from the apporpiate field or formula
Do Until RstData.EOF
'add the new row to the output array
lngRowCur = lngRowCur + 1
'ReDim Preserve rayOut(intColMax, lngRowMax)
RstFieldList.MoveFirst
    intColCur = 0
    Do Until RstFieldList.EOF
        If Not IsNull(RstFieldList!ReportLabel) Then
            strField = RstFieldList!ControlSource
            If Left(strField, 1) = "=" Then
'choose formula
varBookMark = RstFieldList.Bookmark
                Select Case strField
                    Case "=[Sales_LY]-[txtExcs_LY]"
                        RstFieldList.FindFirst "ControlName = 'Sales_LY'"
                        varOne = RstData(RstFieldList!ControlSource)
                        If IsNull(varOne) Then varOne = 0
                        RstFieldList.FindFirst "ControlName = 'txtExcs_LY'"
                        varTwo = RstData(RstFieldList!ControlSource)
                        
                    Case "=[Sales_TY]-[txtExcs_TY]"
                        RstFieldList.FindFirst "ControlName = 'Sales_TY'"
                        varOne = RstData(RstFieldList!ControlSource)
                        If IsNull(varOne) Then varOne = 0
                        RstFieldList.FindFirst "ControlName = 'txtExcs_TY'"
                        varTwo = RstData(RstFieldList!ControlSource)
                    
                    Case "=[txtPercent_GM_TY]-[txtPercent_GM_LY]"
                        RstFieldList.FindFirst "ControlName = 'txtPercent_GM_TY'"
                        varOne = RstData(RstFieldList!ControlSource)
                        If IsNull(varOne) Then varOne = 0
                        RstFieldList.FindFirst "ControlName = 'txtPercent_GM_LY'"
                        varTwo = RstData(RstFieldList!ControlSource)
                    
                End Select
                rayOut(lngRowCur, intColCur) = varOne - varTwo
                RstFieldList.Bookmark = varBookMark
            Else
                rayOut(lngRowCur, intColCur) = RstData(strField)
            End If
            intColCur = intColCur + 1
        End If
        RstFieldList.MoveNext
    Loop
'get the next rst record
RstData.MoveNext
Loop
ShowWait False
'test for a running copy of Excel and link to it
If fIsAppRunning("XLMain") Then
    Set oExcel = GetObject("Excel.Application")
Else
'if not running then open a copy of Excel
Set oExcel = CreateObject("Excel.Application")
End If

'create a new workbook
Set oBook = oExcel.Workbooks.Add

'paste the output array into the spreadsheet
Set oSheet = oBook.Worksheets(1)
oSheet.range("A1").Resize(lngRowMax, intColMax).Value = rayOut
oSheet.range("A1").Resize(1, intColMax).Font.Bold = True

'Save the Workbook and Quit Excel
oBook.SaveAs strExcelWorkBook

'if the user wants to view the spreadsheet then make excel visible
If bolOpenExcel Then
    oExcel.Application.Visible = True
Else
    oExcel.Quit
End If

Exit_sExportReport1:
On Error Resume Next
Set RstData = Nothing
Set RstFieldList = Nothing
Set Qdef = Nothing
Set Cdb = Nothing
Erase rayOut()
Set Fld = Nothing
Set oExcel = Nothing
Set oBook = Nothing
Set oSheet = Nothing

End Sub
__________________________________________________

Sub sExportReport2(strReport As String, bolOpenExcel As Boolean)
Dim Cdb As Database
Dim Qdef As QueryDef
Dim RstData As Recordset
Dim RstFieldList As Recordset
Dim rayOut() As Variant
Dim Fld As Field
Dim oExcel As Object
Dim oBook As Object
Dim oSheet As Object
Dim strField As String
Dim lngRowMax As Long
Dim lngRowCur As Long
Dim intColMax As Integer
Dim intColCur As Integer
Dim strExcelWorkBook As String
Dim strStartPath As String
Dim strSQL As String
Dim Prm As Parameter
Dim varBookMark As Variant
Dim varOne As Variant
Dim varTwo As Variant
Dim strMsg As String

ShowWait False
Set Cdb = CurrentDb
'get the name of the new excel file from the user
strStartPath = fCurrentPath()
strExcelWorkBook = GetSaveFullPath("New WorkBook", "Excel|*.xls|All Files|*.*", _
strStartPath, strReport, ".xls")
Forms!frmReportCriteria.Repaint
ShowWait True
'Get the SQL String
strSQL = Forms!frmReportCriteria!txtReportSQL

Set Qdef = Cdb.CreateQueryDef("", strSQL)
'open a recordset against the sql statement

For Each Prm In Qdef.Parameters
        Prm.Value = Eval(Prm.name)
Next Prm

Set RstData = Qdef.OpenRecordset(dbOpenDynaset)
RstData.MoveLast
lngRowMax = RstData.RecordCount + 1
RstData.MoveFirst

If lngRowMax > 65536 Then
    ShowWait False
    strMsg = "The number of rows needed - " & lngRowMax & vbCrLf _
            & "Exceeds the Maximum size of an Excel Spreadsheet 65,536 Rows" & vbCrLf _
            & "Please select a report with fewer rows."
    MsgBox strMsg, vbCritical, "Too Many Rows in Report"
    GoTo Exit_sExportReport2
End If

'get the field list
strSQL = "SELECT tblReportList.ReportName, tblReportList.ControlName, tblReportList.ControlSource, " _
            & "tblReportList.ReportLabel, tblReportList.Rank, tblReportList.ColumnFormat " _
            & "FROM tblReportList " _
            & "WHERE (((tblReportList.ReportName) = '" & strReport & "')) " _
            & "ORDER BY tblReportList.Rank;"
Set RstFieldList = Cdb.OpenRecordset(strSQL)

'determine the number of fields needed for the output array
RstFieldList.MoveLast
intColMax = RstFieldList.RecordCount - 2
RstFieldList.MoveFirst

'create an array with the field names in order as the first row
ReDim rayOut(0 To lngRowMax, 0 To intColMax)
Do Until RstFieldList.EOF
    If Not IsNull(RstFieldList!ReportLabel) Then
        rayOut(0, intColCur) = RstFieldList!ReportLabel
        intColCur = intColCur + 1
    End If
    RstFieldList.MoveNext
Loop

'call the elements in order pulling the data from the apporpiate field or formula
Do Until RstData.EOF
'add the new row to the output array
lngRowCur = lngRowCur + 1
'ReDim Preserve rayOut(intColMax, lngRowMax)
RstFieldList.MoveFirst
    intColCur = 0
    Do Until RstFieldList.EOF
        If Not IsNull(RstFieldList!ReportLabel) Then
            strField = RstFieldList!ControlSource
            If Left(strField, 1) = "=" Then
'choose formula
varBookMark = RstFieldList.Bookmark
                Select Case strField
                    Case "=[Sales_LY]-[txtExcs_LY]"
                        RstFieldList.FindFirst "ControlName = 'Sales_LY'"
                        varOne = RstData(RstFieldList!ControlSource)
                        If IsNull(varOne) Then varOne = 0
                        RstFieldList.FindFirst "ControlName = 'txtExcs_LY'"
                        varTwo = RstData(RstFieldList!ControlSource)
                        
                    Case "=[Sales_TY]-[txtExcs_TY]"
                        RstFieldList.FindFirst "ControlName = 'Sales_TY'"
                        varOne = RstData(RstFieldList!ControlSource)
                        If IsNull(varOne) Then varOne = 0
                        RstFieldList.FindFirst "ControlName = 'txtExcs_TY'"
                        varTwo = RstData(RstFieldList!ControlSource)
                    
                    Case "=[txtPercent_GM_TY]-[txtPercent_GM_LY]"
                        RstFieldList.FindFirst "ControlName = 'txtPercent_GM_TY'"
                        varOne = RstData(RstFieldList!ControlSource)
                        If IsNull(varOne) Then varOne = 0
                        RstFieldList.FindFirst "ControlName = 'txtPercent_GM_LY'"
                        varTwo = RstData(RstFieldList!ControlSource)
                    
                End Select
                rayOut(lngRowCur, intColCur) = varOne - varTwo
                RstFieldList.Bookmark = varBookMark
            Else
                rayOut(lngRowCur, intColCur) = RstData(strField)
            End If
            intColCur = intColCur + 1
        End If
        RstFieldList.MoveNext
    Loop
'get the next rst record
RstData.MoveNext
Loop
ShowWait False
'test for a running copy of Excel and link to it
If fIsAppRunning("XLMain") Then
    Set oExcel = GetObject("Excel.Application")
Else
'if not running then open a copy of Excel
Set oExcel = CreateObject("Excel.Application")
End If

'create a new workbook
Set oBook = oExcel.Workbooks.Add

'paste the output array into the spreadsheet
Set oSheet = oBook.Worksheets(1)
oSheet.range("A1").Resize(lngRowMax, intColMax).Value = rayOut
'oExcel.Application.Visible = True
'Format the Rows
oSheet.range("A1").Resize(1, intColMax).Font.Bold = True
intColCur = 0
RstFieldList.MoveFirst
Do Until RstFieldList.EOF
    If Not IsNull(RstFieldList!Rank) Then
    intColCur = intColCur + 1
    Select Case RstFieldList!columnformat
        Case "none"
'do nothing
Case "%"
            oSheet.Columns(intColCur).NumberFormat = "0.00%"
        Case "0"
            oSheet.Columns(intColCur).NumberFormat = "0"
        Case "0.00"
            oSheet.Columns(intColCur).NumberFormat = "0.00"
    End Select
    
    End If
    RstFieldList.MoveNext
Loop
'oSheet.range(12, 5).Value = "I am Here"

'Save the Workbook and Quit Excel
oBook.SaveAs strExcelWorkBook

'if the user wants to view the spreadsheet then make excel visible
If bolOpenExcel Then
    oExcel.Application.Visible = True
Else
    oExcel.Quit
End If

Exit_sExportReport2:
On Error Resume Next
Set RstData = Nothing
Set RstFieldList = Nothing
Set Qdef = Nothing
Set Cdb = Nothing
Erase rayOut()
Set Fld = Nothing
Set oExcel = Nothing
Set oBook = Nothing
Set oSheet = Nothing
Exit Sub

End Sub
____________________________________

			

[ Home ] [ Up ] [ Site Map ] [ Search ]

Send mail to CY Databases, P.O. Box 532178, Grand Prairie, TX 75053 or call 972-989-7198

Copyright © 2004 CY Databases
Last modified: February 04, 2005