I have a simple form with a drop down box with a list of names in it
and a picture box above that .
how can i make it when i select a name the picture
of that person shows up automatically in the picture box ?
use a user defined type containing both the name as well as the picture file, and then create an array of this type
for example :
'1 form with :
' 1 listbox : name=List1
' 1 picturebox : name=Picture1
Option Explicit
Private Type PERSON
strName As String
strPicture As String
End Type
Private mperFriend(4) As PERSON
Private Sub Form_Load()
Dim intIndex As Integer
mperFriend(0).strName = "Bob"
mperFriend(0).strPicture = "Bob.jpg"
mperFriend(1).strName = "Jane"
mperFriend(1).strPicture = "Jane.jpg"
mperFriend(2).strName = "Fred"
mperFriend(2).strPicture = "Fred.jpg"
mperFriend(3).strName = "Iris"
mperFriend(3).strPicture = "Iris.jpg"
mperFriend(4).strName = "John"
mperFriend(4).strPicture = "John.jpg"
List1.Clear
For intIndex = 0 To UBound(mperFriend)
List1.AddItem mperFriend(intIndex).strName
Next intIndex
End Sub
Private Sub List1_Click()
Caption = mperFriend(List1.ListIndex).strPicture
Picture1.Picture = LoadPicture(App.Path & "\" & mperFriend(List1.ListIndex).strPicture)
End Sub
Related
in my project there are two forms:
first form i named it frmSettings , i will use text boxes to save values in INI file.
second form i named it frmSelectFolder , i had included with DirListBox and 2 Command buttons
as shown in attached image above in Settings form i have 8 text boxes and 8 command buttons to browse for folder path that it will be selected from frmSelectFolder
how to use frmSelectFolder for all text boxes without duplicating this form per each command button to return DirlistBox Control value ?
Here is some sample code for secondary frmSelectFolder form
Option Explicit
Private m_bConfirm As Boolean
Public Function Init(sPath As String) As Boolean
Dir1.Path = sPath
Show vbModal
If m_bConfirm Then
sPath = Dir1.Path
'--- success
Init = True
End If
Unload Me
End Function
Private Sub cmdOk_Click()
If LenB(Dir1.Path) = 0 Then
MsgBox "Please select a path!", vbExclamation
Exit Sub
End If
m_bConfirm = True
Visible = False
End Sub
Private Sub cmdCancel_Click()
Visible = False
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If UnloadMode <> vbFormCode Then
Cancel = 1
Visible = False
End If
End Sub
Here is how to call Init method above from primary frmSettings
Option Explicit
Private Sub cmdStartupPath_Click()
Dim sPath As String
Dim oFrmSelector As New frmSelectFolder
sPath = txtStartupPath.Text
If oFrmSelector.Init(sPath) Then
txtStartupPath.Text = sPath
txtStartupPath.SetFocus
End If
End Sub
Private Sub cmdDownloadPath_Click()
Dim sPath As String
Dim oFrmSelector As New frmSelectFolder
sPath = txtDownloadPath.Text
If oFrmSelector.Init(sPath) Then
txtDownloadPath.Text = sPath
txtDownloadPath.SetFocus
End If
End Sub
Here is a link to a complete sample project for you to research: SelectFolder.zip
Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 5 years ago.
Improve this question
I want to create a VBScript (not within an HTML file) that gives the user a list of documents to select from then uses the selections to run another script for each document they chose. How do I create this list box?
Some sort of GUI for WSH VBS can be implemented via dynamically created HTA window. The below code includes two wrapper classes, which facilitate HTA window creation and elements events handling, and shows how to put a listbox and buttons on the form and get selected items:
Option Explicit
' Base64-encoded background image
Const BGI = "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAWIAAAB2CAYAAADybJlDAAAACXBIWXMAAC4jAAAuIwF4pT92AAAAIGNIUk0AAHolAACAgwAA+f8AAIDpAAB1MAAA6mAAADqYAAAXb5JfxUYAAAUjSURBVHja7N05ztxGEIBRjqHciZ34Bn3/w9QNnPsE49QwtPwc9lLd9V4kAdKwyQE+Fjnb6/1+XwCs85tDACDEAEIMgBADCDEAQgwgxAAIMYAQAyDEAEIMgBADCDEAQgwgxACM980hgD28Xq/Td7Hd/PdxzHPri+FBiBPH9hPbBVqIQYh3D+/2YRZiEOIT47tVmIUYhLhCfFMHWYhBiKsFOF2UhRiEuHKAUwRZiEGIBXhxkIUYhFiAFwdZiEGIBXhxjIUYhDhLhCP5OocFWYhBiGeHLaxdiEGI54YsNljj0n0SYhDiEYGLhGtKG2MhBiHOFuCdXiDsEmMhhtoh7hW9SLKOLWMsxFA3xD3iVznA3Y6FEEPNED8NoAB3PC5CDPVCvDLCFT4gcvv4CDHUCvGTEFYKcMw8Vn48FOpYEeG28RQ87cRjIoYaE/GnMdxpCo7O2336eH9f1/WPEIMQr4jwyo8Zt4HbaqOOoRCDEGePcCzc9pQYCzGcHeJZER45ia6ewmP0MfViHZxrxwjHle9XltvoYyTEIMIZIvwkwDNvvfT6/0IMpInw0wn4SYTj4Xa63T4RYjANr4hwj1sQKybhIc+NEIMIz4xwr3vAvSI8eyo2EQNLAphhGo1Ej92EGESyW0AWhbD3fkaHbT86lkIMNc2KcO+3ox3500lCDPWm4ZkRXjnx31lDTDgeP3wcIYZaEZ712Bk+lBG7bFOIoZbYdBsz3g0SC/a/CTGw6lZAlok/xZqEGGrFsg163FW3AnqvY8lULMQg3pkj3JKsYyghhjrT8KhL66oRbr3WI8Qg5OUm0Gz7JMQgxhmDdcoJ4UvrEmKoF9AfPVbbdN+2n8qFGNg5fkfcGhFiIFP82mb72Ho8lhDD+dOrqdxEDCyc6mLAY54+lQsxkDrspvwBx06IQUDtj4kYGDA5xnf+Hpvv07GEGEzHd4LZO5qVXqALIQZ6xaxtuu602xNiYNV03A46FkIM7BuhpNPwVEIM50VvxddBjvqC+hKEGAQ9++PG6U+IEAOzp+M7wS7xHmghBnaajk3EgEA+nI4rT8NCDNy+hO4VQtPxL3xzCIAvTKWz3zOcYRr+a9ZaTcSA2wTf9/usDQkxcCfGMWk7pQgx1PGHUAoxsNafHUM7ajouGXkhBjKFc8RXbQoxUCLGgizEgCB33+60KwIhBgR5ceB9oAPYNWTHvLBnIoa9Js2el9UnRPmIfRViYNol+CZBnh53tyaAE+O/1ScAhRgQ5cWEGBgZwa9OlW3SeqLj2rsdF/eIQQxXif/9OSYdlx73lLuuVYhhL9kvs3sELiau9b9RXnbyEmIg6wln5kln6U84CTGcK/Ptibjx72ZHefpz4cU6YJfwx6Tt3NnPLicIIYY9L9vb5us/Icg/W8OtfRRiOH9KPfXL1mPiND706kCIgenhKRblX/JiHdS5vM/wpUGzPnq81Qt8Qgym1dNPWOmjLMRQayquHPq0URZiMBVXO3GYiIEtYnjy7Yxs+xZCDDXCOipAuwW7fXB8h0/y3r4GZDthZIrwz9bfeh0XIYYzIvfVKNyJx0kfBmmDjnuXbbk1AZzukwjHhG2FEINL/4xTZpUIm4hBjKfGdtXtjZZ4WyHEwOk+jfCSk4YQg6k402S5Y4Tb0+0IMTAyPpF0XWkiLMRgKj5lKn7yy8yx+pgIMYhxlel8dYRDiEGMT5uK23VAhIUYqDgFp4rwdV3X6/1+e0phA6/Xa7dJ9rT3NQ+7B/0vAAAA//8DAERsQ7O6796eAAAAAElFTkSuQmCC"
Dim aItems, i
' Array containing items for ListBox
aItems = Array("Item A", "Item B", "Item C", "Item D", "Item E")
' Create HTA window wrapper
With New clsSmallWrapperForm
' Setup window
.ShowInTaskbar = "yes"
.Title = "Test HTA UserForm"
.BackgroundImage = BGI
.Width = 354
.Height = 118
.Visible = False
' Create window
.Create
' Assign handlers
Set .Handlers = New clsSmallWrapperHandlers
' Add ListBox
With .AddElement("ListBox1", "SELECT")
.size = 6
.multiple = True
.style.left = "15px"
.style.top = "10px"
.style.width = "250px"
End With
.AppendTo "Form"
' Add ListBox items
For i = 0 To UBound(aItems)
.AddElement , "OPTION"
.AddText aItems(i)
.AppendTo "ListBox1"
Next
' Add OK Button
With .AddElement("Button1", "INPUT")
.type = "button"
.value = "OK"
.style.left = "285px"
.style.top = "10px"
.style.width = "50px"
.style.height = "20px"
End With
.AppendTo "Form"
' Add Cancel Button
With .AddElement("Button2", "INPUT")
.type = "button"
.value = "Cancel"
.style.left = "285px"
.style.top = "40px"
.style.width = "50px"
.style.height = "20px"
End With
.AppendTo "Form"
' Add Label
With .AddElement("Label1", "SPAN")
.style.left = "15px"
.style.top = "98px"
.style.width = "350px"
End With
.AddText "Choose items"
.AppendTo "Form"
' Show window
.Visible = True
' Wait window closing or user choise
Do While .ChkDoc And Not .Handlers.Selected
WScript.Sleep 100
Loop
' Read results from array .Handlers.SelectedItems
If .Handlers.Selected Then
MsgBox "Selected " & (UBound(.Handlers.SelectedItems) + 1) & " Item(s)" & vbCrLf & Join(.Handlers.SelectedItems, vbCrLf)
Else
MsgBox "Window closed"
End If
' The rest part of code ...
End With
Class clsSmallWrapperHandlers
' Handlers class implements events processing
' Edit code to provide the necessary behavior
' Keep conventional VB handlers names: Public Sub <ElementID>_<EventName>()
Public oswForm ' mandatory property
Public Selected
Public SelectedItems
Private Sub Class_Initialize()
Selected = False
SelectedItems = Array()
End Sub
Public Sub ListBox1_Click()
Dim vItem
With CreateObject("Scripting.Dictionary")
For Each vItem In oswForm.Window.ListBox1.childNodes
If vItem.Selected Then .Item(vItem.innerText) = ""
Next
SelectedItems = .Keys()
End With
oswForm.Window.Label1.style.color = "buttontext"
oswForm.Window.Label1.innerText = (UBound(SelectedItems) + 1) & " selected"
End Sub
Public Sub Button1_Click()
Selected = UBound(SelectedItems) >= 0
If Selected Then
oswForm.Window.close
Else
oswForm.Window.Label1.style.color = "darkred"
oswForm.Window.Label1.innerText = "Choose at least 1 item"
End If
End Sub
Public Sub Button2_Click()
oswForm.Window.close
End Sub
End Class
Class clsSmallWrapperForm
' Utility class for HTA window functionality
' Do not modify
' HTA tag properties
Public Border ' thick | dialog | none | thin
Public BorderStyle ' normal | complex | raised | static | sunken
Public Caption ' yes | no
Public ContextMenu ' yes | no
Public Icon ' path
Public InnerBorder ' yes | no
Public MinimizeButton ' yes | no
Public MaximizeButton ' yes | no
Public Scroll ' yes | no | auto
Public Selection ' yes | no
Public ShowInTaskbar ' yes | no
Public SysMenu ' yes | no
Public WindowState ' normal | minimize | maximize
' Form properties
Public Title
Public BackgroundImage
Public Width
Public Height
Public Left
Public Top
Public Self
Dim oWnd
Dim oDoc
Dim bVisible
Dim oswHandlers
Dim oLastCreated
Private Sub Class_Initialize()
Set Self = Me
Set oswHandlers = Nothing
Border = "thin"
ContextMenu = "no"
InnerBorder = "no"
MaximizeButton = "no"
Scroll = "no"
Selection = "no"
End Sub
Private Sub Class_Terminate()
On Error Resume Next
oWnd.Close
End Sub
Public Sub Create()
' source http://forum.script-coding.com/viewtopic.php?pid=75356#p75356
Dim sName, sAttrs, sSignature, oShellWnd, oProc
sAttrs = ""
For Each sName In Array("Border", "Caption", "ContextMenu", "MaximizeButton", "Scroll", "Selection", "ShowInTaskbar", "Icon", "InnerBorder", "BorderStyle", "SysMenu", "WindowState", "MinimizeButton")
If Eval(sName) <> "" Then sAttrs = sAttrs & " " & sName & "=" & Eval(sName)
Next
If Len(sAttrs) >= 240 Then Err.Raise 450, "<HTA:APPLICATION" & sAttrs & " />"
sSignature = Mid(Replace(CreateObject("Scriptlet.TypeLib").Guid, "-", ""), 2, 16)
Set oProc = CreateObject("WScript.Shell").Exec("mshta ""about:<script>moveTo(-32000,-32000);document.title='*'</script><hta:application" & sAttrs & " /><object id='s' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>s.putProperty('" & sSignature & "',document.parentWindow);</script>""")
Do
If oProc.Status > 0 Then Err.Raise 507, "mshta.exe"
For Each oShellWnd In CreateObject("Shell.Application").Windows
On Error Resume Next
Set oWnd = oShellWnd.GetProperty(sSignature)
If Err.Number = 0 Then
On Error Goto 0
With oWnd
Set oDoc = .document
With .document
.open
.close
.title = Title
.getElementsByTagName("head")(0).appendChild .createElement("style")
.styleSheets(0).cssText = "* {font:8pt tahoma;position:absolute;}"
.getElementsByTagName("body")(0).id = "Form"
End With
.Form.style.background = "buttonface"
If BackgroundImage <> "" Then
.Form.style.backgroundRepeat = "no-repeat"
.Form.style.backgroundImage = "url(" & BackgroundImage & ")"
End If
If IsEmpty(Width) Then Width = .Form.offsetWidth
If IsEmpty(Height) Then Height = .Form.offsetHeight
.resizeTo .screen.availWidth, .screen.availHeight
.resizeTo Width + .screen.availWidth - .Form.offsetWidth, Height + .screen.availHeight - .Form.offsetHeight
If IsEmpty(Left) Then Left = CInt((.screen.availWidth - Width) / 2)
If IsEmpty(Top) Then Top = CInt((.screen.availHeight - Height) / 2)
bVisible = IsEmpty(bVisible) Or bVisible
Visible = bVisible
.execScript "var smallWrapperThunks = (function(){" &_
"var thunks,elements={};return {" &_
"parseHandlers:function(h){" &_
"thunks=h;for(var key in thunks){var p=key.toLowerCase().split('_');if(p.length==2){elements[p[0]]=elements[p[0]]||{};elements[p[0]][p[1]]=key;}}}," &_
"forwardEvents:function(e){" &_
"if(elements[e.id.toLowerCase()]){for(var key in e){if(key.search('on')==0){var q=elements[e.id.toLowerCase()][key.slice(2)];if(q){eval(e.id+'.'+key+'=function(){thunks.'+q+'()}')}}}}}}})()"
If Not oswHandlers Is Nothing Then
.smallWrapperThunks.parseHandlers oswHandlers
.smallWrapperThunks.forwardEvents .Form
End If
End With
Exit Sub
End If
On Error Goto 0
Next
WScript.Sleep 100
Loop
End Sub
Public Property Get Handlers()
Set Handlers = oswHandlers
End Property
Public Property Set Handlers(oHandlers)
Dim oElement
If Not oswHandlers Is Nothing Then Set oswHandlers.oswForm = Nothing
Set oswHandlers = oHandlers
Set oswHandlers.oswForm = Me
If ChkDoc Then
oWnd.smallWrapperThunks.parseHandlers oswHandlers
For Each oElement In oDoc.all
If oElement.id <> "" Then oWnd.smallWrapperThunks.forwardEvents oElement
Next
End If
End Property
Public Sub ForwardEvents(oElement)
If ChkDoc Then oWnd.smallWrapperThunks.forwardEvents oElement
End Sub
Public Function AddElement(sId, sTagName)
Set oLastCreated = oDoc.createElement(sTagName)
If VarType(sId) <> vbError Then
If Not(IsNull(sId) Or IsEmpty(sId)) Then oLastCreated.id = sId
End If
oLastCreated.style.position = "absolute"
Set AddElement = oLastCreated
End Function
Public Function AppendTo(vNode)
If Not IsObject(vNode) Then Set vNode = oDoc.getElementById(vNode)
vNode.appendChild oLastCreated
ForwardEvents oLastCreated
Set AppendTo = oLastCreated
End Function
Public Function AddText(sText)
oLastCreated.appendChild oDoc.createTextNode(sText)
End Function
Public Property Get Window()
Set Window = oWnd
End Property
Public Property Get Document()
Set Document = oDoc
End Property
Public Property Get Visible()
Visible = bVisible
End Property
Public Property Let Visible(bWindowVisible)
bVisible = bWindowVisible
If ChkDoc Then
If bVisible Then
oWnd.moveTo Left, Top
Else
oWnd.moveTo -32000, -32000
End If
End If
End Property
Public Function ChkDoc()
On Error Resume Next
ChkDoc = CBool(TypeName(oDoc) = "HTMLDocument")
End Function
End Class
In fact that is just a draft, and some operations like generic types elements creation can be simplified by adding wrappers and methods with such functionality to clsSmallWrapperForm.
text1.text = "Mayweather vs McGregor: Los Angeles Press Conference"
text2.text returns count of space.
my custom value say = "love"
now on each button click , i want to randomly add that custom string to each position the space.
so first click
text1.text = "Mayweather vs love McGregor: Los Angeles Press Conference"
second click
text1.text = "Mayweather vs McGregor: ;love Los Angeles Press Conference"
and so on depending on the code were it detects the space then add it their only once per click.
Code:
Dim Count As Integer
Dim i As Integer
For i = 1 To Len(Text1.Text)
If Mid(Text1.Text, i, 1) = " " Then Count = Count + 1
Text2.Text = Count
Next
Here is a small test project:
Option Explicit
' 1 form with:
' 2 textbox controls: name=Text1 and name=Text2
' 1 command button : name=Command1
Private mstrText As String
Private Sub Command1_Click()
Static intCount As Integer 'declare as static to remember value of intCount on next click
Dim intLoop As Integer
Dim intSpace As Integer
intCount = intCount + 1
'find correct space
intLoop = 0
intSpace = 0
Do While intLoop < intCount
intSpace = InStr(intSpace + 1, mstrText, " ")
intLoop = intLoop + 1
Loop
Text1.Text = Left$(mstrText, intSpace) & "love " & Mid$(mstrText, intSpace + 1)
Caption = CStr(intSpace)
End Sub
Private Sub Form_Load()
mstrText = "Mayweather vs McGregor: Los Angeles Press Conference"
Text1.Text = mstrText
End Sub
Private Sub Text1_Change()
'show number of spaces
Dim intSpace As Integer
intSpace = Len(Text1.Text) - Len(Replace(Text1.Text, " ", ""))
Text2.Text = CStr(intSpace)
End Sub
Is this what you mean?
How do I set SelectedIndex of a DataGridViewComboBoxCell?
The code fill the combobox with items, but I need to select one of them
My Code:
Dim cListItems As New System.Collections.Generic.List(Of Combobox_values)
If ds.Tables("items_prices").Rows(0).Item("item_selldozen") > 0 Then
Dim item_selldozen As String = ds.Tables("items_prices").Rows(0).Item("item_selldozen")
cListItems.Add(New Combobox_values("Docena (" + item_selldozen + ")", item_selldozen))
End If
Dim dgvcbc As DataGridViewComboBoxCell = DirectCast(CType(main.ActiveMdiChild, discount_new_discount).discountitems_new_discount.Rows(last_row).Cells(3), DataGridViewComboBoxCell)
dgvcbc.DataSource = cListItems 'Fill Remote Comboboxcell
dgvcbc.DisplayMember = "Text"
dgvcbc.ValueMember = "Value"
If you have a ComboBoxColumn in your DataGridView and you want to know what is the selected index of the combo box, then you need to do this:
Handle the EditingControlShowing event of DataGridView. In this event handler, check if the current column is of our interest. Then we
create a temporary ComboBox object and get the selected index:
Private Sub dataGridView1_EditingControlShowing(sender As Object, e As DataGridViewEditingControlShowingEventArgs)
If dataGridView1.CurrentCell.ColumnIndex = 0 Then
' Check box column
Dim comboBox As ComboBox = TryCast(e.Control, ComboBox)
comboBox.SelectedIndexChanged += New EventHandler(AddressOf comboBox_SelectedIndexChanged)
End If
End Sub
Private Sub comboBox_SelectedIndexChanged(sender As Object, e As EventArgs)
Dim selectedIndex As Integer = DirectCast(sender, ComboBox).SelectedIndex
MessageBox.Show("Selected Index = " & selectedIndex)
End Sub
I would like to add a Control and an associated event at runtime in Excel using VBA but I don't know how to add the events.
I tried the code below and the Button is correctly created in my userform but the associated click event that should display the hello message is not working.
Any advice/correction would be welcome.
Dim Butn As CommandButton
Set Butn = UserForm1.Controls.Add("Forms.CommandButton.1")
With Butn
.Name = "CommandButton1"
.Caption = "Click me to get the Hello Message"
.Width = 100
.Top = 10
End With
With ThisWorkbook.VBProject.VBComponents("UserForm1.CommandButton1").CodeModule
Line = .CountOfLines
.InsertLines Line + 1, "Sub CommandButton1_Click()"
.InsertLines Line + 2, "MsgBox ""Hello!"""
.InsertLines Line + 3, "End Sub"
End With
UserForm1.Show
The code for adding a button at runtime and then to add events is truly as simple as it is difficult to find out. I can say that because I have spent more time on this perplexity and got irritated more than in anything else I ever programmed.
Create a Userform and put in the following code:
Option Explicit
Dim ButArray() As New Class2
Private Sub UserForm_Initialize()
Dim ctlbut As MSForms.CommandButton
Dim butTop As Long, i As Long
'~~> Decide on the .Top for the 1st TextBox
butTop = 30
For i = 1 To 10
Set ctlbut = Me.Controls.Add("Forms.CommandButton.1", "butTest" & i)
'~~> Define the TextBox .Top and the .Left property here
ctlbut.Top = butTop: ctlbut.Left = 50
ctlbut.Caption = Cells(i, 7).Value
'~~> Increment the .Top for the next TextBox
butTop = butTop + 20
ReDim Preserve ButArray(1 To i)
Set ButArray(i).butEvents = ctlbut
Next
End Sub
Now you need to add a Class Module to your code for the project. Please remember it's class module, not Standard Module.
The Object butEvents is the button that was clicked.
Put in the following simple code (in my case the class name is Class2).
Public WithEvents butEvents As MSForms.CommandButton
Private Sub butEvents_click()
MsgBox "Hi Shrey from " & butEvents.Caption
End Sub
That's it. Now run it!
Try this:
Sub AddButtonAndShow()
Dim Butn As CommandButton
Dim Line As Long
Dim objForm As Object
Set objForm = ThisWorkbook.VBProject.VBComponents("UserForm1")
Set Butn = objForm.Designer.Controls.Add("Forms.CommandButton.1")
With Butn
.Name = "CommandButton1"
.Caption = "Click me to get the Hello Message"
.Width = 100
.Top = 10
End With
With objForm.CodeModule
Line = .CountOfLines
.InsertLines Line + 1, "Sub CommandButton1_Click()"
.InsertLines Line + 2, "MsgBox ""Hello!"""
.InsertLines Line + 3, "End Sub"
End With
VBA.UserForms.Add(objForm.Name).Show
End Sub
This permanently modifies UserForm1 (assuming you save your workbook). If you wanted a temporary userform, then add a new userform instead of setting it to UserForm1. You can then delete the form once you're done with it.
Chip Pearson has some great info about coding the VBE.
DaveShaw, thx for this code man!
I have used it for a togglebutton array (put a 'thumbnail-size' picture called trainer.jpg in the same folder as the excel file for a togglebutton with a picture in it). In the 'click' event the invoker is also available (by the object name as a string)
In the form:
Dim CreateTrainerToggleButtonArray() As New ToggleButtonClass
Private Sub CreateTrainerToggleButton(top As Integer, id As Integer)
Dim pathToPicture As String
pathToPicture = ThisWorkbook.Path & "\trainer.jpg"
Dim idString As String
idString = "TrainerToggleButton" & id
Dim cCont As MSForms.ToggleButton
Set cCont = Me.Controls.Add _
("Forms.ToggleButton.1")
With cCont
.Name = idString
.Width = 20
.Height = 20
.Left = 6
.top = top
.picture = LoadPicture(pathToPicture)
End With
ReDim Preserve CreateTrainerToggleButtonArray(1 To id)
Set CreateTrainerToggleButtonArray(id).ToggleButtonEvents = cCont
CreateTrainerToggleButtonArray(id).ObjectName = idString
End Sub
and a class "ToggleButtonClass"
Public WithEvents ToggleButtonEvents As MSForms.ToggleButton
Public ObjectName As String
Private Sub ToggleButtonEvents_click()
MsgBox "DaveShaw is the man... <3 from your friend: " & ObjectName
End Sub
Now just simple call from UserForm_Initialize
Private Sub UserForm_Initialize()
Dim index As Integer
For index = 1 To 10
Call CreateTrainerToggleButton(100 + (25 * index), index)
Next index
End Sub
This was my solution to add a commandbutton and code without using classes
It adds a reference to allow access to vbide
Adds the button
Then writes a function to handle the click event in the worksheet
Sub AddButton()
Call addref
Set rng = DestSh.Range("B" & x + 3)
'Set btn = DestSh.Buttons.Add(rng.Left, rng.Top, rng.Width, rng.Height)
Set myButton = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", Left:=rng.Left, Top:=rng.Top, Height:=rng.Height * 3, Width:=rng.Width * 3)
DoEvents
With myButton
'.Placement = XlPlacement.xlFreeFloating
.Object.Caption = "Export"
.Name = "BtnExport"
.Object.PicturePosition = 1
.Object.Font.Size = 14
End With
Stop
myButton.Object.Picture = LoadPicture("F:\Finalised reports\Templates\Macros\evolution48.bmp")
Call CreateButtonEvent
End Sub
Sub addref()
On Error Resume Next
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA6\VBE6EXT.OLB"
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6EXT.OLB"
End Sub
Private Sub CreateButtonEvent()
On Error GoTo errtrap
Dim oXl As Application: Set oXl = Application
oXl.EnableEvents = False
oXl.DisplayAlerts = False
oXl.ScreenUpdating = False
oXl.VBE.MainWindow.Visible = False
Dim oWs As Worksheet
Dim oVBproj As VBIDE.VBProject
Dim oVBcomp As VBIDE.VBComponent
Dim oVBmod As VBIDE.CodeModule '
Dim lLine As Single
Const QUOTE As String = """"
Set oWs = Sheets("Contingency")
Set oVBproj = ThisWorkbook.VBProject
Set oVBcomp = oVBproj.VBComponents(oWs.CodeName)
Set oVBmod = oVBcomp.CodeModule
With oVBmod
lLine = .CreateEventProc("Click", "BtnExport") + 1
.InsertLines lLine, "Call CSVFile"
End With
oXl.EnableEvents = True
oXl.DisplayAlerts = True
Exit Sub
errtrap:
End Sub
An easy way to do it:
1 - Insert a class module and write this code:
Public WithEvents ChkEvents As MSForms.CommandButton
Private Sub ChkEvents_click()
MsgBox ("Click Event")
End Sub
2 - Insert a userform and write this code:
Dim Chk As New Clase1
Private Sub UserForm_Initialize()
Dim NewCheck As MSForms.CommandButton
Set NewCheck = Me.Controls.Add("Forms.CommandButton.1")
NewCheck.Caption = "Prueba"
Set Chk.ChkEvents = NewCheck
End Sub
Now show the form and click the button
I think the code needs to be added to the Userform, not to the button itself.
So something like
With UserForm1.CodeModule
'Insert code here
End With
In place of your With ThisWorkbook