Well, I made some progress as far as no more
run-time error 91:
Object variable or With block variable not set
I probably still have certain formatting lines in the wrong
with app and with sheet/range sections.
This code works now - it transfers the current record to
Excel - but, it saves a blank spreadsheet before the
transfer, then asks to save it again.
Is there any correlation between the two?
Thanks
John
----Code
Private Sub cmdExcelSend_Click()
'Get recordset from Client's table
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strFilter As String
Dim qDef As QueryDef
Dim strSaveFileName As String
Dim fPath As String
Dim intLastCol As Integer
Dim oApp As Excel.Application
Dim oBook As Excel.Workbook
Dim oSheet As Excel.Worksheet
Const conMAX_ROWS = 20000
'Ask for SaveFileName; Save to file
strFilter = ahtAddFilterItem("", "Excel Files (*.xls)", "*.xls")
strSaveFileName = ahtCommonFileOpenSave(OpenFile:=False, Filter:=strFilter, _
Flags:=ahtOFN_OVERWRITEPROMPT Or ahtOFN_READONLY)
'Test if Save As... cancelled
If strSaveFileName = "" Then
Exit Sub ' GoTo Exit_cmdExcelSend_Click
End If
'Indicate task complete
' MsgBox "File " & strSaveFileName & " successfully saved"
Set db = CurrentDb
Set oApp = GetObject(, "Excel.Application")
If err.Number <> 0 Then
Set oApp = CreateObject("Excel.Application")
'Else: Set oApp = New Excel.Application 'instantiate Excel
End If
Set rs = db.OpenRecordset("Select * FROM tblClients WHERE Subgect='" & Nz(Me![Subgect], "") & "'")
'Start a new workbook in Excel
Set oBook = oApp.Workbooks.Add
Set oSheet = oBook.Worksheets(1)
'Add the field names in row 1
Dim i As Integer
Dim iNumCols As Integer
iNumCols = rs.Fields.Count
For i = 1 To iNumCols
oSheet.Cells(1, i).Value = rs.Fields(i - 1).Name
Next
'Add the data starting at cell A2
oSheet.Range("A2").CopyFromRecordset rs
'Format the header row as bold and autofit the columns
With oSheet.Range("a1").Resize(1, iNumCols)
.Font.Bold = True
.EntireColumn.AutoFit
End With
oApp.Visible = True
oApp.UserControl = True
With oApp
.Visible = True
Set oBook = .Workbooks.Open(strSaveFileName)
On Error Resume Next
Set oSheet = oBook.Worksheets("Sheet1")
If Not err.Number = 0 Then
Set oSheet = oBook.Worksheets.Add
' oSheet.Name = conSHT_NAME
End If
err.Clear
On Error GoTo 0
intLastCol = oSheet.UsedRange.Columns.Count
With oSheet
.Range(.Cells(1, 1), .Cells(conMAX_ROWS, _
intLastCol)).ClearContents
.Range(.Cells(1, 1), _
.Cells(1, rs.Fields.Count)).Font.Bold = True
.Range("A2").CopyFromRecordset rs
End With
End With
oBook.close True
Set oSheet = Nothing
Set oBook = Nothing
oApp.Quit ' NOTE - changed sequence
Set oApp = Nothing
rs.close
db.close
Set rs = Nothing
Set db = Nothing
' Set qDef = Nothing
End Sub
run-time error 91:
Object variable or With block variable not set
I probably still have certain formatting lines in the wrong
with app and with sheet/range sections.
This code works now - it transfers the current record to
Excel - but, it saves a blank spreadsheet before the
transfer, then asks to save it again.
Is there any correlation between the two?
Thanks
John
----Code
Private Sub cmdExcelSend_Click()
'Get recordset from Client's table
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strFilter As String
Dim qDef As QueryDef
Dim strSaveFileName As String
Dim fPath As String
Dim intLastCol As Integer
Dim oApp As Excel.Application
Dim oBook As Excel.Workbook
Dim oSheet As Excel.Worksheet
Const conMAX_ROWS = 20000
'Ask for SaveFileName; Save to file
strFilter = ahtAddFilterItem("", "Excel Files (*.xls)", "*.xls")
strSaveFileName = ahtCommonFileOpenSave(OpenFile:=False, Filter:=strFilter, _
Flags:=ahtOFN_OVERWRITEPROMPT Or ahtOFN_READONLY)
'Test if Save As... cancelled
If strSaveFileName = "" Then
Exit Sub ' GoTo Exit_cmdExcelSend_Click
End If
'Indicate task complete
' MsgBox "File " & strSaveFileName & " successfully saved"
Set db = CurrentDb
Set oApp = GetObject(, "Excel.Application")
If err.Number <> 0 Then
Set oApp = CreateObject("Excel.Application")
'Else: Set oApp = New Excel.Application 'instantiate Excel
End If
Set rs = db.OpenRecordset("Select * FROM tblClients WHERE Subgect='" & Nz(Me![Subgect], "") & "'")
'Start a new workbook in Excel
Set oBook = oApp.Workbooks.Add
Set oSheet = oBook.Worksheets(1)
'Add the field names in row 1
Dim i As Integer
Dim iNumCols As Integer
iNumCols = rs.Fields.Count
For i = 1 To iNumCols
oSheet.Cells(1, i).Value = rs.Fields(i - 1).Name
Next
'Add the data starting at cell A2
oSheet.Range("A2").CopyFromRecordset rs
'Format the header row as bold and autofit the columns
With oSheet.Range("a1").Resize(1, iNumCols)
.Font.Bold = True
.EntireColumn.AutoFit
End With
oApp.Visible = True
oApp.UserControl = True
With oApp
.Visible = True
Set oBook = .Workbooks.Open(strSaveFileName)
On Error Resume Next
Set oSheet = oBook.Worksheets("Sheet1")
If Not err.Number = 0 Then
Set oSheet = oBook.Worksheets.Add
' oSheet.Name = conSHT_NAME
End If
err.Clear
On Error GoTo 0
intLastCol = oSheet.UsedRange.Columns.Count
With oSheet
.Range(.Cells(1, 1), .Cells(conMAX_ROWS, _
intLastCol)).ClearContents
.Range(.Cells(1, 1), _
.Cells(1, rs.Fields.Count)).Font.Bold = True
.Range("A2").CopyFromRecordset rs
End With
End With
oBook.close True
Set oSheet = Nothing
Set oBook = Nothing
oApp.Quit ' NOTE - changed sequence
Set oApp = Nothing
rs.close
db.close
Set rs = Nothing
Set db = Nothing
' Set qDef = Nothing
End Sub