Adding shape at poistion of mouse click

[NomanAziz]

I want to develop a GIS type drawing window where the user can draw circle, lines and Plines based on selection.
Additional issue is the user can only draw on top of a picture (used as background).

I have been searching for a code that i can use specifically to solve the problem of inserting a shape at the mouse cursor location on top of an image. Found the following solutions both using PointAPI:

1. Range is selected under the pic and shape is inserted at the selected range - this works well but the image has to be made invisible very briefly to achieve it. I dont want the image to blink during the process
2. Cursor X and Y locations in excel are found using a combination of screen resolution and relative position of cursor in Excel window - This is closer to what i want as i am not having to select a range but the issue is the shape is not inserted at the precise location. Its some distance away. This distance increases when i click further away from the top left of the image. I found some zoom corrections but none of them seems to work perfectly.

Here is the code that I copied from a couple of different forums. Can anyone please look at it to see what i can do to it to make it work perfectly.

Thanks

Option Explicit

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Private Type POINTAPI
    x As Long
    y As Long
End Type

'GetDeviceCaps function
'http://msdn.microsoft.com/en-us/library/windows/desktop/dd144877%28v=vs.85%29.aspx
Private Const LOGPIXELSX As Long = 88&
Private Const LOGPIXELSY As Long = 90&

'Size of shape's bounding box in points
Private Const SHAPE_WIDTH = 5
Private Const SHAPE_HEIGHT = 5


Public Sub Add_Shape_At_Cursor_Position()

    Dim hdc As Long
    Dim PointsPerPixelX As Double, PointsPerPixelY As Double
    Dim CursorPos As POINTAPI
    Dim ExcelPos As POINTAPI
    Dim ShapePos As POINTAPI
    Dim z As Double
    
    Const LOGPIXELSX As Long = 88
    Const LOGPIXELSY As Long = 90
    
    
    'Get number of points per screen pixel, depending on screen device size
    
    hdc = GetDC(0)
    PointsPerPixelX = 72 / GetDeviceCaps(hdc, LOGPIXELSX)
    PointsPerPixelY = 72 / GetDeviceCaps(hdc, LOGPIXELSY)
    ReleaseDC 0, hdc
    
    'Scale points per pixel according to current window zoom. The smaller the zoom, the higher the number of points per pixel
    
    PointsPerPixelX = PointsPerPixelX '* 100 / ActiveWindow.Zoom
    PointsPerPixelY = PointsPerPixelY '* 100 / ActiveWindow.Zoom
    
    'Get position of Excel window in screen pixels
    
   
    z = CorrectZoomFactor(ActiveWindow.Zoom / 100)
    
    
    ExcelPos.x = ActiveWindow.PointsToScreenPixelsX(0)
    ExcelPos.y = ActiveWindow.PointsToScreenPixelsY(0)
     
    'Get mouse cursor position in screen pixels
    
    GetCursorPos CursorPos
    
    'Set shape position according to mouse position relative to Excel window position, scaled to the
    'number of points per pixel.  Since the AutoShape's position is defined by the top left corner
    'of its bounding box, subtract half the shape's size to centre it over the mouse
    
    ShapePos.x = (CursorPos.x - ExcelPos.x) * PointsPerPixelX / z - SHAPE_WIDTH / 2
    ShapePos.y = (CursorPos.y - ExcelPos.y) * PointsPerPixelY / z - SHAPE_HEIGHT / 2
       
    ActiveSheet.Shapes.AddShape msoShapeOval, ShapePos.x, ShapePos.y, SHAPE_WIDTH, SHAPE_HEIGHT

End Sub


Function CorrectZoomFactor(ByVal z As Single) As Single
Select Case z
Case 2
z = 2
Case 1.75
z = 1.765
Case 1.5
z = 1.529
Case 1.25
z = 1.235
Case 1
z = 1
Case 0.9
z = 0.882
Case 0.85
z = 0.825
Case 0.8
z = 0.82
Case 0.75
z = 0.74
Case 0.7
z = 0.705
Case 0.65
z = 0.645
Case 0.6
z = 0.588
Case 0.55
z = 0.53
Case 0.5
z = 0.5296
Case Else
z = 1.0069 * z + 0.0055
End Select
CorrectZoomFactor = z


End Function

 

[Jaafar Tribak]

Additional issue is the user can only draw on top of a picture (used as background)

Is that a background picture for the entire worksheet ? From the ribbon : PageLayout=>Background

Or is it a picture added as an image activeX control or as a shape to the worksheet ?

 

[NomanAziz]

Thanks Jaafar.
The picture is not inserted as a background - it results in tiles filling the screen and there is no way of resizing the image.
At the moment it is inserted as an Picture but i am happy to use any other method that allows me to amend the size and position of the image through macros.
The idea is that image will be used as a background to draw lines or circles. The user will first insert the image which may be an aerial image, the user will then start drawing on it.
Your help would be much appreciated.

 

[NomanAziz]

Is that a background picture for the entire worksheet ? From the ribbon : PageLayout=>Background

Or is it a picture added as an image activeX control or as a shape to the worksheet ?

Thanks Jaafar.
The picture is not inserted as a background - it results in tiles filling the screen and there is no way of resizing the image.
At the moment it is inserted as an Picture but i am happy to use any other method that allows me to amend the size and position of the image through macros.
The idea is that image will be used as a background to draw lines or circles. The user will first insert the image which may be an aerial image, the user will then start drawing on it.
Your help would be much appreciated.

 

[Jaafar Tribak]

How about the sheet zoom ? Is it going to be always fixed at 100 or will it varie ?
I gave a quick test to the code you posted and it inserts the shapes at the precise location if the zoom is 100.

 

[NomanAziz]

How about the sheet zoom ? Is it going to be always fixed at 100 or will it varie ?
I gave a quick test to the code you posted and it inserts the shapes at the precise location if the zoom is 100.

Thanks Jaafar. Yes, it seems to work at 100% zoom but is unreliable when the zoom level is changed. If there is no other way I am happy to lock the zoom so that the user doesnt change it. Do you have a quick way to do this?

 

[NomanAziz]

Here is the other method. It temporarily disables the image and selects the range under the image and then its easy to insert the shape at that location. This works perfectly for all scenarios but the only issue is that personally dont like the image disappearing and reappearing during the process. I rather the process is smooth like in the above case.

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Type POINTAPI
x As Long
y As Long
End Type

Dim sh As Shape
Sub ShapeClick()
Set sh = ActiveSheet.Shapes("Picture 91")
sh.Visible = False
Application.OnTime Now(), "getrange"
End Sub


Sub GetRange()
Dim cursorWhere As POINTAPI
Dim selected As Object
If GetCursorPos(cursorWhere) <> 0 Then
DoEvents
Set selected = ActiveWindow.RangeFromPoint(cursorWhere.x, cursorWhere.y)
If TypeName(selected) = "Range" Then 'selected.Interior.Color = vbRed
sh.Visible = True
Rad = 5
'MsgBox cursorWhere.x`

ActiveSheet.Shapes.AddShape(msoShapeOval, selected.Left, selected.Top, Rad, Rad).Select


End If

End If
End Sub

 

[Jaafar Tribak]

Your last code (post#7) not only does it make the background image disappear and reappear causing ugly flicker, it also doesn't work for inserting the shapes at the precise location of the mouse pointer because it relies on the range underneath whose Left and Top do not necessarly coincide with the mouse pointer location.

IMHO, the propper approach is the one you posted initially but just like you said, the precision fails when the zoom is different from 100.
I don't know why this is the case as the conversion from pixels to points is correct ... I'll give it a try later on and see if something can be done.

 

[Jaafar Tribak]

Workbook example

Ok- I haven't been able to figure out why the shape is not being added at the precise mouse-click location when the zoom is other than 100 despite converting screen pixels to points correctly.

But I have found another way to achieve what you want: - We are going to use an ActiveX image control for the background image and we are going to take advantage of the X Y arguments in the MouseDown event that the image control exposes ... The event X Y values are in Points and are relative to the Image not to the screen therefore it will save us the need to convert Pixels to Points and consequently the worksheet zoom issue will be solved.

Now this approach still poses a problem since the image control stubbornly hides all shapes\objects behind it After each click... I tried temporarly hiding and showing the image control but this still caused flickering.

After some investigation, I found that excel secretely creates a hidden window (class-named: "F3 Server 23a50000") every time the image is clicked . This hidden window seems to be the one responsible for bringing the image control to the front upon each click... Fortunately, I found that preventing this hidden window from being redrawn seems to solve the issue and gives good results at least in my testings... I hope this will also work for you.

https://s7.gifyu.com/images/DrawOnClick.gif

- Code goes in the module of the worksheet where the Image control is located :

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
#Else
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
#End If


Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)

    Const IMAGE_WIDTH As Single = 10
    Const IMAGE_HEIGHT As Single = 10

    Call AddShapeToImage( _
        Sheet1.Image1, msoShapeOval, vbYellow, Button, Shift, x, y, IMAGE_WIDTH, IMAGE_HEIGHT)

End Sub


Private Sub AddShapeToImage _
    (ByVal image As Object, _
    ByVal ShapeType As MsoAutoShapeType, _
    ByVal FillColor As Long, _
    ByVal Button As Integer, _
    ByVal Shift As Integer, _
    ByVal x As Single, _
    ByVal y As Single, _
    ByVal cx As Single, _
    ByVal cy As Single)

    Const WM_SETREDRAW = &HB

    #If VBA7 Then
        Dim hwnd As LongPtr
    #Else
        Dim hwnd As Long
    #End If

    Dim oShape As Shape

    hwnd = FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString)
    hwnd = FindWindowEx(hwnd, 0, "EXCEL7", vbNullString)
    hwnd = FindWindowEx(hwnd, 0, "F3 Server 23a50000", vbNullString)
    If hwnd Then
        Call SendMessage(hwnd, ByVal WM_SETREDRAW, ByVal 0, 0)
        If Button = 1 Then
            With image
                Set oShape = image.Parent.Shapes.AddShape(ShapeType, .Left + x - (cx / 2), .Top + y - (cy / 2), cx, cy)
                oShape.Fill.ForeColor.RGB = FillColor
            End With
        End If
    End If

End Sub

 

[NomanAziz]

Workbook example

Ok- I haven't been able to figure out why the shape is not being added at the precise mouse-click location when the zoom is other than 100 despite converting screen pixels to points correctly.

But I have found another way to achieve what you want: - We are going to use an ActiveX image control for the background image and we are going to take advantage of the X Y arguments in the MouseDown event that the image control exposes ... The event X Y values are in Points and are relative to the Image not to the screen therefore it will save us the need to convert Pixels to Points and consequently the worksheet zoom issue will be solved.

Now this approach still poses a problem since the image control stubbornly hides all shapes\objects behind it After each click... I tried temporarly hiding and showing the image control but this still caused flickering.

After some investigation, I found that excel secretely creates a hidden window (class-named: "F3 Server 23a50000") every time the image is clicked . This hidden window seems to be the one responsible for bringing the image control to the front upon each click... Fortunately, I found that preventing this hidden window from being redrawn seems to solve the issue and gives good results at least in my testings... I hope this will also work for you.

https://s7.gifyu.com/images/DrawOnClick.gif

- Code goes in the module of the worksheet where the Image control is located :

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
#Else
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
#End If


Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)

    Const IMAGE_WIDTH As Single = 10
    Const IMAGE_HEIGHT As Single = 10

    Call AddShapeToImage( _
        Sheet1.Image1, msoShapeOval, vbYellow, Button, Shift, x, y, IMAGE_WIDTH, IMAGE_HEIGHT)

End Sub


Private Sub AddShapeToImage _
    (ByVal image As Object, _
    ByVal ShapeType As MsoAutoShapeType, _
    ByVal FillColor As Long, _
    ByVal Button As Integer, _
    ByVal Shift As Integer, _
    ByVal x As Single, _
    ByVal y As Single, _
    ByVal cx As Single, _
    ByVal cy As Single)

    Const WM_SETREDRAW = &HB

    #If VBA7 Then
        Dim hwnd As LongPtr
    #Else
        Dim hwnd As Long
    #End If

    Dim oShape As Shape

    hwnd = FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString)
    hwnd = FindWindowEx(hwnd, 0, "EXCEL7", vbNullString)
    hwnd = FindWindowEx(hwnd, 0, "F3 Server 23a50000", vbNullString)
    If hwnd Then
        Call SendMessage(hwnd, ByVal WM_SETREDRAW, ByVal 0, 0)
        If Button = 1 Then
            With image
                Set oShape = image.Parent.Shapes.AddShape(ShapeType, .Left + x - (cx / 2), .Top + y - (cy / 2), cx, cy)
                oShape.Fill.ForeColor.RGB = FillColor
            End With
        End If
    End If

End Sub

Many thanks for your reply. I really appreciate it. Unfortunately i was unable to make it work. The code seems to work but it doesn't create the shapes. I have a feeling something goes wrong from here; "hwnd = FindWindowEx(hwnd, 0, "F3 Server 23a50000", vbNullString)" the remaining If conditions are not met. I am using Office 365.
I can send you the file but not sure if its allowed on the forum to share files. Can i send it via wetransfer?