Excel VBA Object required error when populating ComboBox - excel

I am getting the following error --
Run-time error '424' : Object required
Here is the code where I am getting the error message. The line where the error appears has been highlighted with ****
Sub LoadDropdown_Click()
Dim cnt As ADODB.Connection
Dim rst As ADODB.Recordset
Dim stDB As String, stSQL As String
Dim xlCalc As XlCalculation
Dim vaData As Variant
Dim k As Long
Set cnt = New ADODB.Connection
cnt.connectionString = Module1.GetConnectionString
stSQL = "EXEC dbo.GetData"
With cnt
.CursorLocation = adUseClient 'Necesary for creating disconnected recordset.
.Open stConn 'Open connection.
'Instantiate the Recordsetobject and execute the SQL-state.
Set rst = .Execute(stSQL)
End With
With rst
Set .ActiveConnection = Nothing 'Disconnect the recordset.
k = .Fields.Count
'Populate the array with the whole recordset.
vaData = .GetRows
End With
'Close the connection.
cnt.Close
'Manipulate the Listbox's properties and show the form.
With ComboBox21
.Clear ' **** the error comes at this line since ComboBox21 is empty ******
.BoundColumn = k
.List = Application.Transpose(vaData)
.ListIndex = -1
End With
Dim i As Integer
'Release objects from memory.
Set rst = Nothing
Set cnt = Nothing
End Sub
These are the things I have veified --
The ComboBox actually exists in Sheet1, called Priorities. See this screenshot showing that Sheet1 contains a Combobox called ComboBox21
The below function, LoadDropdown_Click is present in Sheet1. See this screenshot for details
This code works when running from certain machines. It used to work on my machine earlier, but now I am getting this error suddenly without having made any changes to the code or the environment.
I tried changing ComboBox21 to Sheet1.ComboBox21, but I got a compile error - Method or Data member not found.
It will be great if someone can help!

Please change your code:
With ComboBox21
.Clear ' **** the error comes at this line since ComboBox21 is empty ******
.BoundColumn = k
.List = Application.Transpose(vaData)
.ListIndex = -1
End With
'With the below:
Sheet1.ComboBox21.Clear
With Sheet1.ComboBox21
.BoundColumn = k
.List = Application.Transpose(vaData)
.ListIndex = -1
End With

Basically, you just add "On Error Resume Next" to avoid those annoying error messages popping up and then add "Err.Clear" to clear the error flag just in case.
Private Sub ComboBox1_Change()
On Error Resume Next
ComboBox5.List = Sheets("Data").Range("B1:B6").Value
Err.Clear
End Sub
NOTE: This is probably not the right way of doing things but at least it works on my end

Related

Populate Combobox with font names

I want to populate a combobox on a userform with available fonts on a pc, when the userform is initialized. i have written a code for it, but it just gives me an error:
Run-time error '-2147467259 (80004005)':
Method 'ListCount' of Object '_CommanBarComboBox' failed
Ive tried to modify the i = 1 to i = 0, but it doesnt helped me.
Private Sub UserForm_Initialize()
Image3.Visible = False
Image6.Visible = False
Dim FontList
Dim i
CreatePapers.ComboBox1.Clear
Set FontList = Application.CommandBars("Formatting").FindControl(ID:=1728)
For i = 1 To FontList.ListCount
CreatePapers.ComboBox1.AddItem FontList.List(i + 1)
Next i
End Sub
EDIT:
I modified the code, the error is gone, however, nothing is filled into the combobox.
Dim FontList As CommandBarControl
Dim i As Long
Dim Tempbar As CommandBar
CreatePapers.ComboBox1.Clear
On Error Resume Next
Set FontList = Application.CommandBars("Formatting").FindControl(ID:=1728)
' If Font control is missing, create a temp CommandBar
If FontList Is Nothing Then
Set Tempbar = Application.CommandBars.Add
Set FontList = Tempbar.Controls.Add(ID:=1728)
End If
For i = 1 To FontList.ListCount
Debug.Print FontList.List(i)
CreatePapers.ComboBox1.AddItem FontList.List(i)
Next i
Me.ComboBox1.ListIndex = 0
' Delete temp CommandBar if it exists
On Error Resume Next
Tempbar.Delete
EDIT 2:
Added 2 lines of code into the above modified code as mentioned by T.M. , but it still doesnt fill up the combobox, its just empty.
EDIT 3:
Changed some line in the code, but still it doesnt retrieves the fonts. Also the FontList is empty, even after the If FontList Is Nothing Then part, where it creates the temporary control bar.
You could shorten initializing into a more readable form by assigning a complete array to the combobox'es .List property:
Private Sub UserForm_Initialize()
Me.ComboBox1.List = GetFontList() ' << calling `GetFontList()
End Sub
The array itself is the result of the following function:
Option Explicit
Function GetFontList() As Variant
Dim FontList As CommandBarControl ' << declare type
On Error Resume Next ' provide for missing font control
Set FontList = Application.CommandBars("Formatting").FindControl(id:=1728)
On Error GoTo 0
'If Font control is missing, create it on a temporary CommandBar
If FontList Is Nothing Then
Dim tmpBar As CommandBar
Set tmpBar = Application.CommandBars.Add
Set FontList = tmpBar.Controls.Add(id:=1728)
End If
Dim tmpList: ReDim tmpList(1 To FontList.ListCount, 1 To 1)
'Assign fonts to array
Dim i As Long
For i = 1 To UBound(tmpList)
tmpList(i, 1) = FontList.List(i)
Next i
'Delete temporary CommandBar eventually
On Error Resume Next
tmpBar.Delete
'return 2-dim 1-based font array as function result
GetFontList = tmpList
End Function
Further hints
The CommandBarControl items can be addressed by a one-based index via
FontList.List(i)
*) The combobox'es 2-dimensional .List property is zero-based, but accepts also assignment of a one-based array (as returned by above function).
You are accessing a FontList item that does not exist. Your for-loop is fine. But, you need to change the line inside to:
CreatePapers.ComboBox1.AddItem FontList.List(i)
Accessing index + 1 is reaching outside of the bounds of the list, this is why it's crashing.
Your code should look like:
Private Sub UserForm_Initialize()
Image3.Visible = False
Image6.Visible = False
Dim FontList
Dim i
CreatePapers.ComboBox1.Clear
Set FontList = Application.CommandBars("Formatting").FindControl(ID:=1728)
For i = 1 To FontList.ListCount
CreatePapers.ComboBox1.AddItem FontList.List(i)
Next i
End Sub

Bringing data from sql server - existing data not brought

I have a function that brings data from sql server. The function is tested and is used in many macros. Now I am trying to use it and for some reason it doesn't work, although I am testing the query and it does have data
I opened a macro where the function works and try to test it from there, but still doesn't work.
I am calling to function GetDataFromDatabase (see below) from the following code:
Sub testing()
Dim query As String
Dim ImportedData As Range
query = GetQuery
Debug.Print query
Call GetDataFromDatabase(query, Range("AB1"), False)
End Sub
Note, that when debug.pring prints the query, I take it, run in in the database and I get the data, so the GetQuery function works.
The function includes the following line:
On Error GoTo CloseConnection
And indeed, at some point it goes to closeConnection (line marked below in the function). How do I know what is the error?
Sub GetDataFromDatabase(query As String, cellToCpyData As Range, WithHeaders As Boolean)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim LocalDBCon As ADODB.Connection
Dim SqlTableDatasSet As ADODB.Recordset
Dim SqlDataSetFields As ADODB.Field
Dim Ctr As Long
Dim RDBConString As String
RDBConString = "connection string (the right one)"' This here is ok, I deleted the actual sting
Set LocalDBCon = New ADODB.Connection
Set SqlTableDatasSet = New ADODB.Recordset
LocalDBCon.ConnectionString = RDBConString
On Error GoTo CloseConnection
LocalDBCon.Open
With SqlTableDatasSet
.ActiveConnection = LocalDBCon
.ActiveConnection.CommandTimeout = 0
.Source = query
.LockType = adLockReadOnly
.CursorType = adOpenForwardOnly
.Open
End With
'Adding the sql table headers
If WithHeaders Then
Ctr = 0
For Each SqlDataSetFields In SqlTableDatasSet.Fields
cellToCpyData.Offset(0, Ctr) = SqlDataSetFields.Name
Ctr = Ctr + 1
Next SqlDataSetFields
Set cellToCpyData = cellToCpyData.Offset(1, 0)
End If
---->>cellToCpyData.CopyFromRecordset SqlTableDatasSet 'When not working, jumps from here to CloseConnection<<------------------------------------
SqlTableDatasSet.Close
Wrapup:
On Error Resume Next
LocalDBCon.Close
Exit Sub
CloseConnection:
On Error Resume Next
LocalDBCon.Close
End Sub
You need to add this line of code between "CloseConnection:" and "On Error Resume Next"
Debug.Print Err.Number & " - " & Err.Description
This will print to the immediate window what error is causing the problem. That will give a starting point to go from.

How do I resolve Run-time Error 438 inside a CATIA macro?

I am writing a macro in CATIA v5 using VBA. The program is suppose to take points from a geometric set and transfer them into an excel file. I have successfully gotten the excel document open, a header created, but then I receive "Run-time error '438': Object doesn't support this property or method.
I have tried searching around and it seems like the section of code is trying to interact with something outside of its domain, but I cannot figure out how. Below is a sample of my code. The line that contains "***" to the left is the line that is being pointed out in the debugger.
Dim xls As Object
Dim wkbks As Object
Dim wkbk As Object
Dim wksheets As Object
Dim sheet As Object
Dim fs, f, f1, fc, s
Dim coords(2) As Integer
Dim PartDoc
Sub CATMain()
CATIA.ActiveDocument.Selection.Search "CATGmoSearch.Point,all"
'Function Calls
AppStart
CATIAtoXLS
'wksheet.Application.ActiveWorkbook.SaveAs (ExcelFolder & Left(CATIA.ActiveDocument.Name,Len(CATIA.ActiveDocument.Name)-8)&".xls")
'wksheet.Application.ActiveWorkbook.Close
End Sub
Private Sub AppStart()
Err.Clear
On Error Resume Next
Set xls = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Err.Clear
Set xls = CreateObject("Excel.Application")
End If
xls.Application.Visible = True
Set wkbks = xls.Application.Workbooks
Set wkbk = wkbks.Add
Set wksheets = wkbk.Worksheets(1)
Set sheet = wkbk.Sheets(1)
sheet.Cells(1, "A") = "X-Cord"
sheet.Cells(1, "B") = "Y-Cord"
sheet.Cells(1, "C") = "Z-Cord"
End Sub
Private Sub CATIAtoXLS()
For i = 1 To CATIA.ActiveDocument.Selection.Count
Set Selection = CATIA.ActiveDocument.Selection ***
Set Element = Selection.Item(i)
'Transfer data to xls
Point.GetCoordinates (coords)
sheet.Cells(i + 1, "A") = coords(0)
sheet.Cells(i + 1, "B") = coords(1)
sheet.Cells(i + 1, "C") = coords(2)
Next i
End Sub
Your first issue is that in any method in CATIA VBA which passes an array as an argument, must be called on a object declared variant (explicitly or by default).
So you it should look like this:
Dim px as Variant
Set px = CATIA.ActiveDocument.Selection.Item(i).Value
Call Point.GetCoordinates(coords)
The second problem is that in VBA if you use a subroutine with parentheses, you must use the Call keyword:
Call Point.GetCoordinates (coords)
Otherwise, you can skip the parentheses and the keyword:
Point.GetCoordinates coords

Running Excel Macro through Access VBA Runtime Error -2147417851

I created code that will copy the RecordSet to Excel and I want a macro in the Excel file to run. The code works perfectly until it hits the code to run the macro. I must not be calling the application correctly but can't figure it out!
Private Sub Command233_Click()
Dim objXLS As Object
Dim wks As Object
Dim rsc As Recordset
Dim idx As Long
Set rsc = Me.RecordsetClone
If Me.RecordsetClone.RecordCount = 0 Then
MsgBox ("No Records To Export")
Else
rsc.MoveLast
rsc.MoveFirst
Set objXLS = CreateObject("Excel.Application")
objXLS.Workbooks.Open FileName:="C:\Comps Macro.xlsm", ReadOnly:=True
Set wks = objXLS.Worksheets(1)
For idx = 0 To rsc.Fields.Count - 1
wks.Cells(1, idx + 1).Value = rsc.Fields(idx).Name
Next
wks.Range(wks.Cells(1, 1), wks.Cells(1, rsc.Fields.Count)).Font.Bold = True
wks.Range("A2").CopyFromRecordset rsc, rsc.RecordCount, rsc.Fields.Count
objXLS.Visible = True
objXLS.Run ("Format")
End If
Set objXLS = Nothing
End Sub
The runtime error I am receiving is:
Run-Time Error '-2147417851 (80010105)':
Method 'Run' of object '_Application' failed
You have to reference the Sub or Function correctly.
Your Sub named Format is defined at Workbook- or Sheet- level?
If defined in a Sheet module (for example Sheet1):
objXLS.Run ("Sheet1.Format")
If at Workbook level:
objXLS.Run ("ThisWorkbook.Format")
Hope this helps

Excel VBA: Late binding reference

I'm trying to write some code for an add-in in excel, which grabs some data from an SQL Server. The code itself is working flawlessly, but somehow something got corrupted.
It seems that the code will work fine a few times and then all of a sudden trigger an excel-crash. After a long time I've determined that it has something to do with the references, seeing as if upon crash I change the reference 'Microsoft ActiveX Data Objects 2.8 Library' to something else, and then back again, the add-in will work again.
Seeing as rebuilding the add-in doesn't work, I'm beginning to explore the option of late-binding. I just can't seem to understand how to do it.
Private Sub RetrieveToWorksheet(SQL As String, WriteTo As Range, Optional WriteColumnNames As Boolean = True)
If GetStatus = "True" Then
MsgBox ("Database is currently being updated. Please try again later.")
Exit Sub
End If
Application.ScreenUpdating = False
Dim Connection As ADODB.Connection
Dim RecordSet As ADODB.RecordSet
Dim Field As ADODB.Field
Dim RowOffset As Long
Dim ColumnOffset As Long
On Error GoTo Finalize
Err.Clear
Set Connection = New ADODB.Connection
Connection.ConnectionTimeout = 300
Connection.CommandTimeout = 300
Connection.ConnectionString = "Provider=sqloledb;Data Source=vdd1xl0001;Initial Catalog=SRDK;User Id=SRDK_user;Password=password;Connect Timeout=300"
Connection.Mode = adModeShareDenyNone
Connection.Open
Set RecordSet = New ADODB.RecordSet
RecordSet.CursorLocation = adUseServer
RecordSet.Open SQL, Connection, ADODB.CursorTypeEnum.adOpenForwardOnly
RowOffset = 0
ColumnOffset = 0
If WriteColumnNames = True Then
For Each Field In RecordSet.Fields
WriteTo.Cells(1, 1).Offset(RowOffset, ColumnOffset).Value = Field.Name
ColumnOffset = ColumnOffset + 1
Next
ColumnOffset = 0
RowOffset = 1
End If
WriteTo.Cells(1, 1).Offset(RowOffset, ColumnOffset).CopyFromRecordset RecordSet
Finalize:
If Not RecordSet Is Nothing Then
If Not RecordSet.State = ADODB.ObjectStateEnum.adStateClosed Then RecordSet.Close
Set RecordSet = Nothing
End If
If Not Connection Is Nothing Then
If Not Connection.State = ADODB.ObjectStateEnum.adStateClosed Then Connection.Close
Set Connection = Nothing
End If
If Err.Number <> 0 Then Err.Raise Err.Number, Err.Source, Err.Description
End Sub
Long story short: I just want the add-in to automatically add the reference 'Microsoft ActiveX Data Objects 2.8 Library'.
All help is greatly appreciated!
In answer to your question about late binding, this involves replacing the line of code
Dim Connection As ADODB.Connection
with
Dim Connection As object
and replacing
Set Connection = New ADODB.Connection
with
Set Connection = GetObject(, "ADODB.Connection")
And similarly for the other objects from that library.
Now, I am not sure if this will fix the actual issue that you are having. It sounds like there is a bug in the ActiveX library and you are hitting it, although nothing you are doing seems particularly esoteric.

Resources