I'm exporting a query to excel from access and I'm running into the problem if Excel auto-formatting the appended records that I am exporting to an excel file. Basically it's reformating "General" formatted fields to "Time/Date". So when I want to see the number 1, or 94 - Excel creates a strange date taht corresponds to that number. Like 09/10/1899 .. something along those lines. When I change the format manually back to general format, all is well. I'd like to do thsi by code so the end user doesn't have to.
I've already gone into my excel template that is being opened and tried to set the column format through there, but no good - the code just reformats for me.
I've been scanning the excel object library and it looks like there is something in the Range category I can use. But I'm having trouble putting my finger on it. Here is my code, please feel free to make suggestions.
'***
Function appndXLS(strPath As String, strFilename As String, strOpenFilename As String, _
strSHName As String, qrySQL As String)
'Create an Excel Instance
Set myXl = CreateObject("Excel.Application")
'Check to see if the template file exists:
If fbol_Check_File_Name(strPath, strOpenFilename, ".xls") = False Then
MsgBox "Template file missing." & Chr(13) & "Please place in the appropriate directory.", _
vbExclamation, "File missing:"
Exit Function
End If
'Set your Excel File to push the data too
Set myBk = myXl.Workbooks.Open(strPath & "\" & strOpenFilename & ".xls")
With myBk.Sheets(strSHName)
'Set your range to first available cell in Column A
'Stack your Sql in a String
Set db = CurrentDb()
Set qdf = db.CreateQueryDef("")
With qdf
.sql = db.QueryDefs(qrySQL).sql
Set rs = .OpenRecordset()
If rs.RecordCount = 0 Then
MsgBox "No records were found.", vbOKOnly
myBk.Close True: Set myBk = Nothing
myXl.Quit: Set myXl = Nothing
rs.Close
db.Close
Exit Function
End If
rs.MoveFirst
End With
If Not rs.EOF Then
rs.MoveLast: rs.MoveFirst
'Rezise Excel Target Range Cell Array to
'Accomodate Recordset Height/Width
.[a2].Resize(rs.RecordCount + 1, 3).CopyFromRecordset rs
'I think the correction needs to go right here[/color red]
' If SysName = "CASPR" Or SysName = "Canc_Def" Then
'.[a1].Resize(rs.RecordCount + 1, 3).CopyFromRecordset rs
' End If
End If
rs.Close
Set rs = Nothing
db.Close
End With
'Check to see if file already exists.
If fbol_Check_File_Name(strPath, strFilename & Format(Date, "YYYY_MM_DD"), ".xls") = True Then
myBk.Save
Else
myBk.SaveAs FileName:=strPath & "\" & strFilename & Format(Date, "YYYY_MM_DD") & ".xls"
End If
'Close workbook, saving it, release WB object variable
myBk.Close True: Set myBk = Nothing
'Close Excel instance, release application object variable
myXl.Quit: Set myXl = Nothing
MsgBox "File has been saved to your" & vbCr & _
strPath & " directory."
End Function
'***
------------------
'How to Keep Your Databases from becoming Overwhelming!'
thread181-293590
joshua.peters@attws.com
------------------
I've already gone into my excel template that is being opened and tried to set the column format through there, but no good - the code just reformats for me.
I've been scanning the excel object library and it looks like there is something in the Range category I can use. But I'm having trouble putting my finger on it. Here is my code, please feel free to make suggestions.
'***
Function appndXLS(strPath As String, strFilename As String, strOpenFilename As String, _
strSHName As String, qrySQL As String)
'Create an Excel Instance
Set myXl = CreateObject("Excel.Application")
'Check to see if the template file exists:
If fbol_Check_File_Name(strPath, strOpenFilename, ".xls") = False Then
MsgBox "Template file missing." & Chr(13) & "Please place in the appropriate directory.", _
vbExclamation, "File missing:"
Exit Function
End If
'Set your Excel File to push the data too
Set myBk = myXl.Workbooks.Open(strPath & "\" & strOpenFilename & ".xls")
With myBk.Sheets(strSHName)
'Set your range to first available cell in Column A
'Stack your Sql in a String
Set db = CurrentDb()
Set qdf = db.CreateQueryDef("")
With qdf
.sql = db.QueryDefs(qrySQL).sql
Set rs = .OpenRecordset()
If rs.RecordCount = 0 Then
MsgBox "No records were found.", vbOKOnly
myBk.Close True: Set myBk = Nothing
myXl.Quit: Set myXl = Nothing
rs.Close
db.Close
Exit Function
End If
rs.MoveFirst
End With
If Not rs.EOF Then
rs.MoveLast: rs.MoveFirst
'Rezise Excel Target Range Cell Array to
'Accomodate Recordset Height/Width
.[a2].Resize(rs.RecordCount + 1, 3).CopyFromRecordset rs
'I think the correction needs to go right here[/color red]
' If SysName = "CASPR" Or SysName = "Canc_Def" Then
'.[a1].Resize(rs.RecordCount + 1, 3).CopyFromRecordset rs
' End If
End If
rs.Close
Set rs = Nothing
db.Close
End With
'Check to see if file already exists.
If fbol_Check_File_Name(strPath, strFilename & Format(Date, "YYYY_MM_DD"), ".xls") = True Then
myBk.Save
Else
myBk.SaveAs FileName:=strPath & "\" & strFilename & Format(Date, "YYYY_MM_DD") & ".xls"
End If
'Close workbook, saving it, release WB object variable
myBk.Close True: Set myBk = Nothing
'Close Excel instance, release application object variable
myXl.Quit: Set myXl = Nothing
MsgBox "File has been saved to your" & vbCr & _
strPath & " directory."
End Function
'***
------------------
'How to Keep Your Databases from becoming Overwhelming!'
thread181-293590
joshua.peters@attws.com
------------------