Hi there
Hope this helps others
Public Function Export_Excel_10(dblocation As Variant)
On Error GoTo Err_Export_Excel_10
Dim x1 As Excel.Application
Dim excelwbkXL As Object
Dim excelwksXL As Object
Dim counter As Integer, row As Integer
Dim strSQL1 As String, strSQL4 As String
Dim strPath_Security_WkGrp As String, strPath_Security_User As String
Dim strPath_Security_Pwd As String, strPath As String
Dim cnt As New ADODB.Connection, rst As New ADODB.Recordset
Dim D As DAO.Database, R As DAO.Recordset, s As String
Dim I As Integer
Dim strTable As Integer
'***AIM-Default Settings
dblocation = "C:\WWL.PipeSpec\book1.xls"
strPath = "C:\WWL.PipeSpec\PipeSpec.mdb"
strPath_Security_WkGrp = "C:\WWL.PipeSpec\WorkGroup\wwl_sys1.mda"
strPath_Security_User = ""
strPath_Security_Pwd = ""
strTable = 0
'***AIM-Open the Excel spreadsheet.
Set x1 = CreateObject("Excel.application")
Set excelwbkXL = x1.Workbooks.Open(dblocation)
'***AIM-Display Excel and give user control of Excel
x1.Visible = True
x1.UserControl = True
'***AIM-Set the string to the path of the Working database
Set cnt = New ADODB.Connection
With cnt
.Provider = "Microsoft.Jet.OLEDB.4.0"
.CursorLocation = adUseClient
'.Properties("Jet OLEDB:Database Password") = "" --> password
.Properties("Jet OLEDB:System Database") =
strPath_Security_WkGrp
.Open strPath, strPath_Security_User, strPath_Security_Pwd
End With
s = "SELECT Table_Name FROM STANDARD_TABLES"
Set D = CurrentDb
Set R = D.OpenRecordset(s)
'***AIM-LOOP THROUGH RECORDS IN PathTextTech
Do Until R.EOF
If R!table_name = "Pass" Or R!table_name = "Timeout" Then
'
Else
strSQL1 = "select * from " & R!table_name & ";"
End If
strSQL4 = "select * from " & R!table_name & ";"
strTable = strTable + 1
Set rst = New ADODB.Recordset
rst.Open strSQL4, cnt
'***AIM-Add new sheet
Set excelwksXL = excelwbkXL.Worksheets.Add
'***AIM-Spreadsheet - sheet name
excelwksXL.NAME = R!table_name
'***AIM-Make the column headers.
For I = 1 To rst.Fields.Count - 1
excelwksXL.Cells(9, I).Value = rst.Fields(I).NAME
Next I
'***AIM-Get data from the database and insert
'***AIM-it into the spreadsheet.
row = 10
Do While Not rst.EOF
For I = 1 To rst.Fields.Count - 1
excelwksXL.Cells(row, I) = rst.Fields(I).Value
Next I
row = row + 1
rst.MoveNext
Loop
'***AIM-Need to disable, can't handle large number of rows
(2000>)
'***AIM-Formatting
'excelwksXL.range(excelwksXL.Cells(1, 1), _
'excelwksXL.Cells(1, row)).Select
'x1.Selection.EntireColumn.AutoFit
'X1.Selection.Columns.AutoFit
R.MoveNext
Loop
R.Close
D.Close
Set excelwbkXL = Nothing
Set excelwksXL = Nothing
'***AIM-End Message
msgbox "Transfered over " & strTable & " tables out of 33 in
total.", vbInformation
Exit_Export_Excel_10:
Exit Function
Err_Export_Excel_10:
msgbox ERR.Description
Resume Exit_Export_Excel_10
End Function
