Valkie (valkyri) wrote in ms_access,
Valkie
valkyri
ms_access

A strange thing...

I have a dozen or so procedures that take Access data and save it to excel. They worked before, and they have stopped working. This in itself leads me to believe that it's a system issue. I still need a way to fix it though, or an explanation of why this is happening all of a sudden.

What happens is that the command button is pressed which kicks off the event, the process runs as it is supposed to, it produces the "Save as" dialog box with defaults, the user can choose to save it where they want, choose to change the name if they want, then when they press "Save" everything appears fine - except no saved file ever results. The file is created new each time from data, I am not opening an existing sheet. It will not save though. Bizzare.



Function ExcelExport()
Dim xlobject As Object, xlsheet As Object
Dim cn As ADODB.Connection
Dim rs As New ADODB.Recordset
Dim sSql As String, sSqlIO As String

On Error GoTo ErrControl

Set cn = CurrentProject.Connection

sSql = {The SQL statement}

rs.Open sSql, cn, adOpenDynamic, adLockOptimistic
rs.MoveFirst

Set xlobject = CreateObject("excel.sheet.8")
Set xlsheet = xlobject.Application.ActiveWorkbook.Sheets("sheet1")
With xlsheet

.Columns("B:B").ColumnWidth = 7
.Rows("1:1").Select
.Rows("1:1").RowHeight = 25
.Range("A1").Value = "Outstanding Purchases for " & rs("IO")

.Range("B3").Value = "UCN"
.Range("C3").Value = "Line ID"
.Range("D3").Value = "Description"
.Range("E3").Value = "GL"
.Range("F3").Value = "Fund"
.Range("G3").Value = "Amount"

End With
i = 4
tmpTotal = 0
Do While Not rs.EOF

With xlsheet

.Range("B" & i).Value = rs("UCN")
.Range("C" & i).Value = rs("Line_ID")
.Range("D" & i).Value = rs("Description")
.Range("E" & i).Value = rs("GL")
.Range("F" & i).Value = rs("Fund")
.Range("G" & i).Value = rs("Amount")
.Range("G" & i).NumberFormat = "$#,##0.##"

End With
i = i + 1
rs.MoveNext
Loop

xlsheet.Application.GetSaveAsFileName InitialFilename:="Q:\Documents\OustandingPurchasesIO.xls", FileFilter:="Microsoft Excel Files (*.xls), *.xls"
xlobject.Application.Quit
Set xlobject = Nothing

ErrEnd:
Exit Function

ErrControl:
ErrorLog
MsgBox Err.Description
Resume ErrEnd

End Function



Eternal thanks and all that... :-)
  • Post a new comment

    Error

    default userpic
  • 6 comments
I'm a little confused when you say that the procedure worked at one time, but does not work anymore. When I tried your code in a sample database on my machine I experienced the exact same error you are describing.

The GetSaveAsFileName method simply returns a string that identifies the path you want the file saved to. It does not, however, actually save a file. In fact, the Excel VBA Help entry for GetSaveAsFileName explicitly states,

"Displays the standard Save As dialog box and gets a file name from the user without actually saving any files."

So I added some code that included a SaveAs command, and it worked fine.

I have modified your code slightly, this should get it working: (my additions are in red):


Function ExcelExport()
Dim xlobject As Object, xlsheet As Object
Dim cn As ADODB.Connection
Dim rs As New ADODB.Recordset
Dim sSql As String, sSqlIO As String
Dim sFilename As String

On Error GoTo ErrControl

Set cn = CurrentProject.Connection

sSql = {The SQL statement}

rs.Open sSql, cn, adOpenDynamic, adLockOptimistic
rs.MoveFirst

Set xlobject = CreateObject("excel.sheet.8")
Set xlsheet = xlobject.Application.ActiveWorkbook.Sheets("sheet1")
With xlsheet

.Columns("B:B").ColumnWidth = 7
.Rows("1:1").Select
.Rows("1:1").RowHeight = 25
.Range("A1").Value = "Outstanding Purchases for " & rs("IO")

.Range("B3").Value = "UCN"
.Range("C3").Value = "Line ID"
.Range("D3").Value = "Description"
.Range("E3").Value = "GL"
.Range("F3").Value = "Fund"
.Range("G3").Value = "Amount"

End With
i = 4
tmpTotal = 0
Do While Not rs.EOF

With xlsheet

.Range("B" & i).Value = rs("UCN")
.Range("C" & i).Value = rs("Line_ID")
.Range("D" & i).Value = rs("Description")
.Range("E" & i).Value = rs("GL")
.Range("F" & i).Value = rs("Fund")
.Range("G" & i).Value = rs("Amount")
.Range("G" & i).NumberFormat = "$#,##0.##"

End With
i = i + 1
rs.MoveNext
Loop


sFilename = xlsheet.Application.GetSaveAsFileName (InitialFilename:="Q:\Documents\OustandingPurchasesIO.xls", FileFilter:="Microsoft Excel Files (*.xls), *.xls")
xlobject.Application.ActiveWorkbook.SaveAs strFilename
xlobject.Application.Quit
Set xlobject = Nothing

ErrEnd:
Exit Function

ErrControl:
ErrorLog
MsgBox Err.Description
Resume ErrEnd

End Function

Yes, it worked, I didn't include the API code which is more than likely where my problem is, though why is still a mystery.

I made those changes and it still does not work, it does exactly the same thing.

I tried to include the API code but it is too long to fit in a comment, I can put it in a new post if you'd like to see it, though - none of the code has changed anywhere.
Without seeing the rest of the code it is hard to say for certain, but another thing I can think of off the top of my head is this may be a permissions issue. Is it possible you no longer have write access to the drive and directory you are trying to save to?

No, the drive I'm trying to save to is the local one - to the desktop or to a personal folder. It brings up a save dialog box and allows the user to choose wherever they want to save it - it just defaults to their documents folder on the server. Permissions would cause an error to be thrown, and there is no error, it just doesn't save anything.

It's incredibly weird. It worked beautifully before. I think it is a systems issue, I'm very constrained here and I don't actually work in IT (they wouldn't do anything for this department, so they hired me to do it) - it's a horrible place to have to develop anything. Bureacracy, blah. Anyhow, if you have any more ideas, let me know, and thanks for trying.