Excel 2003，intermitent VBA錯誤

Question

我有一個腳本，將VBA控件插入到工作表中，該腳本通過單擊按鈕啓動。有時腳本運行沒有錯誤，並且正確運行100％。

有時候劇本完成之前停止，顯示一個 「Microsoft Visual Basic中」 錯誤：

運行時錯誤 '-2147319764（8002802c）：' 對象 'IMdcCheckBox' 的 方法 '名稱' 失敗

所有按鈕excel'結束'和幫助被禁用。

我不知道爲什麼它是錯誤的，正如我說的有時它完全確定。

該腳本通過尋找43行每行插入2個複選框，1個標籤和組合框，所有的控制都根據與從1開始並運行多達43

附加到名稱的索引類型命名

這裏是常規的，對不起它有點大：

Public Sub btnGetInfo_Click() 
     If False Then 
    errHandler: 
      Resume Next 
     End If   
     Dim objColumns As Collection 
     Dim objTables As Collection 
     Dim objRS As ADODB.Recordset 
     Set objColumns = New Collection 
     Set objTables = New Collection 
     Set objRS = objExecuteSQL() 
    'Removed all checkboxes and labels 
     If removeOLEtypesOfType() = False Then 
      Exit Sub 
     End If 
     If Not objRS Is Nothing Then 
      Dim objItem As Field, varExisting As Variant 
      Dim blnPresent As Boolean 
      Do While Not objRS.EOF 
       DoEvents 

       With objRS 
    'Iterate through the fields 
        For Each objItem In .Fields 
    'Is this field name already present in the columns collection? 
         blnPresent = False 
         For Each varExisting In objColumns 
          If varExisting = objItem.Name Then 
    'Yes, flag it is present and stop search 
           blnPresent = True 
           Exit For 
          End If 
         Next 
         If blnPresent = False Then 
    'Look for the table name 
          Dim objSubItem As Property 
          Dim strTable As String 
          strTable = "" 
          For Each objSubItem In objItem.Properties 
           If objSubItem.Name = TABLE_NAME Then 
            strTable = objSubItem.Value 
            Exit For 
           End If 
          Next 
          If Len(strTable) > 0 Then 
           Dim blnFound As Boolean, strAlias As String 
           Dim varTable As Variant 
           blnFound = False 
           For Each varTable In objTables 
            If strTable = varTable Then 
             blnFound = True 
            End If 
           Next 
           If blnFound = False Then 
            objTables.Add strTable 
           End If 
    'Get the alias for this table 
           strAlias = Trim(strBuildTableRef(strTable)) 

           If Len(strAlias) = 0 Then 
            strAlias = "t" & objTables.Count 
           End If 
    'No, add the new item to the collection 
           objColumns.Add strAlias & "." & objItem.Name 
          End If 
         End If 
        Next 
    'We have the columns, exit loop 
        Exit Do 
       End With 
      Loop 
    'Close the recordset 
      objRS.Close 
      Set objRS = Nothing 
    'Clear the columns range 
      Dim objColumnHeadings As Range, objDBsheet As Worksheet 
      Dim lngRow As Long, objCell As Range, objOLE As Object 
    'MS controls 
      Dim objMSorderCbo As MSForms.ComboBox 
      Dim obMSfieldCbx As MSForms.checkbox 
      Dim obMSorderCbx As MSForms.checkbox 
      Dim objMSlbl As MSForms.Label 
      Dim intItemIdx As Integer 

      Set objDBsheet = getDBsheet() 
      Set objColumnHeadings = objDBsheet.Range(COLUMN_HEADINGS) 
      objColumnHeadings.ClearContents 
    'Populate sheet 
      lngRow = 0 
      For Each varExisting In objColumns 
    'Get the cell/row we will insert the controls at 
       Set objCell = objColumnHeadings.Cells(lngRow + 1, 1) 
    'Insert a checkbox to allow selection of the column 
       Set obMSfieldCbx = ActiveSheet.OLEObjects.Add(_ 
            ClassType:="Forms.CheckBox.1" _ 
           , Left:=objCell.Left + CHECKBOX_FIELD_XPOS _ 
           , Top:=objCell.Top _ 
           , Height:=CONTROL_HEIGHT _ 
           , Width:=CHECKBOX_FIELD_WIDTH).Object 
       obMSfieldCbx.Name = CHECKBOX_FIELD_PREFIX & (lngRow + 1) 
       obMSfieldCbx.Caption = varExisting 
       obMSfieldCbx.Font.Name = "Arial" 
       obMSfieldCbx.Font.Size = 8 
       obMSfieldCbx.BackColor = &HFFFFFF 
       obMSfieldCbx.BackStyle = fmBackStyleOpaque 
       obMSfieldCbx.ForeColor = &H0 
    'Insert a label 
       Set objMSlbl = ActiveSheet.OLEObjects.Add(_ 
            ClassType:="Forms.Label.1" _ 
           , Left:=objCell.Left + CHECKBOX_FIELD_WIDTH _ 
           , Top:=objCell.Top + 3 _ 
           , Height:=CONTROL_HEIGHT).Object 
       objMSlbl.Name = LABEL_PREFIX & (lngRow + 1) 
       objMSlbl.Caption = "Order By:" 
       objMSlbl.Font.Name = "Arial" 
       objMSlbl.Font.Size = 8 
       objMSlbl.TextAlign = fmTextAlignRight 
       objMSlbl.BackColor = &HFFFFFF 
       objMSlbl.BackStyle = fmBackStyleOpaque 
       objMSlbl.ForeColor = &H0 
       objMSlbl.AutoSize = True 
    'Insert combobox 
       Set objMSorderCbo = ActiveSheet.OLEObjects.Add(_ 
           ClassType:="Forms.ComboBox.1" _ 
           , Left:=objCell.Left + CBOX_OFFSET _ 
           , Top:=objCell.Top _ 
           , Width:=45 _ 
           , Height:=CONTROL_HEIGHT).Object 
       objMSorderCbo.Name = CBOX_PREFIX & (lngRow + 1) 
       objMSorderCbo.Font.Name = "Arial" 
       objMSorderCbo.Font.Size = 8 
       objMSorderCbo.ListStyle = fmListStylePlain 
       objMSorderCbo.MatchEntry = fmMatchEntryNone 
       objMSorderCbo.TextAlign = fmTextAlignLeft 
       objMSorderCbo.BackColor = &HFFFFFF 
       objMSorderCbo.ForeColor = &H0 
       objMSorderCbo.SelectionMargin = False 
       objMSorderCbo.Style = fmStyleDropDownList 
       For intItemIdx = 1 To objColumns.Count 
        objMSorderCbo.AddItem CStr(intItemIdx) 
       Next 
       objMSorderCbo.ListIndex = lngRow 
    'Insert a checkbox to allow selection of asc/desc 
       Set obMSorderCbx = ActiveSheet.OLEObjects.Add(_ 
            ClassType:="Forms.CheckBox.1" _ 
           , Left:=objCell.Left + CHECKBOX_ORDER_XPOS _ 
           , Top:=objCell.Top _ 
           , Height:=16 _ 
           , Width:=16).Object 
       obMSorderCbx.Name = CHECKBOX_ORDER_PREFIX & (lngRow + 1) 
       obMSorderCbx.Alignment = fmAlignmentLeft 
       obMSorderCbx.AutoSize = True 
       obMSorderCbx.Caption = "Desc" 
       obMSorderCbx.Font.Name = "Arial" 
       obMSorderCbx.Font.Size = 8 
       obMSorderCbx.BackColor = &HFFFFFF 
       obMSorderCbx.BackStyle = fmBackStyleOpaque 
       obMSorderCbx.ForeColor = &H0 
       obMSorderCbx.TextAlign = fmTextAlignRight 
       lngRow = lngRow + 1 
      Next 
    'Start timer this is necessary due to bug in the way activeX objects 
    'are registered 
      startTimer 
    'Get the tables from the database 
      Dim objTableNames As Range, objTablePrefixes As Range 
      Dim conn As ADODB.Connection, cmd As ADODB.Command 
      Set cmd = New ADODB.Command 
      Set conn = openDB() 
      Set objTableNames = objDBsheet.Range(TABLE_NAMES) 
      Set objTablePrefixes = objDBsheet.Range(TABLE_PREFIXES) 
      objTableNames.ClearContents 
      objTablePrefixes.ClearContents 
      lngRow = 1 
      With cmd 
       .ActiveConnection = conn 
       .CommandText = "SHOW TABLES" 
       Set objRS = .Execute() 

       Do While Not objRS.EOF 
        Set objCell = objTableNames.Cells(lngRow, 1) 
        objCell.Value = objRS.Fields(0).Value 
        Set objCell = objTablePrefixes.Cells(lngRow, 1) 
        objCell.Value = "t" & lngRow 
    'Next record 
        objRS.MoveNext 
        lngRow = lngRow + 1 
       Loop 
    'Close the recordset 
       objRS.Close 
       Set objRS = Nothing 
      End With 
     End If 
    End Sub 

Answer 1

固定的，我寫了一個函數來執行SQL語句，這被困的錯誤。

Public Function objExecuteSQL(Optional ByVal strSQL As String = "") As ADODB.Recordset 
    'Start off by initialising function return in case of failure 
     Set objExecuteSQL = Nothing 

     On Error GoTo errHandler 

     If False Then 
    errHandler: 
      Debug.Print "Error in objExecuteSQL:" & Err.Description 
      Resume Next 
     End If 

     If Len(strSQL) = "" Then 
      strSQL = Trim(Sheet1.txtSQL.Text) 
     End If 
     If Len(strSQL) = 0 Then 
      MsgBox "No SQL statement to execute", vbCritical 
      Exit Function 
     End If 
    'Connect to database 
     Dim conn As ADODB.Connection 
     Set conn = openDB() 
    'Create command to perform query 
     Dim cmd As ADODB.Command 
     Set cmd = New ADODB.Command 

     With cmd 
      .ActiveConnection = conn 
      .CommandText = strSQL 
      Set objExecuteSQL = .Execute() 
     End With 
    End Function