Please Help me in following problem:
this code work in VB but doesn't work in VBA:
also I add in beginning a combobox with index 0 to form1
For i = 1 To 5
Load Combo1(i)
Combo1(i).Visible = True
Combo1(i).Left = Combo1(i - 1).Left + Combo1(0).Width
Next i
I will have this code in VBA.
thank you
Are you thinking of something on the lines of:
Sub AddControls()
Dim frm As Form
Dim iTop, iWidth, iHeight, iLeft
DoCmd.OpenForm "FormNameHere", acDesign
Set frm = Forms!FormNameHere
iTop = 100
iWidth = 1500
iHeight = 300
iLeft = 100
For i = 1 To 5
Set ctl = CreateControl(frm.Name, acComboBox, , , , iLeft, iTop, iWidth, iHeight)
ctl.Visible = True
ctl.Name = "Combo1" & i
iLeft = ctl.Left + ctl.Width
Next i
DoCmd.Restore
End Sub
I think the index property is not available in VBA; I am not sure how it works in VB though.
Related
I have a userform with dynamic checkboxes(programmed)
Below is my code
Dim Rows As Integer
Dim toppart As Integer
Dim Opt As Variant
Dim x As Integer
On Error Resume Next
toppart = 20
UpdateRow = Application.WorksheetFunction.CountA(ActiveSheet.Range("C3:CU3"))
For x = 3 To UpdateRow
Set Opt = Te.Controls.Add("Forms.CheckBox.1", "CheckBox" & x, True)
Opt.Caption = ActiveSheet.Cells(x, "C").Value
Opt.Width = 70
Opt.Height = 18
Opt.Left = 18
Opt.Top = toppart
toppart = toppart + 20
Next
I know if the checkboxes were set via the controls my code will look something like this:
If (CheckBox1.Value = False) Or (CheckBox2.Value = False) Then
MsgBox "You must select alteast 2 checkboxes", vbCritical
But when the checkboxes are dynamically created I can't think of a efficient way to do it. Please any suggestions or Help is very much appreciated, thanks.
Untested, but you can probably loop the controls on your form, check if each is a checkbox, if it is, query it's .Value and tally the total number of checkboxes which are "checked. If that number is LTE 1, then you raise your warning/MsgBox:
Dim checked as Long
Dim ctrl as Object
For Each ctrl in Me.Controls
If TypeName(ctrl) = "CheckBox" Then
If ctrl.Value = True Then
checked = checked + 1
End If
End If
Next
If checked <= 1 Then
MsgBox "You must select alteast 2 checkboxes", vbCritical
Exit Sub
End If
I'm currently working on a project where I'll be selecting up to 5 items to compare to each other, with the results being displayed in up to a 5x5 dynamic grid. My objective is to have this grid be composed of command buttons such that the caption of each button is the percent similarity between the row and column items, and on clicking the button, the units that are common between the row and column items will be displayed in a message box.
I more or less know how to generate the actual array of buttons. However, everything I've read suggests that I need to create a class to handle the button clicks, since I don't feel like making 20 subroutines that all have the same code in them. I have not been able to get this class to work properly, and I could use some tips. Here's what I have so far.
In a class module named DynButton:
Public Withevents CBevents as MSForms.CommandButton
Private Sub CBevents_Click()
DisplayOverlappedUnits 'Sub that will display the units that are the same
'between items i and j- may use Application.Caller
End Sub
And in the userform itself:
Private Sub Userform_Initialize()
Dim NumItems as integer
Dim ComparisonArray() as DynButton
Dim ctlButton as MSForms.CommandButton
'QuestionList() is a public type that stores various attributes of the
'items I'm comparing.
'This code determines how many items were selected for comparison
'and resets the item array accordingly.
NumItems=0
For i=1 to 5
If QuestionList(i).Length>0 Then
NumItems=Numitems+1
QuestionList(NumItems)=QuestionList(i)
End If
Next
Redim ComparisonArray(1 to NumItems, 1 to NumItems)
For i = 1 to NumItems
For j=1 to NumItems
Set ctlButton=Me.Controls.Add("Forms.CommandButton.1", Cstr(i) & Cstr(j) & cb)
With ctlButton
.Height= CB_HEIGHT 'These are public constants defined elsewhere.
.Width= CB_WIDTH
.Top= TOP_OFFSET + (i * (CB_HEIGHT+ V_PADDING))
If i = j Then .visible = False
.Caption= CalculateOverlap(i,j) 'Runs a sub that calculates the overlap between items i and j
End With
Set ComparisonArray(i,j).CBevents = ctlButton
Next
Next
End Sub
Currently, I get a "Object with or Block variable not set" when I hit the Set ComparisonArray line, and I'm stymied. Am I just missing something in the class module? Thanks in advance for the help.
Edited to add: I tried to model the class code in part off of this article, but again I haven't got it to work yet. http://www.siddharthrout.com/index.php/2018/01/15/vba-control-arrays/
Private Sub Userform_Initialize()
Dim NumItems as integer
Dim ComparisonArray() as DynButton '<<<< should be a Global variable
As soon as Userform_Initialize completes, ComparisonArray() will go out of scope and no longer exist: you need to make that a Global variable in your form so it will be around to handle any events.
Your code seems correct and interesting. The only (bug) I could see is:
Redim ComparisonArray(1 to NumItems, 1 to NumItems)
...
Set ComparisonArray(i,j).CBevents = ctlButton
The problem is that your array holds null references. You have not created your DynButton objects yet. You must explicitly creat the objects in your array.
Redim ComparisonArray(1 to NumItems, 1 to NumItems)
For i = 1 to NumItems
For j = 1 to NumItems
Set ComparisonArray(i,j) = new DynButton
Next
Next
...
Set ComparisonArray(i,j).CBevents = ctlButton
Also, declare the array ComparisonArray as a member object of the form, not as a local variable in Form_Initialize.
Only copy paste
Option Private Module
Option Explicit
Private Const i_total_channels As Integer = 100
Sub createArrayOfbuttons()
Application.ScreenUpdating = False
f_create_buttons 5, 5, 30, 5, True
End Sub
Sub clearArrayOfButtos()
Application.ScreenUpdating = False
f_clear_array_of_buttons
End Sub
Private Function f_create_buttons(Optional posLeft As Integer = 0, Optional posTop As Integer = 0, _
Optional sizeSquare As Integer = 20, Optional distBetween As Integer, Optional buttonColor As Boolean = False)
'create customized buttons to channel choice.
Dim i_ch_amount_x As Integer
Dim i_ch_amount_y As Integer
Dim i_size_X 'size of square button
Dim i_size_Y 'size of square button
Dim i_stp_X As Integer 'step in X
Dim i_stp_Y As Integer 'step in Y
Dim i_dist_bte_buttons As Integer 'distance between buttons, in X and Y
Dim i_pos_ini_X As Integer 'initial position
Dim i_pos_ini_Y As Integer
Dim it_x As Integer 'iterator
Dim it_y As Integer 'iterator
Dim amount As Integer 'channel acumulator
Dim FO_color As Integer 'index from 1 to 12 to change background color of button
f_clear_array_of_buttons
i_pos_ini_X = posLeft
i_pos_ini_Y = posTop
'create dimensions of square
i_size_X = sizeSquare
i_size_Y = i_size_X 'to create a square Y need same size of X
'distance between squares
i_dist_bte_buttons = i_size_X + distBetween 'to shift distance change laste value of expression
i_stp_X = i_pos_ini_X
i_stp_Y = i_pos_ini_Y
i_ch_amount_x = Int(Sqr(i_total_channels)) 'total channels in switch (i_ch_amount_y * i_ch_amount_x)
i_ch_amount_y = i_ch_amount_x
amount = 1
FO_color = 1
For it_y = 1 To i_ch_amount_x
For it_x = 1 To i_ch_amount_y
f_create_button amount, i_stp_X, i_stp_Y, CSng(i_size_X), CSng(i_size_Y), FO_color
i_stp_X = i_stp_X + i_dist_bte_buttons
amount = amount + 1
If buttonColor Then
FO_color = FO_color + 1
End If
If FO_color > 12 Then 'return FO to 1
FO_color = 1
End If
Next it_x
i_stp_X = i_pos_ini_X
i_stp_Y = i_stp_Y + i_dist_bte_buttons
Next it_y
amount = 0
i_ch_amount_x = 0
i_ch_amount_y = 0
i_size_X = 0
i_size_Y = 0
i_stp_X = 0
i_stp_Y = 0
i_pos_ini_X = 0
i_pos_ini_Y = 0
i_dist_bte_buttons = 0
FO_color = 0
End Function
Private Function f_create_button(index As Integer, posLeft As Integer, posRight As Integer, _
Box_width As Single, Box_height As Single, Optional FO As Integer)
ActiveSheet.Shapes.AddShape(msoShapeRectangle, posLeft, posRight, Box_width, Box_height). _
Select
With Selection
.Name = "ch_" & index
.Text = index
.Font.Name = "Arial"
.Font.Bold = True
If FO = 9 Then
.Font.Color = vbWhite
Else
.Font.ColorIndex = xlAutomatic
End If
.Font.Size = 10
.Interior.Color = fiber_color(FO)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End Function
Public Function fiber_color(Optional FO As Integer = 1) As Long
'use with a index in FO from 1 to 12
Select Case FO
Case 1
fiber_color = 65280 'green
Case 2
fiber_color = 65535 'yellow
Case 3
fiber_color = 16777215 'white
Case 4
fiber_color = 16711680 'blue
Case 5
fiber_color = 255 'red
Case 6
fiber_color = 16711823 'violt
Case 7
fiber_color = 19350 'brown
Case 8
fiber_color = 13353215 'pink
Case 9
fiber_color = 0 'black
Case 10
fiber_color = 16711680 'cinza
Case 11
fiber_color = 32767 'orange
Case 12
fiber_color = 16776960 'aqua
Case Else
fiber_color = 65280 'verde
End Select
End Function
Private Function f_clear_array_of_buttons()
Dim i_ch_amount_x As Integer
Dim it As Integer
i_ch_amount_x = i_total_channels
On Error GoTo sair
If ActiveSheet.Shapes.Count <> 0 Then
For it = 1 To i_ch_amount_x
ActiveSheet.Shapes("ch_" & it).Delete
Next it
End If
sair:
i_ch_amount_x = 0
it = 0
End Function
I am writing a VBA application in Excel. I have a Userform that dynamically builds itself based upon the data contained in one of the worksheets.
All of the code that creates the various comboboxes, textboxes and labels is working.
I created a class module to trap OnChange events for the Comboboxes, and again this works as expected.
Now I have a need to trap OnChange events for some of the textboxes, so I created a new class module modelled on that for the comboboxes to trap the events.
Public WithEvents tbx As MSForms.TextBox
Sub SetTextBox(ctl As MSForms.TextBox)
Set tbx = ctl
End Sub
Public Sub tbx_Change()
Dim LblName As String
MsgBox "You clicked on " & tbx.Name, vbOKOnly
End Sub
The message box is just so that I can confirm it works before I go further.
The problem I'm getting is in the UserForm code module:
Dim TBox As TextBox
Dim tbx As c_TextBoxes
'[...]
Set TBox = lbl
Set tbx = New c_TextBoxes
tbx.SetTextBox lbl
pTextBoxes.Add tbx
This throws up a type mismatch error at Set TBox=lbl. It's the exact same code that works fine for the ComboBox, just with the variables given approriate names. I've stared at this for 2 hours.
Anyone got any ideas? Thanks for any pointers.
Edit - Here's the full userform module that I'm having trouble with:
Private Sub AddLines(FrameName As String, PageName As String)
Dim Counter As Integer, Column As Integer
Dim obj As Object
Dim CBox As ComboBox
Dim cbx As c_ComboBox
Dim TBox As TextBox
Dim tbx As c_TextBoxes
Dim lbl As Control
Set obj = Me.MultiPage1.Pages(PageName).Controls(FrameName)
If pComboBoxes Is Nothing Then Set pComboBoxes = New Collection
If pTextBoxes Is Nothing Then Set pTextBoxes = New Collection
For Counter = LBound(Vehicles) To UBound(Vehicles)
For Column = 1 To 8
Select Case Column
Case 1
Set lbl = obj.Add("Forms.Label.1", "LblMachine" & FrameName & Counter, True)
Case 2
Set lbl = obj.Add("Forms.Label.1", "LblFleetNo" & FrameName & Counter, True)
Case 3
Set lbl = obj.Add("Forms.Label.1", "LblRate" & FrameName & Counter, True)
Case 4
Set lbl = obj.Add("Forms.Label.1", "LblUnit" & FrameName & Counter, True)
Case 5
Set lbl = obj.Add("Forms.ComboBox.1", "CBDriver" & FrameName & Counter, True)
Case 6
Set lbl = obj.Add("Forms.Label.1", "LblDriverRate" & FrameName & Counter, True)
Case 7
Set lbltbx = obj.Add("Forms.TextBox.1", "TBBookHours" & FrameName & Counter, True)
Case 8
Set lbl = obj.Add("Forms.Label.1", "LblCost" & FrameName & Counter, True)
End Select
With lbl
Select Case Column
Case 1
.Left = 1
.Width = 60
.Top = 10 + (Counter) * 20
.Caption = Vehicles(Counter).VType
Case 2
.Left = 65
.Width = 40
.Top = 10 + (Counter) * 20
.Caption = Vehicles(Counter).VFleetNo
Case 3
.Left = 119
.Width = 50
.Top = 10 + (Counter) * 20
.Caption = Vehicles(Counter).VRate
Case 4
.Left = 163
.Width = 30
.Top = 10 + (Counter) * 20
.Caption = Vehicles(Counter).VUnit
Case 5
.Left = 197
.Width = 130
.Top = 10 + (Counter) * 20
Set CBox = lbl 'WORKS OK
Call CBDriver_Fill(Counter, CBox)
Set cbx = New c_ComboBox
cbx.SetCombobox CBox
pComboBoxes.Add cbx
Case 6
.Left = 331
.Width = 30
.Top = 10 + (Counter) * 20
Case 7
.Left = 365
.Width = 30
.Top = 10 + (Counter) * 20
Set TBox = lbl 'Results in Type Mismatch
Set tbx = New c_TextBoxes
tbx.SetTextBox TBox
pTextBoxes.Add tbx
Case 8
.Left = 400
.Width = 30
.Top = 10 + (Counter) * 20
End Select
End With
Next
Next
obj.ScrollHeight = (Counter * 20) + 20
obj.ScrollBars = 2
End Sub
And here's the c_Combobox class module:
Public WithEvents cbx As MSForms.ComboBox
Sub SetCombobox(ctl As MSForms.ComboBox)
Set cbx = ctl
End Sub
Public Sub cbx_Change()
Dim LblName As String
Dim LblDriverRate As Control
Dim i As Integer
'MsgBox "You clicked on " & cbx.Name, vbOKOnly
LblName = "LblDriverRate" & Right(cbx.Name, Len(cbx.Name) - 8)
'MsgBox "This is " & LblName, vbOKOnly
'Set obj = Me.MultiPage1.Pages(PageName).Controls(FrameName)
Set LblDriverRate = UFBookMachines.Controls(LblName)
For i = LBound(Drivers) To UBound(Drivers)
If Drivers(i).Name = cbx.Value Then LblDriverRate.Caption = Drivers(i).Rate
Next
End Sub
And finally, here's the c_TextBoxes class module:
Public WithEvents tbx As MSForms.TextBox
Sub SetTextBox(ctl As MSForms.TextBox)
Set tbx = ctl
End Sub
Public Sub tbx_Change()
Dim LblName As String
'Does nothing useful yet, message box for testing
MsgBox "You clicked on " & tbx.Name, vbOKOnly
End Sub
After some quick testing, I am able to reproduce your error if I declare TBox as TextBox. I do not get an error if I declare TBox as MSForms.TextBox. I would recommend declaring all your TextBox variables with the MSForms qualifier.
Test code is situated similar to yours. I have a MultiPage with a Frame where I am adding a Control.
Private Sub CommandButton1_Click()
Dim obj As Object
Set obj = Me.MultiPage1.Pages(0).Controls("Frame1")
Dim lbl As Control
Set lbl = obj.Add("Forms.TextBox.1", "txt", True)
If TypeOf lbl Is TextBox Then
Debug.Print "textbox found1" 'does not execute
End If
If TypeOf lbl Is MSForms.TextBox Then
Debug.Print "textbox found2"
Dim txt1 As MSForms.TextBox
Set txt1 = lbl 'no error
End If
If TypeOf lbl Is MSForms.TextBox Then
Debug.Print "textbox found3"
Dim txt As TextBox
Set txt = lbl 'throws an error
End If
End Sub
I am not sure why the qualifier is needed for TextBox and not ComboBox. As you can see above, a good test for this is the If TypeOf ... Is ... Then to test which objects are which types. I included the first block to show that lbl is not a "bare" TextBox, but, again, I have no idea why that is. Maybe there is another type of TextBox out there that overrides the default declaration?
I have TextBoxes on UserForm and in Excel File (unfortunately).
I can do the loop on those in UserForm, and it works perfectly:
Dim txt(1 To 20) As String
txt(3)=("txtCompany")
txt(4)=("txtDataSource")
....
For i = 1 To 20
If frmInfo.Controls(txt(i)).Value <>
Worksheets(SheetNameDataBaze).Cells(ERow, i).Value Then ....
However, there is a huge problem with controls placed on the worksheet.
I tried:
Worksheets(SheetNameDataBaze).Controls(txt(i)).Value
Worksheets(SheetNameDataBaze).TextBox(txt(i)).Value
Worksheets(SheetNameDataBaze).OLEObjects(txt(i)).Value
Worksheets(SheetNameDataBaze).Shapes(txt(i)).Value
Worksheets(SheetNameDataBaze).txt(i).Value
nothing worked.
How should I define it?
It would be much easier then preparing the if statement for each TextBox.
I'm assuming that your textboxes on the worksheet are ActiveX controls and not forms controls. If so, then does this work for you?
Sub ReferToTextboxes()
Dim txt As MSForms.TextBox
Dim o As OLEObject
For Each o In Sheet1.OLEObjects
If o.progID = "Forms.TextBox.1" Then
Set txt = o.Object
'now you can refer to txt and do what you need
Debug.Print txt.Text
End If
Next o
End Sub
I finally used:
Private Sub FunctionalProgramNew()
Dim bLoop As Double
Dim eLoop As Double
bLoop = 8
eLoop = 13
Dim txt(8 To 13) As String
txt(8) = ("txtFuel_1")
txt(9) = ("txtFuel_2")
txt(10) = ("txtFuel_3")
txt(11) = ("txtProduct_1")
txt(12) = ("txtProduct_2")
txt(13) = ("txtProduct_3")
Dim txtBox(8 To 13) As MSForms.TextBox
For i = bLoop To eLoop
Set txtBox(i) = Worksheets(SheetNameModel).OLEObjects(txt(i)).Object
Next i
For i = bLoop To eLoop
If txtBox(i).Value <> CStr(Cells(ActiveCell.row, ActiveCell.Column + i - 2).Value) Then
MsgBox ("Error code: " & txt(i))
End If
Next i
End Sub
In excel, I have an userForm with checkBox dynamically created from a list
on initialize, I call a sub to affect a click event to my checkbox.
I have then a classmodule call MyEvents in wich I declare click event for check box.
Here is the class module MyEvents :
Option Explicit
Public WithEvents chkGroup As MSForms.CheckBox
Private Sub chkGroup_Click()
Debug.Print "chkGroup_Click -----> " & chkGroup.Caption
End Sub
Here is the sub on userForm :
Private Sub initCheckBox(chanelList As Variant)
Dim myEvent As MyEvents
Dim chkBox As Collection
Dim n As Long, j As Integer, i As Integer
n = Application.CountA(chanelList)
Dim checkBoxChanel() As MSForms.CheckBox
ReDim checkBoxChanel(n) As MSForms.CheckBox
n = 1
j = 1
i = 1
Set chkBox = New Collection
chkBoxNum = 0
For Each chanel In chanelList
Set myEvent = New MyEvents
Set checkBoxChanel(n) = Frame1.Controls.Add("Forms.CheckBox.1", "chkBoxChanel" & n)
Set myEvent.chkGroup = Frame1.Controls("chkBoxChanel" & n)
chkBox.Add myEvent
With checkBoxChanel(n)
.Top = j
.Left = i
.Caption = chanel
.AutoSize = True
.Value = True
.Enabled = False
End With
n = n + 1
i = i + 80
If n Mod 3 = 0 Then
j = j + 20
i = 1
End If
Next
End Sub
Can someone explain me why clickevent is diffused on initialising. Is it the normal behavior ?
okay, I've found the trick. Setting check box value to true is like clicking on check box ! to avoid this, I just have to affect event after setting value to true. Thanks to all for you comment and answers