recordset where sequence with excel export 1

[knownote]

hello all,

I'm stuck after trying to combine parts of 3 separate
code to export to excel (including what to keep or delete).
First, can I combine a text primary key and an autonumber
in an AND within a WHERE statement?
Second, what is the proper sequence of recordset and Excel
lines of code? Thanks.

John
----Code ----

'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 New Excel.Application
Dim oBook As Excel.Workbook
Dim oSheet As Excel.Worksheet

'Ask for SaveFileName
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
GoTo Exit_cmd?_Click
End If

'Save to file
Set db = CurrentDb
Set oApp = New Excel.Application
Set rs = db.OpenRecordset("Select * FROM tblClients WHERE tblClients.Subgect = Nz(Me![Subgect]) And tblClients.CustomerID

= " & Me.CustomerID", _
dbOpenSnapshot)

'Indicate task complete
MsgBox "File " & strSaveFileName & " successfully saved"


'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

 

[PHV]

Some notes:
'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

'Ask for SaveFileName
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
GoTo Exit_cmd?_Click
End If

'Save to file
Set db = CurrentDb
Set oApp = New Excel.Application
[!] Set rs = db.OpenRecordset("Select * FROM tblClients WHERE Subgect='" & Nz(Me![Subgect], "") & "' And CustomerID=" & Me.CustomerID", _[/!]
dbOpenSnapshot)

'Indicate task complete
MsgBox "File " & strSaveFileName & " successfully saved"

'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

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[knownote]

PHV,

Thanks, it works. Just a minor error message after
the current record is displayed in Excel:

Run-time error '1004':

'C:\My Documents\tryit.xls' could not be found. Check the spelling of the file name, and
verify that the file location is correct.

Should the order of some lines be rearranged? I don't
want to regress by trying it myself. Thanks.

John

 

[knownote]

PHV,

Submitted too soon.

Thanks, it works. Just a minor error message after
the current record is displayed in Excel:

Run-time error '1004':

'C:\My Documents\tryit.xls' could not be found. Check the spelling of the file name, and
verify that the file location is correct.

Should the order of some lines be rearranged? I don't
want to regress by trying it myself. 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
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

'Save to file
Set db = CurrentDb
Set oApp = New Excel.Application
Set rs = db.OpenRecordset("Select * FROM tblClients WHERE Subgect='" & Nz(Me![Subgect], "") & "'")

'Indicate task complete
MsgBox "File " & strSaveFileName & " successfully saved"

'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