Access Excel Automation Formatting Problem

[ImraneA]

Hi there
Have a database, where front-end interface allows user to select a ms
access database. From there, standard tables are linked. Routine,
that creates a spreadsheet, for each table a separate sheet within
spreadsheet is created. Particular fields are selected.

User requires fields to be auto-fitted. Problem, is that some tables
have more than 1200> rows. Code generates error message. Is there a
way of getting around this problem. See ***

Code -->

Public Function Export_Excel_10(dblocation As Variant)
On Error GoTo Err_Export_Excel_10

'***AIM-Testing
'CALL Export_Excel_10("T:\TechCentral\techCENTRAL\StdSpe cs\WWL\A0000.MDB")

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 strSQL4A As String, strSQL4B As String, strSQL4C As String,
strSQL4D As String
Dim strSQL4E As String, strSQL4F As String, strSQL4G As String,
strSQL4H 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
Dim posLONG_DESCR As Integer, posMAIN_SIZE As Integer, posRUN_SIZE As
Integer, posBRAN_SIZE As Integer
Dim posSCHEDULE As Integer, posRATING As Integer, posSHORT_DESC As
Integer, posCATALOG As Integer

'***AIM-Column Position of fields
posLONG_DESCR = 1
posMAIN_SIZE = 2
posRUN_SIZE = 3
posBRAN_SIZE = 4
posSCHEDULE = 5
posRATING = 6
posSHORT_DESC = 7
posCATALOG = 8

'***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
'do nothing
ElseIf R!table_name <> "pumpa" Then
strSQL4A = "SELECT [LONG_DESCR], [MAIN_SIZE], [RUN_SIZE],
[BRAN_SIZE], [SCHEDULE], [RATING], [SHORT_DESC], [CATALOG] from " &
R!table_name
strSQL4 = strSQL4A & " ORDER BY [LONG_DESCR], [MAIN_SIZE],
[RUN_SIZE], [BRAN_SIZE], [SCHEDULE], [RATING], [SHORT_DESC], [CATALOG]
" & ";"

ElseIf R!table_name = "pumpa" Then
strSQL4A = "SELECT [LONG_DESCR], [LONG_DESCR], [CATALOG]
from " & R!table_name
strSQL4 = strSQL4A & " ORDER BY [LONG_DESCR], [CATALOG] "
& ";"
End If

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

If R!table_name <> "pumpa" Then

'***AIM-Make the column headers.
For I = 1 To rst.Fields.Count - 1

'***AIM-Fields
If rst.Fields(I).NAME = "LONG_DESCR" Then
excelwksXL.Cells(1, posLONG_DESCR).Value =
rst.Fields(I).NAME
ElseIf rst.Fields(I).NAME = "MAIN_SIZE" Then
excelwksXL.Cells(1, posMAIN_SIZE).Value =
rst.Fields(I).NAME
ElseIf rst.Fields(I).NAME = "RUN_SIZE" Then
excelwksXL.Cells(1, posRUN_SIZE).Value =
rst.Fields(I).NAME
ElseIf rst.Fields(I).NAME = "BRAN_SIZE" Then
excelwksXL.Cells(1, posBRAN_SIZE).Value =
rst.Fields(I).NAME
ElseIf rst.Fields(I).NAME = "SCHEDULE" Then
excelwksXL.Cells(1, posSCHEDULE).Value =
rst.Fields(I).NAME
ElseIf rst.Fields(I).NAME = "RATING" Then
excelwksXL.Cells(1, posRATING).Value =
rst.Fields(I).NAME
ElseIf rst.Fields(I).NAME = "SHORT_DESC" Then
excelwksXL.Cells(1, posSHORT_DESC).Value =
rst.Fields(I).NAME
ElseIf rst.Fields(I).NAME = "CATALOG" Then
excelwksXL.Cells(1, posCATALOG).Value =
rst.Fields(I).NAME
End If

Next I

'***AIM-Get data from the database and insert
'***AIM-it into the spreadsheet.
row = 2
Do While Not rst.EOF
For I = 1 To rst.Fields.Count - 1
'***AIM-Fields
If rst.Fields(I).NAME = "LONG_DESCR" Then
excelwksXL.Cells(row, posLONG_DESCR) =
rst.Fields(I).Value
ElseIf rst.Fields(I).NAME = "MAIN_SIZE" Then
excelwksXL.Cells(row, posMAIN_SIZE) =
rst.Fields(I).Value
ElseIf rst.Fields(I).NAME = "RUN_SIZE" Then
excelwksXL.Cells(row, posRUN_SIZE) =
rst.Fields(I).Value
ElseIf rst.Fields(I).NAME = "BRAN_SIZE" Then
excelwksXL.Cells(row, posBRAN_SIZE) =
rst.Fields(I).Value
ElseIf rst.Fields(I).NAME = "SCHEDULE" Then
excelwksXL.Cells(row, posSCHEDULE) =
rst.Fields(I).Value
ElseIf rst.Fields(I).NAME = "RATING" Then
excelwksXL.Cells(row, posRATING) =
rst.Fields(I).Value
ElseIf rst.Fields(I).NAME = "SHORT_DESC" Then
excelwksXL.Cells(row, posSHORT_DESC) =
rst.Fields(I).Value
ElseIf rst.Fields(I).NAME = "CATALOG" Then
excelwksXL.Cells(row, posCATALOG) =
rst.Fields(I).Value
End If

Next I
row = row + 1
rst.MoveNext
Loop

ElseIf R!table_name = "pumpa" Then

'***AIM-Make the column headers.
For I = 1 To rst.Fields.Count - 1

'***AIM-Fields
If rst.Fields(I).NAME = "LONG_DESCR" Then
excelwksXL.Cells(1, 2).Value = rst.Fields(I).NAME
ElseIf rst.Fields(I).NAME = "CATALOG" Then
excelwksXL.Cells(1, 3).Value = rst.Fields(I).NAME
End If

Next I

'***AIM-Get data from the database and insert
'***AIM-it into the spreadsheet.
row = 2
Do While Not rst.EOF
For I = 1 To rst.Fields.Count - 1
'***AIM-Fields
If rst.Fields(I).NAME = "LONG_DESCR" Then
excelwksXL.Cells(row, 2) = rst.Fields(I).Value
ElseIf rst.Fields(I).NAME = "CATALOG" Then
excelwksXL.Cells(row, 3) = rst.Fields(I).Value
End If

Next I
row = row + 1
rst.MoveNext
Loop

End If
************************************************** *****************
'***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
'excelwksXL.range(excelwksXL.Cells(1, 1), excelwksXL.Cells(2,
row)).Select
'excelwksXL.range(excelwksXL.Cells(1, 1), excelwksXL.Cells(8,
200)).Select
'x1.Selection.EntireColumn.AutoFit
'***AIM-Print Setup properties
'x1.ActiveSheet.PageSetup.Zoom = 70
'x1.ActiveSheet.PageSetup.Orientation = xlLandscape
'x1.ActiveSheet.PageSetup.PrintArea = "$A$1:" & "$H" & "$" &
row
'x1.ActiveSheet.PageSetup.PaperSize = xlPaperA4
'x1.ActiveSheet.PageSetup.Sort = column1

************************************************** **

R.MoveNext
Loop
R.Close
D.Close

excelwksXL.range(excelwksXL.Cells(1, 1), _
excelwksXL.Cells(1, row)).Select
x1.Selection.EntireColumn.AutoFit
Set excelwbkXL = Nothing
Set excelwksXL = Nothing

'***AIM-End Message
msgbox "Transfered over " & strTable & " tables out of 31 in
total.", vbInformation

Exit_Export_Excel_10:
Exit Function

Err_Export_Excel_10:
msgbox ERR.Description
Resume Exit_Export_Excel_10

End Function