Cell Location of A Shape

[afalifi]

Hello everyone,

I learnt lots of things from this forum and finally signed up.

I will try to explain what I want to do and what is the problem.

I have a picture in excel sheet and there are equal grids on the picture. ( Pic is gridded with worksheets gridlines) Macro starts if user click on the pic. In this point, I am getting coordinates of the cursor and I know where user clicked. After it, macro copies a prepared shape and puts it to where user clicks.

At this point, I need to know, on which cell is shape located. I found out a code "topleftcell.address" but, It doesn't work correctly. When user clicks an area near corners (especially topleftcorner of grid), code turns with wrong address. I need exactly, "on which cell is shape's center located".

As you see on the picture when I click on the near top left corner of F3, it returns with E3 (You can see the result at M1)
It must return with F3 , that is what I want.

I hope I could explain my problem. Thanks for help.

That is the code I use:

Sub Rectangle7_Click()    Dim hdc As Long
    Dim PointsPerPixelX As Double, PointsPerPixelY As Double
    Dim CursorPos As POINTAPI
    Dim ExcelPos As POINTAPI
    Dim ShapePos As POINTAPI
    Dim a, b As Long
    
    '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
    
    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 '- SHAPE_WIDTH / 2
    ShapePos.Y = (CursorPos.Y - ExcelPos.Y) * PointsPerPixelY '- SHAPE_HEIGHT / 2
       


    Application.ActiveSheet.Shapes("Oval 2").Select
     With Selection


   
    .Left = ShapePos.X - 2
    .Top = ShapePos.Y - 2
   
   
    End With
   
  
    Range("m1") = Selection.TopLeftCell.Address
    






End Sub

 

[skorpionkz]

Hi afalifi,

I'm not sure how to do code to repeat mouse click, but my idea is,
1. copy format of whole sheet to new temporary sheet
2. repeat mouse click of recorded location on the temporary sheet
3. check address of selected cell

 

[Jon Peltier]

So do a little algebra.

Top left cell: E3. So the center of the shape is in column E or further right and in row 3 or further down.

Center of shape = shape.left + shape.width / 2, shape.top + shape.height / 2

Width of A:E = Range("A:A").Resize(shape.topleftcell.column).Width

If center of shape < width of A:E, then center of shape is in column E

If not, width of A:F = Range("A:A").Resize(shape.topleftcell.column + 1).Width

keep going until center of shape < width (columns).

Same for rows....

 

[afalifi]

Hi afalifi,

I'm not sure how to do code to repeat mouse click, but my idea is,
1. copy format of whole sheet to new temporary sheet
2. repeat mouse click of recorded location on the temporary sheet
3. check address of selected cell

Thanks for answer skorpionkz,

I thought like you too but I could not repeat mouse click with code in temporary sheet.

 

[afalifi]

So do a little algebra.

Top left cell: E3. So the center of the shape is in column E or further right and in row 3 or further down.

Center of shape = shape.left + shape.width / 2, shape.top + shape.height / 2

Width of A:E = Range("A:A").Resize(shape.topleftcell.column).Width

If center of shape < width of A:E, then center of shape is in column E

If not, width of A:F = Range("A:A").Resize(shape.topleftcell.column + 1).Width

keep going until center of shape < width (columns).

Same for rows....

Hi Jon Peltier,
Thanks for your answer. I will give a try.

 

[afalifi]

So do a little algebra.

Top left cell: E3. So the center of the shape is in column E or further right and in row 3 or further down.

Center of shape = shape.left + shape.width / 2, shape.top + shape.height / 2

Width of A:E = Range("A:A").Resize(shape.topleftcell.column).Width

If center of shape < width of A:E, then center of shape is in column E

If not, width of A:F = Range("A:A").Resize(shape.topleftcell.column + 1).Width

keep going until center of shape < width (columns).

Same for rows....

Hi jon peltier,

Thank you so much, It works. This is how I did it.

   i = 1   centerofshapey = Selection.Left + Selection.Width / 2
   centerofshapex = Selection.Top + Selection.Height / 2


    widthofrange = Range("A:A").Resize(Selection.TopLeftCell.Column).Width
If centerofshapey < widthofrange Then
    centerofshapeyloc = Selection.TopLeftCell.Column
Else
Do While centerofshapey > widthofrange
    widthofrange = Range(Cells(1, 1), Cells(1, i + 1)).Resize(Selection.TopLeftCell.Column + i).Width
    colno = i + 1
    i = i + 1
Loop
centerofshapeyloc = colno




End If


i = 1
    heightofrange = Range("A:A").Resize(Selection.TopLeftCell.Row).Height
If centerofshapex < heightofrange Then
    centerofshapexloc = Selection.TopLeftCell.Row
Else
Do While centerofshapex > heightofrange
    heightofrange = Range(Cells(1, 1), Cells(i + 1, 1)).Height
    rowno = i + 1
    i = i + 1
Loop
centerofshapexloc = rowno




End If


   
   Cells(centerofshapexloc, centerofshapeyloc).Select
  
    Range("m1") = ActiveCell.Address