Adding shape at poistion of mouse click

N

NomanAziz

New Member
Joined
Jun 3, 2020
Messages
7
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
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


VBA Code: 
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
 
Sort by date Sort by votes

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
If that code doesn't work for you, try this less sophisticated but simpler alternative (no api calls):

Alternative code example workbook

In the worksheet module:
VBA Code: 
Option Explicit

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)

    Dim oShape As Shape
   
    image.Visible = False
    image.Visible = True
    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 Sub
 
Upvote 0
Jaafar Tribak said:
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.
Click to expand...
The code works for me on Excel 2019 if I change the class name to "F3 Server 5ac30000".
 
Upvote 0
John_w said:
The code works for me on Excel 2019 if I change the class name to "F3 Server 5ac30000".
Click to expand...

Thanks John for looking into this.

In fact, after further investigation, I found that the class name of this secret window can change depending on the excel version... Actually, this class name seems to also change even from one excel session to another within the same excel version.

The part that changes in the class name is the last section "5ac30000"... This being the case, we cannot reliably use FindWindowEx for retrieving the hwnd .

Now, since the Z order of this window seems to remain always the same (It is the lowest in the Z order of all "EXCEL7" child windows), we can conviniently use the GetWindow API for retrieving its Hwnd.

Based on the above facts, we can therefore alter the code in post#9 as follows and in theory, it should now work consistently :

Workbook Example (Version 3)


Code in the Worksheet Module:
VBA Code: 
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 GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) 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 GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) 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 GW_CHILD = 5
    Const GW_HWNDLAST = 1
    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 = GetNextWindow(GetNextWindow(hwnd, GW_CHILD), GW_HWNDLAST)

    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
 
Upvote 0
Jaafar Tribak said:
Thanks John for looking into this.

In fact, after further investigation, I found that the class name of this secret window can change depending on the excel version... Actually, this class name seems to also change even from one excel session to another within the same excel version.

The part that changes in the class name is the last section "5ac30000"... This being the case, we cannot reliably use FindWindowEx for retrieving the hwnd .

Now, since the Z order of this window seems to remain always the same (It is the lowest in the Z order of all "EXCEL7" child windows), we can conviniently use the GetWindow API for retrieving its Hwnd.

Based on the above facts, we can therefore alter the code in post#9 as follows and in theory, it should now work consistently :

Workbook Example (Version 3)


Code in the Worksheet Module:
VBA Code: 
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 GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) 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 GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) 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 GW_CHILD = 5
    Const GW_HWNDLAST = 1
    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 = GetNextWindow(GetNextWindow(hwnd, GW_CHILD), GW_HWNDLAST)

    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
Click to expand...
Thanks Jaafar for the delay in responding. It was a Weekend in Dubai so took a day off. This code works perfectly. I consider myself as someone who knew just enough in Excel vba to get by, I am simply blown away by your skills. I really appreciate it.
 
Upvote 0
NomanAziz said:
Thanks Jaafar for the delay in responding. It was a Weekend in Dubai so took a day off. This code works perfectly. I consider myself as someone who knew just enough in Excel vba to get by, I am simply blown away by your skills. I really appreciate it.
Click to expand...

I am glad we got this sorted and thanks for the feedback... Thanks also to John_w for testing
 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
278
huiettcm
H
B
  • Question
Autosize combobox object suddenly crashes Excel
Replies
6
Views
434
alexofrhodes
alexofrhodes
Jaafar Tribak
  • Question
Date Input Mask ( Applying a Watermark to TextBox)
Replies
9
Views
2K
Davmacrat
Davmacrat
Jaafar Tribak
  • Question
Round Buttons on UserForm (Beveled + Clickable + Tab-able)
2
Replies
17
Views
2K
Jaafar Tribak
Jaafar Tribak
M
  • Question
Need to add _AfterUpdate events to a dynamically-created class
Replies
1
Views
884
Matrovsky
M

Forum statistics

Threads
1,214,651
Messages
6,120,738
Members
448,988
Latest member
BB_Unlv

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top