powerpoint vba - Add an image to userForm with click event using vba -
i created userform make possible create survey. looks @ beginning:
clicking cross next "add answer" can add more rows can seen in other image:
the problem have have add small arrows next checkboxes in new rows. move answers , down if user need change position of them. have add code move them.
the creation of elements need in each row done in following way:
private sub addanswer_click() image5.top = image5.top + 21 checkbox1.top = checkbox1.top + 21 checkbox2.top = checkbox2.top + 21 image7.height = image7.height + 21 image3.top = image3.top + 21 label1.top = label1.top + 21 label4.top = label4.top + 21 image2.top = image2.top + 21 tablet.top = tablet.top + 21 chart.top = chart.top + 21 label8.top = label8.top + 21 label9.top = label9.top + 21 labelorizontal.top = labelorizontal.top + 21 labelvertical.top = labelvertical.top + 21 labelnet.top = labelnet.top + 21 labelround.top = labelround.top + 21 labelpoints.top = labelpoints.top + 21 orizontal.top = orizontal.top + 21 vertical.top = vertical.top + 21 net.top = net.top + 21 points.top = points.top + 21 round.top = round.top + 21 excelbox.top = excelbox.top + 21 okbutton.top = okbutton.top + 21 cancelbutton.top = cancelbutton.top + 21 'me.multipage1.height = me.multipage1.height + 21 image1.height = image1.height + 21 'height = 418 + 21 * (valuenum - 1) if valuenum = 2 me 'this create vertical scrollbar .multipage1.pages(0).scrollbars = fmscrollbarsvertical 'change values of 2 per requirements '.scrollheight = .insideheight '.scrollwidth = .insidewidth * 9 end end if me.multipage1.pages(0).scrollheight = me.multipage1.pages(0).insideheight + 21 * (valuenum - 1) valuenum = valuenum + 1 set ccntrl = me.multipage1.pages(0).controls.add("forms.textbox.1", "textbox" & valuenum, true) ccntrl .width = 156 .height = 18 .top = 108 + (valuenum - 1) * 21 .left = 48 .tabindex = tabind .zorder (0) end set ccntrl1 = me.multipage1.pages(0).controls.add("forms.textbox.1", "anslabbox" & valuenum, true) ccntrl1 .width = 144 .height = 18 .top = 108 + (valuenum - 1) * 21 .left = 210 .tabindex = tabind + 1 .zorder (0) end tabind = tabind + 3 set ccntrl3 = me.multipage1.pages(0).controls.add("forms.checkbox.1", "open" & valuenum, true) ccntrl3 .left = 24 .width = 11 .height = 18 .backcolor = "&h8000000e" .top = 108 + (valuenum - 1) * 21 .zorder (0) end '''''''here starts important part question!!! set ccntrl3 = me.multipage1.pages(0).controls.add("forms.image.1", "down" & valuenum - 1, true) ccntrl3 .left = 12 .width = 12 .height = 6 .backcolor = "&h8000000e" .top = 116 + (valuenum - 2) * 21 .picture = loadpicture(addinpath & "\fixcontent\triangledown.jpg") .borderstyle = fmborderstylenone .picturesizemode = fmpicturesizemodestretch .zorder (0) end with activepresentation.vbproject.vbcomponents("surveycreation").codemodule x = .countoflines .insertlines x + 1, "private sub down" & valuenum - 1 & "_click()" .insertlines x + 2, "godown " & valuenum - 1 .insertlines x + 3, "end sub" end set ccntrl3 = me.multipage1.pages(0).controls.add("forms.image.1", "up" & valuenum, true) ccntrl3 .left = 12 .width = 12 .height = 6 .backcolor = "&h8000000e" .top = 111 + (valuenum - 1) * 21 .picture = loadpicture(addinpath & "\fixcontent\triangleup.jpg") .borderstyle = fmborderstylenone .picturesizemode = fmpicturesizemodestretch .zorder (0) end with activepresentation.vbproject.vbcomponents("surveycreation").codemodule x = .countoflines .insertlines x + 1, "private sub up" & valuenum & "_click()" .insertlines x + 2, "goup " & valuenum .insertlines x + 3, "end sub" end set ccntrl3 = me.multipage1.pages(0).controls.add("forms.image.1", "delete" & valuenum, true) ccntrl3 .left = 480 .width = 12 .height = 12 .backcolor = "&h8000000e" .top = 110 + (valuenum - 1) * 21 .picture = loadpicture(addinpath & "\fixcontent\cross.jpg") .borderstyle = fmborderstylenone .picturesizemode = fmpicturesizemodestretch .zorder (0) end with activepresentation.vbproject.vbcomponents("surveycreation").codemodule x = .countoflines .insertlines x + 1, "private sub delete" & valuenum & "_click()" .insertlines x + 2, "deleterow " & valuenum .insertlines x + 3, "end sub" end if not combovisi ccntrl2.visible = false end if end sub so can see create elements , add code (click events) surveycreation (witch userform)
the deleterow, goup , godown methods defined. never entering in click events. first click events (the ones made arrows appears in first image) defined , working not ones define using code created. can make them work?
as follow comments, here's working example of sort of thing trying do:
class answer
option explicit public key string public answer string public answerlabel string class answer controls
option explicit public withevents answer msforms.textbox public withevents answerlabel msforms.textbox private withevents remove msforms.commandbutton private withevents moveup msforms.label private withevents movedown msforms.label private p_parent object private p_rowkey string private p_answers answers private p_data answer const padding = 5 const tbwidth = 100 public sub addrow(top double, left double, parent answers, container object, rowkey string) set p_parent = container set p_answers = parent p_rowkey = rowkey set answer = p_parent.controls.add("forms.textbox.1", "tb1" + rowkey) set answerlabel = p_parent.controls.add("forms.textbox.1", "tb2" + rowkey) set remove = p_parent.controls.add("forms.commandbutton.1", "cb" + rowkey) set moveup = p_parent.controls.add("forms.label.1", "lb1" + rowkey) set movedown = p_parent.controls.add("forms.label.1", "lb2" + rowkey) moveup .left = left .top = top .caption = "up" .width = 35 end movedown .left = left + 20 + padding .top = top .caption = "down" .width = 35 end answer .left = left + (35 * 2) + (padding * 2) .top = top .width = tbwidth end answerlabel .left = left + (50 * 2) + (padding * 2) + padding + tbwidth .top = top .width = tbwidth end remove .left = left + (50 * 2) + (padding * 2) + padding + (tbwidth * 2) + padding .top = top .height = answerlabel.height .caption = "x" end end sub private sub answer_change() p_data.answer = answer.text end sub private sub answerlabel_change() p_data.answerlabel = answerlabel.text end sub private sub class_terminate() p_parent.controls.remove answer.name p_parent.controls.remove answerlabel.name p_parent.controls.remove moveup.name p_parent.controls.remove movedown.name p_parent.controls.remove remove.name end sub private sub movedown_click() p_answers.movedown p_data.key end sub private sub moveup_click() p_answers.moveup p_data.key end sub private sub remove_click() p_answers.remove p_data.key, p_rowkey end sub public property set data(data answer) set p_data = data answer.value = data.answer answerlabel.value = data.answerlabel end property class answers
option explicit private answerlist collection private rowlist collection private no_rows long public parent object public sub moveup(key string) dim ans answer dim x long: x = 1 set ans = answerlist(key) each ans in answerlist if ans.key = key exit x = x + 1 next ans answerlist.remove key if x = 1 x = 2 'the item may @ top answerlist.add ans, ans.key, x - 1 rebind end sub public sub movedown(key string) dim ans answer dim x long: x = 1 set ans = answerlist(key) each ans in answerlist if ans.key = key exit x = x + 1 next ans answerlist.remove key if x >= answerlist.count answerlist.add ans, ans.key else answerlist.add ans, ans.key, x + 1 end if rebind end sub public sub movetotop(key string) dim ans answer set ans = answerlist(key) answerlist.remove key answerlist.add ans, ans.key, 1 'rebind our data our interface rebind end sub public sub remove(key string, rowkey string) dim ans answer dim x long: x = 1 answerlist.remove key rebind rowlist.remove rowlist.count no_rows = no_rows - 1 end sub public sub add(newanswer answer) addrow answerlist.add newanswer, newanswer.key set rowlist(rowlist.count).data = newanswer end sub private sub addrow() dim rowcontrols answercontrols set rowcontrols = new answercontrols rowcontrols.addrow 20 * no_rows, 1, me, parent, "r" & no_rows rowlist.add rowcontrols, "r" & no_rows no_rows = no_rows + 1 end sub private sub class_initialize() set answerlist = new collection set rowlist = new collection no_rows = 1 end sub private sub rebind() dim ans answer dim x long x = 1 each ans in answerlist set rowlist(x).data = ans x = x + 1 next ans end sub simple implementation in userform:
option explicit dim d answers private sub userform_click() dim new answer a.key = rnd * 10 d.add end sub private sub userform_initialize() set d = new answers set d.parent = me end sub
Comments
Post a Comment