I’d be glad to get some help! I’ve been searching the whole net but I’m stuck!
I’ve been programming VBA for a while but I’m still struggling to understand this language!
I want to create a VBA UserForm in MS Project 2007 VBA.
A few data are dynamic and so I need to add a few text fields during runtime.
I put some code together to add these and it works quite fine.
My problem is to add events to these text fields.
My example is the txtPath text field.
I create it with this code:
Set NewTextBox = Me.InfoMultiPage(page).Controls.Add("Forms.textbox.1")
With NewTextBox
.name = "txtPath"
.value = "Test"
.top = m2w_style("top") + (m2w_style("height") * 1)
.Left = m2w_style("left") + m2w_style("lblWidth") + m2w_style("margin")
.Width = m2w_style("txtWidth")
.height = m2w_style("height")
.font.Size = m2w_style("fontsize")
.font.name = m2w_style("font")
End With
And I want a reaction if the value of txtPath has changed.
Here the code:
Private Sub txtPath_Change() ' Event doesn't shoot
readProjectsFromConfig (Me.value)
End Sub
All websites I’ve browsed and searched show that it should work this way, but the event just doesn’t shoot.
I found out that the dynamic created text field are not displayed at the same place in the tree of the “local window” like the manually created text boxes.
So I tried this to at least get the value of the text field and it works.
Private Sub btnPath_Click()
'txtPath.value = "Hello World!" ' Doesn't work. Dynamicly created text field seems not to exist but is visible in UserForm
'Controls.Item("txtPath").value = "Hello World!" ' This works!
Controls.Item("txtPath").value = GetDirectory("Pick the folder") ' Pick a folder and write it in the text field txtPath
End Sub
Here’s the full code for testing:
' Reference to Library
' Microsoft XML, v5.0 need to be activated.
' Go to menu: Tools->References
' Select Microsoft Scripting Runtime
Public m2w_config As Dictionary
Public m2w_style As Dictionary
Sub m2wVariables()
' Set global Variables for configuration in a kind of hash.
Set m2w_config = New Dictionary
Set m2w_style = New Dictionary
'Styles for teh UserForm
m2w_style("font") = "Arial"
m2w_style("fontsize") = 10
m2w_style("top") = 6
m2w_style("left") = 6
m2w_style("height") = 20
m2w_style("btnHeight") = 8
m2w_style("width") = 40
m2w_style("lblWidth") = 40
m2w_style("h1Width") = 400
m2w_style("txtWidth") = 180
m2w_style("btnWidth") = 72
m2w_style("margin") = 6
m2w_config("XMLDateFormat") = "YYYY-MM-DD"
m2w_config("XMLConfigFileName") = "config.xml" ' should not be changeable
m2w_config("AppPath") = ""
m2w_config("Headline") = "" ' Headline in Website
m2w_config("UpdateHref") = ""
m2w_config("SubFolder") = "" ' Is it used?
m2w_config("default_subfolder") = "" ' Is it used?
End Sub
Private Sub UserForm_Activate()
Dim LabelArr As Variant
Dim ProbNameArr As Variant
Dim TempForm As Object
Dim NewButton As MSForms.CommandButton
Dim NewLabel As MSForms.Label
Dim NewTextBox As MSForms.TextBox
Dim e As Variant
Dim x As Integer
Dim page As String
'Dim Line As Integer
'Dim MyScript(4) As String
m2wVariables
' Setup userform
'~~~~~~~~~~~~~~~~
'This is to stop screen flashing while creating form
Application.VBE.MainWindow.Visible = False
' Setup tab Website
'===================
page = "Website"
Set NewLabel = Me.InfoMultiPage(page).Controls.Add("Forms.label.1")
With NewLabel
.name = "lblHeadlinePath"
.Caption = "This is the local path where the website shall be stored."
.top = m2w_style("top") + (m2w_style("height") * 0)
.Left = m2w_style("left")
.Width = m2w_style("h1Width")
.height = m2w_style("height")
.font.Size = m2w_style("fontsize")
.font.name = m2w_style("font")
End With
Set NewLabel = Me.InfoMultiPage(page).Controls.Add("Forms.label.1")
With NewLabel
.name = "lblPath"
.Caption = "Path:"
.top = m2w_style("top") + (m2w_style("height") * 1)
.Left = m2w_style("left")
.Width = m2w_style("lblWidth")
.height = m2w_style("height")
.font.Size = m2w_style("fontsize")
.font.name = m2w_style("font")
End With
Set NewTextBox = Me.InfoMultiPage(page).Controls.Add("Forms.textbox.1")
With NewTextBox
.name = "txtPath"
.value = "Test"
.top = m2w_style("top") + (m2w_style("height") * 1)
.Left = m2w_style("left") + m2w_style("lblWidth") + m2w_style("margin")
.Width = m2w_style("txtWidth")
.height = m2w_style("height")
.font.Size = m2w_style("fontsize")
.font.name = m2w_style("font")
End With
'Add event onClick
' This is completely weird, it actualy writes code.
' My intention is to add an event at runtime.
With ThisProject.VBProject.VBComponents("msp2web_SettingsForm").CodeModule
.insertlines .CountOfLines + 1, "Sub txtPath_Change()" & vbCrLf & "MsgBox Me.txtPath.Value" & vbCrLf & "End Sub"
Debug.Print Now & " This macro has code lines " & .CountOfLines
End With
Dim btnName As String
btnName = "btnPath"
'Set NewButton = Me.InfoMultiPage(page).Controls.Add("Forms.commandbutton.1", btnName) ' Add dynamicly - but I'm too stupid to add an event action to an dynamicly created button...
Set NewButton = Me.InfoMultiPage(page).Controls.Item(btnName)
With NewButton
.Caption = "Browse..."
.top = m2w_style("top") + (m2w_style("height") * 1)
.Left = m2w_style("left") + m2w_style("lblWidth") + m2w_style("margin") + m2w_style("txtWidth") + m2w_style("margin")
.Width = m2w_style("lblWidth")
.height = m2w_style("btnHeight")
.font.Size = m2w_style("fontsize")
.font.name = m2w_style("font")
.AutoSize = True
End With
' Setup Tab Project
'===================
page = "Project"
LabelArr = Array("Hallo", "Welt", "Model Year")
ProbNameArr = Array("Hallo", "Welt", "Model Year")
'Create 10 Labels just for testing - works fine
'For x = 0 To 9
x = 0
For Each e In LabelArr
Set NewLabel = Me.InfoMultiPage(page).Controls.Add("Forms.label.1")
With NewLabel
.name = "FieldLabel" & x + 1
.Caption = e
.top = m2w_style("top") + (m2w_style("height") * x)
.Left = m2w_style("left")
.Width = m2w_style("lblWidth")
.height = m2w_style("height")
.font.Size = m2w_style("fontsize")
.font.name = m2w_style("font")
End With
x = x + 1
Next
'Create 10 Text Boxes
'For x = 0 To 9
x = 0
For Each e In ProbNameArr
Set NewTextBox = Me.InfoMultiPage(page).Controls.Add("Forms.textbox.1")
With NewTextBox
.name = "MyTextBox" & x + 1
.top = m2w_style("top") + (m2w_style("height") * x)
.Left = m2w_style("left") + m2w_style("lblWidth") + m2w_style("margin")
.Width = m2w_style("lblWidth")
.height = m2w_style("height")
.font.Size = m2w_style("fontsize")
.font.name = m2w_style("font")
End With
x = x + 1
Next
End Sub
Private Sub btnPath_Click()
'txtPath.value = "Hello World!" ' Doesn't work. Dynamicly created text field seems not to exist but is visible in UserForm
'Controls.Item("txtPath").value = "Hello World!" ' This works!
Controls.Item("txtPath").value = GetDirectory("Pick the folder") ' Pick a folder and write it in the text field txtPath
End Sub
Private Sub txtPath_Change() ' Event doesn't shoot
readProjectsFromConfig (Me.value)
End Sub
Private Sub Refresh_Click()
readProjectsFromConfig (Controls.Item("txtPath").value)
End Sub
Cold anyone tell me how to create code based (during runtime) text boxes and command buttons and add events to them?
See Gary's answer to a similar question on SO. You can do it using a class and declaring it WithEvents.
You only get a shared event handler, but you can switch actions based on the calling control.
Tim
When I want to dynamically add controls on a userform I just go the route of adding the controls to a withevents class that I created similar to what is found here.
Related
What would the reason be for a VBA user form with an EventHandler class to throw a Run-time error '9': Subscript out of range
BUT
If I F8 and step into the UserForm code I can step right through the entire code without it crashing
Just for simplicity here is my event handler class LabelEventHandler
Private WithEvents Innerlabel As MSForms.Label
Private InnerRow As Integer
Private InnerSheet As Worksheet
Public Property Set Label(ByVal InLabel As MSForms.Label)
Set Innerlabel = InLabel
End Property
Public Property Let Row(ByVal InRow As Integer)
InnerRow = InRow
End Property
Public Property Set Sheet(ByVal InSheet As Worksheet)
Set InnerSheet = InSheet
End Property
Private Sub InnerLabel_Click()
Dim Frame As MSForms.Frame
Dim ChildLabel As MSForms.Label
Set Frame = Innerlabel.Parent
For Each ChildLabel In Frame.Controls
Select Case ChildLabel.Name
Case "FullName"
InnerSheet.Cells(InnerRow, 4).Value = ChildLabel.Caption
Case "Email"
InnerSheet.Cells(InnerRow, 5).Value = ChildLabel.Caption
Case "Phone"
InnerSheet.Cells(InnerRow, 6).Value = ChildLabel.Caption
End Select
Next
End Sub
and here is the UserForm code
Private Sheet As Worksheet
Private LabelClickArray() As New LabelEventHandler
Public Sub AddUser(FullName As String, Email As String, Phone As String)
Dim FullNameLabel As MSForms.Label
Dim EmailLabel As MSForms.Label
Dim PhoneLabel As MSForms.Label
Dim UserFrame As Frame
Dim Top
Top = FindBottomUserRow()
Set UserFrame = Me.Controls.Add("Forms.Frame.1")
With UserFrame
.Top = Top
.Left = 5
.Width = 660
.Height = 20
.Font.Name = "Verdana"
.Font.Size = 12
.Font.Weight = 400
.Caption = ""
.BorderStyle = fmBorderStyleNone
End With
Set FullNameLabel = UserFrame.Controls.Add("Forms.Label.1")
Set EmailLabel = UserFrame.Controls.Add("Forms.Label.1")
Set PhoneLabel = UserFrame.Controls.Add("Forms.Label.1")
With FullNameLabel
.Top = 0
.Left = 0
.Width = 200
.Height = 15
.Name = "FullName"
.Caption = FullName
End With
With EmailLabel
.Top = 0
.Left = 205
.Width = 300
.Height = 15
.Name = "Email"
.Caption = Email
End With
With PhoneLabel
.Top = 0
.Left = 510
.Width = 150
.Height = 15
.Name = "Phone"
.Caption = Phone
End With
ReDim Preserve LabelClickArray(UBound(LabelClickArray) + 3)
Set LabelClickArray(UBound(LabelClickArray) - 2).Label = FullNameLabel
Set LabelClickArray(UBound(LabelClickArray) - 1).Label = EmailLabel
Set LabelClickArray(UBound(LabelClickArray)).Label = PhoneLabel
Set LabelClickArray(UBound(LabelClickArray) - 2).Sheet = Sheet
Set LabelClickArray(UBound(LabelClickArray) - 1).Sheet = Sheet
Set LabelClickArray(UBound(LabelClickArray)).Sheet = Sheet
LabelClickArray(UBound(LabelClickArray) - 2).Row = ActiveCell.Row
LabelClickArray(UBound(LabelClickArray) - 1).Row = ActiveCell.Row
LabelClickArray(UBound(LabelClickArray)).Row = ActiveCell.Row
End Sub
Function FindBottomUserRow()
Dim Frame As Control
Dim Top
Top = 30
For Each Frame In Me.Controls
If (TypeName(Frame) = "Frame" And Frame.Top > Top) Then Top = Frame.Top
Next
If (Top > 30) Then Top = Top + 20
FindBottomUserRow = Top
End Function
Private Sub UserForm_Initialize()
Set Sheet = ActiveSheet
Me.AddUser "Ryan", "ryan#r.com", "2625"
Me.AddUser "Jeff", "j#k.com", "123-4567"
End Sub
The error
Your error happens at the ReDim Preserve command, because you never initialized the array. You cannot execute a UBound-function to a non-initialized array (if you try, you get the Runtime error 9). If you cannot be sure at runtime if your array in already initialized, change your code to:
If IsArrayAllocated(LabelClickArray) Then
ReDim Preserve LabelClickArray(UBound(LabelClickArray) + 3)
Else
ReDim LabelClickArray(3)
End If
The function IsArrayAllocated looks like this:
Function IsArrayAllocated(arr As Variant) As Boolean
On Error Resume Next
IsArrayAllocated = IsArray(arr) _
And Not IsError(LBound(arr, 1)) _
And LBound(arr, 1) <= UBound(arr, 1)
End Function
(Code copied from cpearson)
I would like to ask why .BorderStyle set to fmBorderStyleNone is not working when adding a new textbox during runtime? I want a textbox with no outline, but after the code runs there's still an outline.
Dim txtB1 As TextBox
Dim i
For i = 0 To 5
Set txtB1 = Frame12.Controls.Add("Forms.TextBox.1")
With txtB1
.Name = "chkDemo" & i
.TextAlign = fmTextAlignCenter
.Height = 20
.Width = 36
.Left = 444
.Top = 10 * i * 2
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone '---> this isn't working.
.Font.Name = "Calibre"
.Font.Size = 11
End With
Next i
The reason you still see an outline is because, by default, a text box is inserted with the special effect "sunken". You also need to change that property:
.SpecialEffect = fmSpecialEffectFlat
I have tried #DaveShaw code, for events on runtime for checkboxes, is click not an valid method for checkbox? It never get into the method checkBoxEvent_click
Dim CheckBoxArray() As New ClassEvents
for i=0 to 10
Set cTemp = MOM.Frame_MOM_MOM.Controls.Add("Forms.CheckBox.1")
With cTemp
.Top = HeaderOffset + RowOffset + i * 25 'your top pos
.Visible = True
.Left = 30 'your left pos
.Width = widthOfLabel 'your width
.Name = Replace(keyArrays(i, 1), " ", "_")
.Caption = keyArrays(i, 1) 'your caption ,
End With
ReDim Preserve CheckBoxArray(0 To i)
Set CheckBoxArray(i).checkBoxEvent = cTemp
next i
and my ClassEvents class looks like this:
Public WithEvents checkBoxEvent As MSForms.checkBox
Private Sub checkBoxEvent_click()
MsgBox "halla" 'checkBox.Caption
End Sub
you have to keep Dim CheckBoxArray() As New ClassEvents at the very top of your userfom code pane, thus outside any of its subs/functions
furthermore use Option Explicit statement too
it becomes
Option Explicit
Dim CheckBoxArray() As New ClassEvents '<--| keep this line at the very top of your userform code pane
Private Sub UserForm_Initialize()
Dim i As Long
Dim cTemp As MSForms.CheckBox '<-- with "Option Explicit" you have to declare all your variables
For i = 0 To 10
Set cTemp = MOM.Frame_MOM_MOM.Controls.Add("Forms.CheckBox.1")
With cTemp
.Top = HeaderOffset + RowOffset + i * 25 'your top pos
.Visible = True
.Left = 30 'your left pos
.Width = widthOfLabel 'your width
.Name = Replace(keyArrays(i, 1), " ", "_")
.Caption = keyArrays(i, 1) 'your caption ,
End With
ReDim Preserve CheckBoxArray(0 To i)
Set CheckBoxArray(i).checkBoxEvent = cTemp
Next i
End Sub
furthermore, since you already know the dimension of your array, Dim it at the beginning and don't ReDim it at every iteration:
Option Explicit
Dim CheckBoxArray(0 To 10) As New ClassEvents '<--| keep this line at the very top of your userform code pane
Private Sub UserForm_Initialize()
Dim i As Long
Dim cTemp As MSForms.CheckBox '<-- with "Option Explicit" you have to declare all your variables
For i = 0 To 10
Set cTemp = MOM.Frame_MOM_MOM.Controls.Add("Forms.CheckBox.1")
With cTemp
.Top = HeaderOffset + RowOffset + i * 25 'your top pos
.Visible = True
.Left = 30 'your left pos
.Width = widthOfLabel 'your width
.Name = Replace(keyArrays(i, 1), " ", "_")
.Caption = keyArrays(i, 1) 'your caption ,
End With
Set CheckBoxArray(i).checkBoxEvent = cTemp
Next i
End Sub
Thank you for reviewing my question :) I am creating a text box on a userform at run time & wants to display filtered data on it. I am running to many run time errors for following code. for the first text box, I want to show a fatalcount, for second text box, it should be Majorcount & for last text box, it should be minorcount. Can someone direct me on right path? thanks in advance
Private Sub UserForm_Initialize()
Set sh = ThisWorkbook.Sheets("Testing")
sh.Range("F21").Activate
With sh
fatalcount = WorksheetFunction.CountIf(Range("F:F"), "Fatal")
'MsgBox fatalcount
Majorcount = WorksheetFunction.CountIf(Range("F:F"), "Major")
'MsgBox Majorcount
Minorcount = WorksheetFunction.CountIf(Range("F:F"), "Minor")
'MsgBox Minorcount
'Add a text box at run time
Dim txtB1 As Control
Dim i
For i = 0 To 5
Set txtB1 = Me.Controls.Add("Forms.TextBox.1")
With txtB1
.Name = "chkDemo" & i
.Height = 20
.Width = 100
.Left = 12
.Top = 15 * i * 2
.Text.i = fatalcount ' problem lines
.Text.i 1 = Majorcount
.Text.i 2 = Minorcount
End With
Next i
End Sub
Hope this is what you looking for.
Private Sub UserForm_Initialize()
Set sh = ThisWorkbook.Sheets("Testing")
sh.Range("F21").Activate
With sh
fatalcount = WorksheetFunction.CountIf(Range("F:F"), "Fatal")
Majorcount = WorksheetFunction.CountIf(Range("F:F"), "Major")
Minorcount = WorksheetFunction.CountIf(Range("F:F"), "Minor")
End With
Dim txtB1 As Control
Dim i
For i = 0 To 2
Set txtB1 = UserForm1.Controls.Add("Forms.TextBox.1")
With txtB1
.Name = "chkDemo" & i
.Height = 20
.Width = 100
.Left = 12
.Top = 15 * i * 2
End With
Next i
Dim tbox As Control
For Each tbox In UserForm1.Controls
If tbox.Name = "chkDemo0" Then
tbox.Value = fatalcount
ElseIf tbox.Name = "chkDemo1" Then
tbox.Value = Majorcount
ElseIf tbox.Name = "chkDemo2" Then
tbox.Value = Minorcount
End If
Next
End Sub
In my userform I ask the user how many listboxs they require and based on the number that the user enters the controls are dynamically created during run time. I want to be able to set the size of my userform based on the bottom position of the last dynamic control that was added to the userform. Below shows the code that I have written to do this, all I want to do at the minute is alert the bottom position of each dynamic control as they are added to the user form.
Dim dynamicControl As Control
For i = 1 To TextBox1.Value
Set cList = Me.Controls.Add("Forms.ListBox.1")
With cList
.Name = "listbox" & (i)
.Left = 150
.Top = listStartPosition
.Width = 300
.Height = 140
End With
Next i
dynamicControl = "listbox" & (i)
Msgbox dynamicControl.Bottom
When I run my code it errors out when I am trying to set the dynamicControl = "listbox" & 0 and the error I am recieving is object variable or with block variable not setobject variable or with block variable not set
to get your dynamic height you can use a code like this , by sending the number of clist this code is going to create them :
Private Sub createcontrol(num As Integer)
Dim StartPos As Integer
Dim WidthPos As Integer
StartPos = TextBox1.Top + TextBox1.Height + 10
For i = 1 To num
Set cList = Me.Controls.Add("Forms.ListBox.1")
With cList
.Name = "listbox" & (i)
.Left = 150
.Top = StartPos
.Width = 300
.Height = 140
StartPos = StartPos + .Height + 10
Me.Width = .Width + .Left
End With
Next i
Me.Height = StartPos - 8
End Sub