Hi. Please, I need help with the VBA. How to draw in UserForm? For example, I press a key and a rectangle (or line or circle) appears on the UserForm)
Sorry for my English
Can you explain, please, why do you have such a need?
Practically I do not think it is possible (easily) to draw something directly on the form, but you can trick that drawing on the page, saving the drawing somewhere in your computer, creating a control on the fly (let's say a label) and connect the label.Picture property to the recent saved picture... All that programmatically done.
I think I can show you something in order to understand the trick. Of course if it fills your needs...
I understand what you're saying. It's not exactly, but I'd like to see you do it. Probably have to do as you said. Show an example
Create a form with a button and copy the next code in the form code. The form must keep a button named btDrawRect:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43
Dim x As MSForms.Label Dim ctl As MSForms.Control Private Sub btDrawRect_Click() Dim sizeHeight As Double, sizeWidth As Double, s1 As Shape, LeftS, TopS, filter As ExportFilter Const pathToSave = "C:\" ActiveDocument.Unit = cdrMillimeter sizeHeight = 70: sizeWidth = 100: LeftS = 1: TopS = 1 Set s1 = ActiveDocument.Pages(1).Layers("Layer 1").CreateRectangle(LeftS, ActivePage.sizeHeight - TopS, _ ActivePage.sizeWidth - LeftS - sizeWidth, ActivePage.TopY - (TopS + sizeHeight)) s1.Fill.ApplyFountainFill CreateRGBColor(255, 0, 0), CreateRGBColor(0, 0, 0) 's1.ConvertToBitmap Set filter = ActiveDocument.ExportBitmap(pathToSave & "TestDraw.jpg", cdrJPEG, cdrSelection, _ cdrRGBColorImage, sizeWidth, sizeHeight, 300, 300) With filter .Compression = 80 .Optimized = True .Smoothing = 50 .SubFormat = 1 .Progressive = False .Finish End With For Each ctl In frmTestDraw.Controls If ctl.Name = "PictureDr" Then frmTestDraw.Controls.Remove "PictureDr" End If Next Set x = frmTestDraw.Controls.Add("Forms.Label.1", "PictureDr", Visible) With x x.Height = sizeHeight x.Width = sizeWidth x.Left = LeftS x.Top = TopS x.Caption = "Test Draw" 'x.AutoSize = True End With frmTestDraw!PictureDr.Caption = "Rectangle" frmTestDraw!PictureDr.Picture = LoadPicture(pathToSave & "TestDraw.jpg") frmTestDraw!PictureDr.PicturePosition = fmPicturePositionBelowCenter End Sub
You can delete the previous shape and draw the next one, or keep it and create another label with a new shape in an incremented position. You can dynamically name the shapes and manipulate them if necessary... You can do that pressing a single button. If you intend to have a button for each shape it is even simpler.
You can also draw all of them on the page and save just a global picture linked by a label. In case you do not need to present all that dynamically immediately after the shape creation. In fact, if the forms appear on the page why the need to also appear on the form?
Thank you so much! I want to make 'preview' of my script. I didn't think it was such a problem. I'll do as you suggested.
OK. Glad to help...
I played with your 'theme' and you can also better understand what you can do with such an approach in the next example to be paste in the form code. It creates three shapes (rectangular, ellipse, line segment) pressing the appropriate button and can also wipe them pressing the Clear button.
So in order to work without any adaptation, your form must have four buttons named: btDrawRect, btDrawCircle, btDrawLine, btClear.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74
Dim lb As MSForms.Label, ctl As MSForms.Control, pathToSave As String Private Sub btClear_Click() For Each ctl In frmTestDraw.Controls If Left(ctl.name, 8) = "PictureD" Then frmTestDraw.Controls.Remove ctl.name End If Next End Sub Private Sub btDrawLine_Click() Dim sizeHeight As Double, sizeWidth As Double, s1 As Shape, LeftS As Long, TopS As Long, filter As ExportFilter sizeHeight = 70: sizeWidth = 30: LeftS = 171: TopS = 1 DrawShape sizeHeight, sizeWidth, LeftS, TopS, "Line", "PictureDL" End Sub Private Sub btDrawRect_Click() 'Create rectangle Dim sizeHeight As Double, sizeWidth As Double, s1 As Shape, LeftS As Long, TopS As Long, filter As ExportFilter sizeHeight = 70: sizeWidth = 100: LeftS = 1: TopS = 1 DrawShape sizeHeight, sizeWidth, LeftS, TopS, "Rectangle", "PictureDr" End Sub Private Sub btDrawCircle_Click() 'Create elipse Dim sizeHeight As Double, sizeWidth As Double, LeftS As Long, TopS As Long sizeHeight = 70: sizeWidth = 70: LeftS = 100: TopS = 1 DrawShape sizeHeight, sizeWidth, LeftS, TopS, "Circle", "PictureDr1" End Sub Function DrawShape(sizeHeight As Double, sizeWidth As Double, LeftS As Long, TopS As Long, shCaption As String, Optional name As String) Dim filter As ExportFilter, s1 As Shape If shCaption = "Circle" Then 'create the shape on the active document and export it as bitmap Set s1 = ActiveDocument.Pages(1).Layers("Layer 1").CreateEllipse(LeftS, ActivePage.sizeHeight - TopS, _ ActivePage.sizeWidth - LeftS - sizeWidth, ActivePage.TopY - (TopS + sizeHeight)) s1.Fill.ApplyFountainFill CreateRGBColor(0, 255, 0), CreateRGBColor(0, 0, 0) Set filter = ActiveDocument.ExportBitmap(pathToSave & "TestDrawCircle.gif", cdrGIF, cdrSelection, _ cdrRGBColorImage, sizeWidth, sizeHeight, 300, 300) ElseIf shCaption = "Rectangle" Then Set s1 = ActiveDocument.Pages(1).Layers("Layer 1").CreateRectangle(LeftS, ActivePage.sizeHeight - TopS, _ ActivePage.sizeWidth - LeftS - sizeWidth, ActivePage.TopY - (TopS + sizeHeight)) s1.Fill.ApplyFountainFill CreateRGBColor(255, 0, 0), CreateRGBColor(0, 0, 0) Set filter = ActiveDocument.ExportBitmap(pathToSave & "TestDraw.jpg", cdrJPEG, cdrSelection, _ cdrRGBColorImage, sizeWidth, sizeHeight, 300, 300) ElseIf shCaption = "Line" Then Set s1 = ActiveDocument.ActiveLayer.CreateLineSegment(LeftS, TopS, sizeHeight, sizeWidth) s1.Outline.SetProperties Color:=CreateRGBColor(255, 0, 0) s1.Outline.Width = 3 Set filter = ActiveDocument.ExportBitmap(pathToSave & "TestLine.gif", cdrGIF, cdrSelection, _ cdrRGBColorImage, sizeWidth, sizeHeight, 300, 300) End If filter.Finish s1.Delete For Each ctl In frmTestDraw.Controls 'delete the shape from the active document page If ctl.name = name Then frmTestDraw.Controls.Remove name: Exit For End If Next Set lb = frmTestDraw.Controls.Add("Forms.Label.1", name, Visible) 'adding the label on the form With lb lb.Height = sizeHeight lb.Width = sizeWidth lb.Left = LeftS lb.Top = TopS lb.Caption = shCaption lb.AutoSize = False End With If name = "PictureDr1" Then 'selecting the way to load the appropriate picture... frmTestDraw!PictureDr1.Picture = LoadPicture(pathToSave & "TestDrawCircle.gif") frmTestDraw!PictureDr1.PicturePosition = fmPicturePositionBelowCenter ElseIf name = "PictureDr" Then frmTestDraw!PictureDr.Picture = LoadPicture(pathToSave & "TestDraw.jpg") frmTestDraw!PictureDr.PicturePosition = fmPicturePositionBelowCenter ElseIf name = "PictureDL" Then frmTestDraw!PictureDL.Picture = LoadPicture(pathToSave & "TestLine.gif") frmTestDraw!PictureDL.PicturePosition = fmPicturePositionBelowCenter End If End Function Private Sub UserForm_Initialize() pathToSave = Environ$("Temp") 'initialize the variable in a location where UAC allows saving for everybody... End Sub
I tried some comments but I think the code is easy to be understood...
Thank U very much!