drawing a line on a userform

[jammoca]

I know you can draw a line on a userform by providing the start and end co-ordinate of where you want it, but is it possible to have a UserForm appear on call, with the 1st co-ordinate already set (by the programmer) and the user clicks on some point of the UserForm to indicate where they want the end co-ordinate to be, and that a line would then be drawn to that point ?

 

[jammoca]

According to a VB book I've been reading, the following code should produce a red line between the following X,Y co-ordinate sets ....

Private Sub UserForm_Load()
Line1.BorderColor = RGB(255, 0, 0)
Line1.BorderWidth = 10
Line1.X1 = 500
Line1.X2 = 3000
Line1.Y1 = 700
Line1.Y2 = 1800
End Sub

The book is about 9 years old now and they were using the word 'Form' not 'UserForm', but it doesn't seem to work.

Any clues ?

 

[Andy Pope]

And is that book also a VB book rather than 1 for VBA coding?

VBA userforms do not have a builtin shape control for drawing lines or circles.

You can mimic vertical and horizontal lines by using a label with no caption and a value of 1 for the width or height.

I have an example file for using autoshape displayed as images which allows for a more rich drawing experience. Maybe this is something you could use.
http://www.andypope.info/vba/userformdraw.htm

 

[Colin Legg]

There's a tremendous example of drawing on VBA userforms (workaround using API) written by Tim Critchley here:
http://www.xtremevbtalk.com/showthread.php?t=153272

Adapt to suit your needs.

Colin

 

[jammoca]

That works really well.

What I am hoping to do is have a UserForm that has an oval permanently drawn in the centre and for a user to click on a place in the oval to indicate where a cricket ball was hit to.

A line would then automatically be drawn to that point from a point central to the oval and remain there, so when more positions where clicked on over the course of the game, a body of lines was recorded.

The various codes below, currently allow a user to left click on a spot and drag to another spot ... leaving a line in its path. How would I have to modify the various codes to do what I am looking for ?



Private Type POINTAPI_MB
X As Long
Y As Long
End Type

Private Type POINTAPI_MM
X As Long
Y As Long
End Type

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function MoveToEx_mb Lib "gdi32" Alias "MoveToEx" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI_MB) As Long
Private Declare Function MoveToEx_mm Lib "gdi32" Alias "MoveToEx" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI_MM) As Long

Dim startX_mb As Single, startY_mb As Single
Dim startX_mm As Single, startY_mm As Single
Private lngHdc As Long
Private blnDraw As Boolean
Dim p_mb As POINTAPI_MB
Dim p_mm As POINTAPI_MM


Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

'store the mouse pointer starting positions
If Button = 1 Then
startX_mb = X
startY_mb = Y
startX_mm = X
startY_mm = Y
End If

'retrieve the UserForm Window handle and use that to return its Device Context
lngHdc = GetActiveWindow
lngHdc = GetDC(lngHdc)

'permit continuous drawing
blnDraw = True

End Sub

Private Sub UserForm_Initialize()
Me.ForeColor = vbRed
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

'only draw continuously if the user wants to draw freehand
If Not Me.optFreehand Then Exit Sub
'only draw if the mouse button is held down
If Not blnDraw Then Exit Sub

'make sure it's the left mouse button
If Button = 1 Then
'supply the UDT mouse position values as pixels
p_mm.X = Get_PixelsFromPoints(startX_mm, True)
p_mm.Y = Get_PixelsFromPoints(startY_mm, False)

'pass the UDT to the API to specify where to the drawing began
MoveToEx_mm lngHdc, p_mm.X, p_mm.Y, p_mm
'pass the current mouse position to the API for drawing the line
LineTo lngHdc, Get_PixelsFromPoints(X, True), Get_PixelsFromPoints(Y, False)

're-assign the drawiing start position
startX_mm = X
startY_mm = Y
End If

End Sub

Private Sub UserForm_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

blnDraw = False

'only draw direct if the user wants to draw straight lines only
If Me.optFreehand Then Exit Sub

'draw lines direct to the current mouse position and terminate the drawing process
'same-same but different
If Button = 1 Then
p_mb.X = Get_PixelsFromPoints(startX_mb, True)
p_mb.Y = Get_PixelsFromPoints(startY_mb, False)
MoveToEx_mb lngHdc, p_mb.X, p_mb.Y, p_mb
LineTo lngHdc, Get_PixelsFromPoints(X, True), Get_PixelsFromPoints(Y, False)
End If

End Sub

 

[Joe Was]

You can draw lines on a sheet using:

Set myDocument = Worksheets(1)

With myDocument.Shapes.BuildFreeform(msoEditingCorner, x1, y1)
.AddNodes msoSegmentLine, msoEditingAuto, x2, y2
.AddNodes msoSegmentLine, msoEditingAuto, x3, y3
.AddNodes msoSegmentLine, msoEditingAuto, x1, y1
.ConvertToShape
End With

Where the variables are the x,y coordinates.

 

[jammoca]

Ok the codes below permanently places a cricket oval and a cricket pitch onto a UserForm ...

Option Explicit
' use the
Private m_objDrawing As AJPiUFDraw


Private Sub UserForm_Initialize()

Set m_objDrawing = New AJPiUFDraw
Set m_objDrawing.CanvasUserform = Me

Dim shpTemp As Shape
Dim sngXPointsCurve(2) As Single
Dim sngYPointsCurve(2) As Single

Set shpTemp = m_objDrawing.Oval(150, 150, 90, 100)
If Not shpTemp Is Nothing Then shpTemp.Fill.ForeColor.RGB = RGB(255, 255, 0)


Set shpTemp = m_objDrawing.Box(135, 125, 30, 55)
If Not shpTemp Is Nothing Then shpTemp.Fill.ForeColor.SchemeColor = 1

m_objDrawing.Paint

End Sub

I still need to find a way to allow a user to click on any point in the oval and a line be drawn to that point from position X = 148, Y = 169

 

[Andy Pope]

You need to add a control to capture the mouse events.
Add a image control, call it imgStrokes. Set transparent and size 400x200

Option Explicit
' use the
Private m_objDrawing As AJPiUFDraw
Private m_sngDownX As Single
Private m_sngDownY As Single

Private Sub UserForm_Initialize()

    Dim shpTemp As Shape
    
    Set m_objDrawing = New AJPiUFDraw
    Set m_objDrawing.CanvasUserform = Me
    
    Set shpTemp = m_objDrawing.Oval(200, 100, 200, 100)
    If Not shpTemp Is Nothing Then shpTemp.Fill.ForeColor.RGB = RGB(0, 255, 0)
    
    m_objDrawing.Paint
    
End Sub
Private Sub imgStrokes_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

    If Button = 1 Then
        m_sngDownX = X
        m_sngDownY = Y
    End If

End Sub
Private Sub imgStrokes_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

    Dim shpTemp As Shape
    
    If Button = 1 Then
        ' draw line from left crease to here
        Set shpTemp = m_objDrawing.Line(m_sngDownX, m_sngDownY, X, Y)
        If Not shpTemp Is Nothing Then
            shpTemp.Line.Weight = 1
            shpTemp.Line.ForeColor.RGB = 0
        End If
        m_objDrawing.Paint
        DoEvents
    End If

End Sub

when running click start point, drag mouse to finish point.
This should give you enough to adapt to your needs.

 

[jammoca]

Hey, thanks Andy,

that worked great, and I've adapted it to always start from a set point, but the lines are not finishing where I release the cursor. They aim in roughly the correct direction (but never straight at the desired point), and they seem to always be short of the mark

 

[Andy Pope]

Ensure that the image used to handle mouse events is positioned in the top left corner of the userform