Adding shape at poistion of mouse click

Some videos you may like

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
7,842
Office Version
2016
Platform
Windows
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
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,266
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.
The code works for me on Excel 2019 if I change the class name to "F3 Server 5ac30000".
 

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
7,842
Office Version
2016
Platform
Windows
The code works for me on Excel 2019 if I change the class name to "F3 Server 5ac30000".
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
 

NomanAziz

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

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
7,842
Office Version
2016
Platform
Windows
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.
I am glad we got this sorted and thanks for the feedback... Thanks also to John_w for testing
 

Watch MrExcel Video

Forum statistics

Threads
1,099,052
Messages
5,466,289
Members
406,474
Latest member
osama beskales

This Week's Hot Topics

Top