CopyFromRecordset上的自动化错误

Question

在上面写着"sh.Range("A2"(.CopyFromRecordset rs2"的行我在许多计算机中只有一台出现了自动化错误(我不知道有多少台，但至少有10+台(该查询只是一个基本的参数化查询，数据源在SQL server中，我在最后包含了它。

Private Sub export2()
If Not BasicInclude.DebugMode Then On Error GoTo Error_Handler Else On Error GoTo 0
Dim app As Object
Dim w As Object
Dim sh As Object
Dim iCols As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim c As Long
Dim d As Long
Dim e As Boolean
Dim s(4) As String
Dim v As Variant
Const xlCenter = -4108
Dim q As Variant
Dim qu As Long
Dim r As Variant
Dim t As Variant
Dim out() As Variant
Dim TidList As Variant
Dim rs() As ADODB.Recordset
Dim count As Long
Dim v2 As Variant
Dim counter As Long
Dim mem() As Variant
Dim DescGroup As Long
Dim ubrs As Long
Dim temp As New Collection
Dim TestItem As Variant
Dim f As ADODB.Field
Dim p As Object
Dim qry As QueryDef
Dim rs2 As DAO.Recordset
Set app = CreateObject("Excel.Application")
app.ScreenUpdating = False
app.Visible = False
'app.ScreenUpdating = True
'app.Visible = True
Set w = app.Workbooks.Add()

截断了此部分，因为它不是固有的

'Start'Resistance'Tester'Export'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set qry = dbLocal.QueryDefs("qryResistanceData")
qry.Parameters(0).Value = s(0)
qry.Parameters(1).Value = s(1)
qry.Parameters(2).Value = s(2)
qry.Parameters(3).Value = s(3)
qry.Parameters(4).Value = s(4)
Set rs2 = qry.OpenRecordset(dbOpenSnapshot)
On Error GoTo 0
With rs2
If .RecordCount <> 0 Then
Set sh = w.Sheets(1)
sh.Name = TestItem(0) & " " & TestItem(6) & " " & TestItem(5)
'Build our Header
For iCols = 0 To rs2.Fields.count - 1
sh.Cells(1, iCols + 1).numberformat = "@"
sh.Cells(1, iCols + 1).Value = rs2.Fields(iCols).Name
Next
With sh.Range(sh.Cells(1, 1), sh.Cells(1, rs2.Fields.count))
.Font.Bold = True
.Font.ColorIndex = 2
.Interior.ColorIndex = 1
.HorizontalAlignment = xlCenter
End With
sh.Range(sh.Cells(2, 1), sh.Cells(rs2.RecordCount + 1, 3)).numberformat = "@"
sh.Range(sh.Cells(2, 4), sh.Cells(rs2.RecordCount + 1, rs2.Fields.count)).numberformat = "0.0000"
'Copy the data from our query into Excel
sh.Range("A2").CopyFromRecordset rs2
sh.Range("A1").Select
'Return to the top of the page
sh.Range(sh.Cells(1, 1), sh.Cells(rs2.RecordCount, rs2.Fields.count)).Columns.AutoFit
'Resize our Columns based on the headings
app.activewindow.splitcolumn = 0
app.activewindow.splitrow = 1
app.activewindow.freezepanes = True
w.Sheets.Add
End If
End With

还有更多与问题无关的代码

For Each sh In w.Sheets
If sh.Name Like "Sheet*" And w.Sheets.count > 1 Then
w.Sheets(sh.Name).Delete
End If
Next
If counter = temp.count Then
w.Close False
app.Quit
MsgBox "No Data Found."
Else
app.ScreenUpdating = True
app.Visible = True
End If
Else
MsgBox "Please choose a part and test."
End If
Error_Exit:
Set app = Nothing
Exit Sub
Error_Handler:
If Not app Is Nothing Then
If Not w Is Nothing Then
w.Close False
End If
app.Quit
End If
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: " & Err.Source & vbCrLf & _
"Error Description: " & Err.Description _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Exit
End Sub

阻力查询

PARAMETERS tn Text ( 255 ), sns Long, sne Long, ds DateTime, de DateTime;
SELECT
PartListTruncated.Truncated             AS PartNumber
, dbo_EPS_EPSResistanceTester_Meas.PartSN AS SerialNumber
, PartListTruncated.TestType
, dbo_EPS_EPSResistanceTester_Meas.ResistanceTestDate AS TestDate
, dbo_EPS_EPSResistanceTester_Meas.Good
, dbo_EPS_EPSResistanceTester_Meas.Resistance
FROM
PartListTruncated
INNER JOIN
dbo_EPS_EPSResistanceTester_Meas
ON
PartListTruncated.Part_Number = dbo_EPS_EPSResistanceTester_Meas.PartNumber
WHERE
(
(
(
dbo_EPS_EPSResistanceTester_Meas.PartSN
)
>=[sns]
And
(
dbo_EPS_EPSResistanceTester_Meas.PartSN
)
<=[sne]
)
AND
(
(
dbo_EPS_EPSResistanceTester_Meas.ResistanceTestDate
)
>=[ds]
And
(
dbo_EPS_EPSResistanceTester_Meas.ResistanceTestDate
)
<=[de]
)
AND
(
(
dbo_EPS_EPSResistanceTester_Meas.PartNumber
)
=[tn]
)
)
;

Answer 1

我从未弄清楚它崩溃的原因，但将记录集类型从DAO记录集更改为ADODB记录集是有效的。

添加

Dim f1 As DAO.Field
Dim rs3 As DAO.Recordset

更改

Dim rs2 As ADODB.Recordset

然后我改变了我对唱片集的看法。

Set qry = dbLocal.QueryDefs("qryResistanceData")
qry.Parameters(0).Value = s(0)
qry.Parameters(1).Value = s(1)
qry.Parameters(2).Value = s(2)
qry.Parameters(3).Value = s(3)
qry.Parameters(4).Value = s(4)
Set rs3 = qry.OpenRecordset(dbOpenSnapshot)
If rs3.RecordCount > 0 Then
Set rs2 = New ADODB.Recordset
rs2.Fields.Append "PartNumber", adVarChar, 255, adFldKeyColumn
rs2.Fields.Append "SerialNumber", adInteger, , adFldKeyColumn
rs2.Fields.Append "TestType", adVarChar, 255
rs2.Fields.Append "TestDate", adDate
rs2.Fields.Append "Good", adVarChar, 255
rs2.Fields.Append "Resistance", adDouble
rs2.Open
rs3.MoveFirst
While Not rs3.EOF
rs2.AddNew
For Each f1 In rs3.Fields
rs2.Fields(f1.Name).Value = f1.Value
Next
rs2.Update
rs3.MoveNext
Wend
On Error GoTo 0
With rs2
If .RecordCount > 0 Then
Set sh = w.Sheets(1)
sh.Name = TestItem(0) & " " & TestItem(6) & " " & TestItem(5)
'Build our Header
For iCols = 0 To rs2.Fields.count - 1
sh.Cells(1, iCols + 1).numberformat = "@"
sh.Cells(1, iCols + 1).Value = rs2.Fields(iCols).Name
Next
With sh.Range(sh.Cells(1, 1), sh.Cells(1, rs2.Fields.count))
.Font.Bold = True
.Font.ColorIndex = 2
.Interior.ColorIndex = 1
.HorizontalAlignment = xlCenter
End With
sh.Range(sh.Cells(2, 1), sh.Cells(rs2.RecordCount + 1, 3)).numberformat = "@"
sh.Range(sh.Cells(2, 4), sh.Cells(rs2.RecordCount + 1, rs2.Fields.count)).numberformat = "0.0000"
'Copy the data from our query into Excel
sh.Range("A2").CopyFromRecordset rs2
sh.Range("A1").Select
'Return to the top of the page
sh.Range(sh.Cells(1, 1), sh.Cells(rs2.RecordCount, rs2.Fields.count)).Columns.AutoFit
'Resize our Columns based on the headings
app.activewindow.splitcolumn = 0
app.activewindow.splitrow = 1
app.activewindow.freezepanes = True
w.Sheets.Add
End If
End With
End If