Re: Format Excel - Object required error

Jake,
there is a complicated bit of code needed to talk to excel via access and
tell excel to autofit the columns.


Public Sub FormatXLReport(strPath As String, _
strFile As String, _
strMakeActive As String)
'strMakeActive name of work*** to activate

On Error GoTo SubErr
pstrProc = "FormatXLReport"
pstrSubProc = "FormatXLReport"
Dim db As DAO.Database
Dim blnExcelExists As Boolean
Dim objXLApp As Object
Dim objActiveWkb As Object
Dim objXLWkb As Object
Dim objXLws As Object
Dim strWkbName As String
Dim strCriteria As String
Dim strRange As String 'used to set the print area


Const xlLandscape = 2
Const xlRight = -4152
Const xlCentre = -4108
Const xlAutomatic = -4105
Const xlContinuous = 1
Const xlCellTypeLastCell = 11

Const pmsg2 = "There is already an open excel file called "

Const pmsg3 = vbCrLf & vbCrLf & "You must choose a different name for
this report or close the excel report already open with the same name"

Const pmsg4 = "Unable to open report in Excel. Before you try again,
open Excel on your computer. "

Set db = DBEngine(0)(0)
'Open the spread*** for formatiing

If fIsAppRunning("excel", False) Then 'yes it is running
' Get a reference to currently running Excel window
Set objXLApp = GetObject(, "Excel.Application")
blnExcelExists = True
Else
' Excel is not currently running so create a new instance
Set objXLApp = CreateObject("Excel.Application")
End If


'Hide warnings on the spread***
objXLApp.DisplayAlerts = False
'prevent any excel macros from running
objXLApp.Interactive = False
'hide screen changes
objXLApp.ScreenUpdating = False
'Open a workbook
objXLApp.Workbooks.Open (strPath)
'point to the active workbook
Set objXLWkb = objXLApp.Workbooks(strFile)
'Debug.Print "active workbook: " & objXLWkb.Name
'activate the selected workbook
objXLWkb.Activate
'Debug.Print strMakeActive
'Debug.Print "active sheet: " & ObjXLApp.ActiveWorkbook.Worksheets(1)
'point to the wanted work***
Set objXLws = objXLApp.ActiveWorkbook.Worksheets(1)
'activate the selected work***
objXLws.Activate

'now format the report

With objXLws.Cells

'format the cells
.Font.Name = "Arial"
.Font.FontStyle = "Regular"
.Font.Size = 10
'bold the headings
.Rows("1:1").Font.Bold = True
.WrapText = True
'Put Borders around all cells in the Data Area
.Range(.Cells(1, 1), .Cells(1,
1).SpecialCells(xlCellTypeLastCell)).Borders.LineStyle = xlContinuous
.Range(.Cells(1, 1), .Cells(1,
1).SpecialCells(xlCellTypeLastCell)).Borders.ColorIndex = xlAutomatic
'auto fit columns
.Range("A:R").Columns.AutoFit
'auto fit row height
.Rows.AutoFit

strRange = .Range(.Cells(1, 1), .Cells(1,
1).SpecialCells(xlCellTypeLastCell)).Address
'Debug.Print strRange
End With

'now do page set up

With objXLws.PageSetup
.Orientation = xlLandscape
'If zoom property is False, the FitToPagesWide and FitToPagesTall
properties
'control how the work*** is scaled
.Zoom = False
.FitToPagesTall = False
.FitToPagesWide = 1
.CenterHeader = Me.txtCurrYear & " " & Me.cboResource _
& " Hours " & strMonth & " YTD"
.CenterFooter = "&F"
.CenterFooter = "&F" & " " & "&D"
.RightFooter = "&R Page &P of &N"
.LeftMargin = objXLApp.CentimetersToPoints(0.5)
.RightMargin = objXLApp.CentimetersToPoints(1.5)
.TopMargin = objXLApp.CentimetersToPoints(1#)
.BottomMargin = objXLApp.CentimetersToPoints(1#)
.HeaderMargin = objXLApp.CentimetersToPoints(0.7)
.FooterMargin = objXLApp.CentimetersToPoints(0.7)
.printarea = strRange
'Debug.Print .printarea
End With

'put focus back to first data cell
objXLws.Range("A2").Select

'Prevent Excel from prompting to save changes
objXLApp.ActiveWorkbook.Save

SubExit:
'turn on warnings on the spread***
objXLApp.DisplayAlerts = True
'allow any excel macros from running
objXLApp.Interactive = True
'show screen changes
objXLApp.ScreenUpdating = True

'close the instance of Excel created by code
If Not blnExcelExists Then
objXLApp.Quit
End If

If Not objActiveWkb Is Nothing Then
Set objActiveWkb = Nothing
End If
If Not objXLApp Is Nothing Then
Set objXLApp = Nothing
End If
If Not db Is Nothing Then
Set db = Nothing
End If

DoCmd.Hourglass False
Exit Sub

SubErr:
Select Case Err.Number
Case 3010
MsgBox pmsg2 & strPath & pmsg3, vbInformation, pstrT
Case 70, 430
MsgBox pmsg4, vbInformation, pstrT
Case Else
MsgBox err.Number & " " & err.Description
End Select
Resume SubExit

End Sub


the code below is from the Access Web
paste all of it into a new module and save as modIsRunning
this code is used in the code above to open the report in excel


Option Compare Database
Option Explicit

'***************** Code Start ***************
'This code was originally written by Dev Ashish.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code Courtesy of
'Dev Ashish
'
Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1
Private Const SW_NORMAL = 1
Private Const SW_SHOWMINIMIZED = 2
Private Const SW_SHOWMAXIMIZED = 3
Private Const SW_MAXIMIZE = 3
Private Const SW_SHOWNOACTIVATE = 4
Private Const SW_SHOW = 5
Private Const SW_MINIMIZE = 6
Private Const SW_SHOWMINNOACTIVE = 7
Private Const SW_SHOWNA = 8
Private Const SW_RESTORE = 9
Private Const SW_SHOWDEFAULT = 10
Private Const SW_MAX = 10

Private Declare Function apiFindWindow Lib "user32" Alias _
"FindWindowA" (ByVal strClass As String, _
ByVal lpWindow As String) As Long

Private Declare Function apiSendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hwnd As Long, ByVal Msg As Long, ByVal _
wParam As Long, lParam As Long) As Long

Private Declare Function apiSetForegroundWindow Lib "user32" Alias _
"SetForegroundWindow" (ByVal hwnd As Long) As Long

Private Declare Function apiShowWindow Lib "user32" Alias _
"ShowWindow" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

Private Declare Function apiIsIconic Lib "user32" Alias _
"IsIconic" (ByVal hwnd As Long) As Long

Function fIsAppRunning(ByVal strAppName As String, _
Optional fActivate As Boolean) As Boolean
Dim lngH As Long
Dim strClassName As String
Dim lngX As Long
Dim lngTmp As Long

Const WM_USER = 1024
On Local Error GoTo fIsAppRunning_Err
fIsAppRunning = False
Select Case LCase$(strAppName)
Case "excel": strClassName = "XLMain"
Case "word": strClassName = "OpusApp"
Case "access": strClassName = "OMain"
Case "powerpoint95": strClassName = "PP7FrameClass"
Case "powerpoint97": strClassName = "PP97FrameClass"
Case "notepad": strClassName = "NOTEPAD"
Case "paintbrush": strClassName = "pbParent"
Case "wordpad": strClassName = "WordPadClass"
Case Else: strClassName = vbNullString
End Select

If strClassName = "" Then
lngH = apiFindWindow(vbNullString, strAppName)
Else
lngH = apiFindWindow(strClassName, vbNullString)
End If
If lngH <> 0 Then
apiSendMessage lngH, WM_USER + 18, 0, 0
lngX = apiIsIconic(lngH)
If lngX <> 0 Then
lngTmp = apiShowWindow(lngH, SW_SHOWNORMAL)
End If
If fActivate Then
lngTmp = apiSetForegroundWindow(lngH)
End If
fIsAppRunning = True
End If
fIsAppRunning_Exit:
Exit Function
fIsAppRunning_Err:
fIsAppRunning = False
Resume fIsAppRunning_Exit
End Function
'******************** Code End ****************

Jeanette Cunningham


"Jake F" <JakeF@xxxxxxxxxxxxxxxxxxxxxxxxx> wrote in message
news:A133AEF4-3029-41B4-AABF-0A2F73E5D655@xxxxxxxxxxxxxxxx
I'm trying to format the cell widths for a query that I export into excel
and
I'm getting an "Object required" error. The file saves but the fields are
not autofit like they're supposed to be. I figure either I have the code
typed incorrectly or that the file is not created before the code gets to
the
formatting so it gets confused there. Here is my code and any help is
greatly appreciated.

Public Function HROrgChart()
On Error GoTo Err_HROrgChart

Dim strFileName As String
Dim strFileName2 As String

strFileName2 = "H:\HROrgChart\Org_Chart" + Format(Date, "dd-mmm-yyyy") +
".xls"

strSheetName = "xlApp." + strFileName2 + ".qryPCAOrgChartNew"

DoCmd.OutputTo acSendQuery, "qryPCAOrgChartNew", acFormatXLS, strFileName2

'AutoFit the columns
strSheetName.Range("A:CC").Columns.AutoFit

Forms![frmReportRun]![Last Run] = Date

Exit_HROrgChart:
Exit Function

Err_HROrgChart:
MsgBox Err.Description
Resume Exit_HROrgChart:
End Function



.