VBA Automation Error when Formating Spread Sheet.

[jase2006]

Hi all, please help. I keep getting a "Automation error: Server threw an exception" error each time it reached the '.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="(blank),2,3,4,5" ' line of code. (See full code below)

The code was working fine previously when I was using :
'DoCmd.OutputTo acOutputQuery, strQuery, acFormatXLS, strSkillsFile, False' to generate the spreadsheet file. But now I have introduce a new function 'Private Sub SaveAsExcel(filename As String)' to generate the spreadsheet, the problem also appears.

Any help will be appreciated


************************************************

Private Function ExportSkills()


Dim strQuery As String
Dim intColumns As Integer
Dim strColumns As String, strRows As String


On Error GoTo Err_ExportSkills




strQuery = "SkillExportQuery"
strSkillsFile = "U:\Jason16nov06.xls"
strColumns = "G:G"
ExportSkills = True



' Not in use right now
'DoCmd.OutputTo acOutputQuery, strQuery, acFormatXLS, strSkillsFile, False



' Protect the cells that should not be changed

' Lock cells in work book
strRows = Str(intRows + 2) & ":" & LTrim(Str(intRows + 102))
Set appExcel = CreateObject("Excel.Application")
With appExcel

.Visible = True 'False
.Workbooks.Open (strSkillsFile)
.Worksheets.Select
.Columns(strColumns).Select
.Selection.Locked = False
.Rows(strRows).Select
.Selection.Locked = False

.Rows("2:2").Select
.ActiveWindow.FreezePanes = True

.Columns("G:G").Select

With .Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="(blank),2,3,4,5"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = "Key"
.ErrorTitle = ""
.InputMessage = _
"(blank) No Experience" & Chr(10) & "2 Familiar" & Chr(10) & "3 Intermediate" & Chr(10) & "4 Experienced" & Chr(10) & "5 Expert (or Exam passed)"
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With

.Range("A1").Select
.ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
.DisplayAlerts = False ' Without asking permission
.ActiveWorkbook.SaveAs filename:=strSkillsFile, FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
.DisplayAlerts = True ' Turning it back on

.ActiveWorkbook.Save
.ActiveWorkbook.close
.Quit
End With
Set appExcel = Nothing

Exit_ExportSkills:
Exit Function

Err_ExportSkills:
If err.Number = 287 Then
Set mal = Nothing
Set otl = Nothing
txtProgress = "Export has been cancelled"
ExportSkills = False
Else
MsgBox err.Description

' MsgBox MessageText(err.Number)
End If
Resume Exit_ExportSkills

End Function




*******************************************
Private Sub SaveAsExcel()


'in the first row of each column.
'

Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet

'Field object
Dim fd As Field


'Cell count, the cells we can use
Dim CellCnt As Integer, cnt As Integer

Dim i As Integer

Dim myQuery As String
Dim keyID As String


Set xlApp = New Excel.Application
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets.Add

'user input for staff ID
keyID = "'" & Me.cmbStaff.Column(0) & "'"

myQuery = "SELECT Skill.ID, Skill.[Skill Category], Skill.[Skill Type], Vendor.[Vendor Name], Skill.[Skill Description]," & _
"IIf([Skill Type]='Exam/Certification','E',' ') AS Exam, [Skill Occurrence].[Skill Rating]" & _
"FROM Vendor RIGHT JOIN (([Resource-skills] LEFT JOIN [Skill Occurrence] ON ([Resource-skills].ID = [Skill Occurrence].[Skill Id]) " & _
"AND ([Resource-skills].RES_ID = [Skill Occurrence].[Res Id])) LEFT JOIN Skill ON [Resource-skills].ID = Skill.ID) ON Vendor.[Vendor Id] = Skill.[Vendor Id]" & _
"WHERE ((([Resource-skills].RES_ID)=" & keyID & "))" & _
"ORDER BY Skill.[Skill Category], Skill.[Skill Type], Vendor.[Vendor Name], Skill.[Skill Description];"

'Get the field names


Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(myQuery, dbOpenSnapshot)

CellCnt = 1
For Each fd In rst.Fields
' cnt = 0
' For CellCnt = cnt To rst.Fields.Count

Select Case fd.Type
'Select Case rst.Fields(CellCnt).Type
Case dbBinary, dbGUID, dbLongBinary, dbVarBinary
' This type of data can't export to excel
Case Else
xlSheet.Cells(1, CellCnt).Value = fd.Name
' xlSheet.Cells(1, CellCnt).Interior.ColorIndex = 33
xlSheet.Cells(1, CellCnt).Font.Bold = True
xlSheet.Cells(1, CellCnt).BorderAround xlContinuous
CellCnt = CellCnt + 1
End Select
Next


'Rewind the rescordset
rst.MoveFirst
i = 2
Do While Not rst.EOF()
CellCnt = 1
For Each fd In rst.Fields
Select Case fd.Type
Case dbBinary, dbGUID, dbLongBinary, dbVarBinary
' This type of data can't export to excel
Case Else
xlSheet.Cells(i, CellCnt).Value = _
rst.Fields(fd.Name).Value
CellCnt = CellCnt + 1
End Select
Next
rst.MoveNext
i = i + 1
Loop

'Fit all columns
CellCnt = 1
For Each fd In rst.Fields

Select Case fd.Type
Case dbBinary, dbGUID, dbLongBinary, _
dbVarBinary
' This type of data can't export to excel
Case Else
xlSheet.Columns(CellCnt).AutoFit
CellCnt = CellCnt + 1
End Select
Next

rst.close
dbs.close
' Save the Worksheet.

xlApp.DisplayAlerts = False

xlApp.ActiveWorkbook.SaveAs "U:\Jason16nov06.xls"
xlApp.DisplayAlerts = True

' Close the Workbook
xlApp.ActiveWorkbook.Save
xlApp.ActiveWorkbook.close
' Close Microsoft Excel with the Quit method.
xlApp.Quit

' Release the objects.
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing

End Sub

 

[Remou]

Have you a reference to Excel Object Library?

 

[idbr]

Looks like a referencing problem, does changing to:

Set xlApp = New Excel.Application

xlApp.Workbooks.Add
xlApp.ActiveWorkbook.Worksheets.Add

Set xlBook = xlApp.ActiveWorkbook

Set xlSheet = xlBook.ActiveWorkbook.ActiveSheet

Help at all?

Iain

 

[jase2006]

Yes, I have done than already. Any more idea? Thanks

 

[jase2006]

Sorry, that was to Remou

 

[jase2006]

Hi idbr, I've tried your suggestion. However, I get this "object doesn't support this property or method" error when I tried to set the:

Set xlBook = xlApp.ActiveWorkbook
and
Set xlSheet = xlBook.ActiveWorkbook.ActiveSheet

 

[idbr]

My error, apologies:

Set xlSheet = xlBook.ActiveSheet

Iain

 

[jase2006]

That's Ok. However, I still get the same problem with the "Automation error: Server threw an exception"

 

[idbr]

I can't replicate the error running the Selection.Validation sequence in isolation.

In the past I've had problems running nested With... End With blocks with Excel Automation, does terminating the first With appExcel block and running the With Selection.Validation as With appExcel.Selection.Validation help?

 

[jase2006]

Removed all the nested with.... End and use the full form. But still gives the same error. Anything else might worth a try? Thanks again

 

[idbr]

Is there data in the spreadsheet that doesn't meet the validation rules that causes it? Although this doesn't throw an error manually, so probably not the case.

Also, have you tried removing the optional arguments to see if they are the cause? If so, see what arguments are acceptable.

I'm trying to think of errors that can't be handled and passed back by Excel, with any other error you'll get a 'object defined... ' type error, so this has to be soemthing more subtle.

It may be that when you output from your recordset, something to do with the output datatypes may be the issue that triggers this error when you try to apply the validation? Try coercing the data types on output and see what happens. You could also try changing the datatypes in the spreadsheet itself.

Sorry I can't be more help, heading off for the weekend now but would be interested in what happens next.

Iain