Excel 2003, intermitent VBA error -
i have script inserts vba controls sheet, script started clicking on button. script runs without error , runs 100% correctly.
sometimes script stops before completion , "microsoft visual basic" error displayed:
run-time error '-2147319764 (8002802c)': method 'name' of object 'imdccheckbox' failed
all buttons excel 'end' , disabled.
i have no idea why erroring , runs ok.
the script looking through 43 rows inserting on each row 2 checkboxes, 1 label , combo box, controls named according type index appended name starting @ 1 , running 43.
here routine, sorry bit large:
public sub btngetinfo_click() if false errhandler: resume next end if dim objcolumns collection dim objtables collection dim objrs adodb.recordset set objcolumns = new collection set objtables = new collection set objrs = objexecutesql() 'removed checkboxes , labels if removeoletypesoftype() = false exit sub end if if not objrs nothing dim objitem field, varexisting variant dim blnpresent boolean while not objrs.eof doevents objrs 'iterate through fields each objitem in .fields 'is field name present in columns collection? blnpresent = false each varexisting in objcolumns if varexisting = objitem.name 'yes, flag present , stop search blnpresent = true exit end if next if blnpresent = false 'look table name dim objsubitem property dim strtable string strtable = "" each objsubitem in objitem.properties if objsubitem.name = table_name strtable = objsubitem.value exit end if next if len(strtable) > 0 dim blnfound boolean, stralias string dim vartable variant blnfound = false each vartable in objtables if strtable = vartable blnfound = true end if next if blnfound = false objtables.add strtable end if 'get alias table stralias = trim(strbuildtableref(strtable)) if len(stralias) = 0 stralias = "t" & objtables.count end if 'no, add new item collection objcolumns.add stralias & "." & objitem.name end if end if next 'we have columns, exit loop exit end loop 'close recordset objrs.close set objrs = nothing 'clear columns range dim objcolumnheadings range, objdbsheet worksheet dim lngrow long, objcell range, objole object 'ms controls dim objmsordercbo msforms.combobox dim obmsfieldcbx msforms.checkbox dim obmsordercbx msforms.checkbox dim objmslbl msforms.label dim intitemidx integer set objdbsheet = getdbsheet() set objcolumnheadings = objdbsheet.range(column_headings) objcolumnheadings.clearcontents 'populate sheet lngrow = 0 each varexisting in objcolumns 'get cell/row insert controls @ set objcell = objcolumnheadings.cells(lngrow + 1, 1) 'insert checkbox allow selection of 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 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 intitemidx = 1 objcolumns.count objmsordercbo.additem cstr(intitemidx) next objmsordercbo.listindex = lngrow 'insert checkbox 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 necessary due bug in way activex objects 'are registered starttimer 'get tables database dim objtablenames range, objtableprefixes range dim conn adodb.connection, cmd 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 cmd .activeconnection = conn .commandtext = "show tables" set objrs = .execute() 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 recordset objrs.close set objrs = nothing end end if end sub
fixed, wrote function execute sql statements , trapped error.
public function objexecutesql(optional byval strsql string = "") adodb.recordset 'start off initialising function return in case of failure set objexecutesql = nothing on error goto errhandler if false errhandler: debug.print "error in objexecutesql:" & err.description resume next end if if len(strsql) = "" strsql = trim(sheet1.txtsql.text) end if if len(strsql) = 0 msgbox "no sql statement execute", vbcritical exit function end if 'connect database dim conn adodb.connection set conn = opendb() 'create command perform query dim cmd adodb.command set cmd = new adodb.command cmd .activeconnection = conn .commandtext = strsql set objexecutesql = .execute() end end function
Comments
Post a Comment