Rows in image match with sheet rows height

B

bilalrcc

New Member
Joined
Dec 21, 2017
Messages
8
I need to adjust the row height of sheet according to a table shown in a picture. Please let me know the possibilities of what I am trying to is making any sense to you?

I have attached visuals for explaining more accurately that what I want to
qw5ZJGmQl0jb
do
qw5ZJGmQl0jb
qw5ZJGmQl0jb

2017-12-21_1433.png
 

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.
Sort by date Sort by votes
Welcome to the Board

A picture is not very clickable. Where does this table come from? Could it be a real table instead?
 
Upvote 0
Thank you very much @Worf for replying and welcoming

This table is extracted from a pdf as image and copied or imported into the excel.

I need to adjust nearest excel row's height when a user clicks on the horizontal line of the table. I know we can get the XY location of the cursor using "user32.dll" but I think this returns the location which looks mapped from the whole screen instead of the sheet.

but I have some issues to find the row by XY coordinates and I am not entirely sure that XY is pointing the right row which height need to be changed.

s!Ar44mJhMVVz3hrcP4sdzfdtiEylq3w
2017-12-24%20%282%29.png
 
Upvote 0
Hi

See below code that will give us necessary information:

o Colour and coordinates of clicked image pixel
o Coordinates of a given worksheet cell

I will be back soon to put it together.


Code: 
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC&, ByVal x&, ByVal y&) As Long
Private Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As POINT) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd&) As Long


Private Type POINT
    x As Long
    y As Long
End Type


Sub Picture1_Click()                            ' assign this to the picture
Dim pLoc As POINT, Colour&, lDC
lDC = GetWindowDC(0)
GetCursorPos pLoc
Colour = GetPixel(lDC, pLoc.x, pLoc.y)
MsgBox "Colour: " & Colour & vbLf & "X: " & pLoc.x & vbLf & "Y: " & pLoc.y
[e90].Interior.Color = Colour
End Sub


Code: 
Private Type RECT
  Left                  As Long
  Top                   As Long
  Right                 As Long
  Bottom                As Long
End Type
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd&, ByVal hDC&) As Long
Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex&) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC&, ByVal nIndex&) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Type POINTAPI
    x As Long
    y As Long
End Type
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Function ScreenDPI&(bVert As Boolean)
Static lDPI&(1), lDC&
If lDPI(0) = 0 Then
    lDC = GetDC(0)
    lDPI(0) = GetDeviceCaps(lDC, 88&)    'horz
    lDPI(1) = GetDeviceCaps(lDC, 90&)    'vert
    lDC = ReleaseDC(0, lDC)
End If
ScreenDPI = lDPI(Abs(bVert))
End Function
Private Function PTtoPX&(Points!, bVert As Boolean)
  PTtoPX = Points * ScreenDPI(bVert) / 72
End Function


Sub GetRangeRect(ByVal rng As Range, ByRef rc As RECT)
Dim wnd As Window
Set wnd = rng.Parent.Parent.Windows(1)
With rng
    rc.Left = PTtoPX(.Left * wnd.Zoom / 100, 0) + wnd.PointsToScreenPixelsX(0)
    rc.Top = PTtoPX(.Top * wnd.Zoom / 100, 1) + wnd.PointsToScreenPixelsY(0)
    rc.Right = PTtoPX(.Width * wnd.Zoom / 100, 0) + rc.Left
    rc.Bottom = PTtoPX(.Height * wnd.Zoom / 100, 1) + rc.Top
End With
End Sub


Sub GetCoordinateXY()           ' run this one
Dim rc As RECT
GetRangeRect ActiveCell, rc
MsgBox "Left: " & rc.Left & vbLf & "Top: " & rc.Top, 64, "Active cell coordinates"
End Sub
 
Upvote 0
Sure thing.

FYI. I am using Excel 2016 and Windows 10 I had to add the PtrSafe to function.

I have created a
EJp8z2xvq5
module and assigned macro as per your instruction. I am able to get Location with the Color value previously I was doing this using "user32". For now, I am getting the compilation error for GetRangeRect.

EJp8z2xvq5

EJp8z2xvq5
EJp8z2xvq5
 
Upvote 0
The version below is the next step, it informs the corresponding worksheet row when a non-white pixel is clicked.
Place it on a new module and tell me the highlighted code line and message if you get errors.

Code: 
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC&, ByVal x&, ByVal y&) As Long
Private Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As POINT) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd&) As Long


Private Type POINT
    x As Long
    y As Long
End Type


Private Type RECT
  Left                  As Long
  Top                   As Long
  Right                 As Long
  Bottom                As Long
End Type


Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd&, ByVal hDC&) As Long
Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex&) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC&, ByVal nIndex&) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long


Private Function ScreenDPI&(bVert As Boolean)
Static lDPI&(1), lDC&
If lDPI(0) = 0 Then
    lDC = GetDC(0)
    lDPI(0) = GetDeviceCaps(lDC, 88&)    'horz
    lDPI(1) = GetDeviceCaps(lDC, 90&)    'vert
    lDC = ReleaseDC(0, lDC)
End If
ScreenDPI = lDPI(Abs(bVert))
End Function


Private Function PTtoPX&(Points!, bVert As Boolean)
  PTtoPX = Points * ScreenDPI(bVert) / 72
End Function


Sub Picture1_Click()                            ' assign this to the picture
Dim pLoc As POINT, Colour&, lDC, wnd As Window, rng As Range, rc As RECT, i%
Set wnd = ActiveCell.Parent.Parent.Windows(1)
lDC = GetWindowDC(0)
GetCursorPos pLoc
Colour = GetPixel(lDC, pLoc.x, pLoc.y)
i = 0
Set rng = wnd.VisibleRange.Cells(1, 1)
Do
    Set rng = rng.Offset(1)
    i = i + 1
    If i > 50 Then Exit Do
    GetRangeRect rng, rc
Loop While i < wnd.VisibleRange.Rows.Count And rc.Top < pLoc.y
If Colour = 16777215 Then
    MsgBox "You did not click a line."
Else
    MsgBox "The worksheet row is " & rng.Row - 1
End If
End Sub


Sub GetRangeRect(ByVal rng As Range, ByRef rc As RECT)
Dim wnd As Window
Set wnd = rng.Parent.Parent.Windows(1)
With rng
    rc.Left = PTtoPX(.Left * wnd.Zoom / 100, 0) + wnd.PointsToScreenPixelsX(0)
    rc.Top = PTtoPX(.Top * wnd.Zoom / 100, 1) + wnd.PointsToScreenPixelsY(0)
    rc.Right = PTtoPX(.Width * wnd.Zoom / 100, 0) + rc.Left
    rc.Bottom = PTtoPX(.Height * wnd.Zoom / 100, 1) + rc.Top
End With
End Sub
 
Upvote 0
The following lines of code were updated by adding the highlighted code.

Code: 
Private Declare [B]PtrSafe[/B] Function GetPixel Lib "gdi32" (ByVal hDC&, ByVal x&, ByVal y&) As Long
Private Declare [B]PtrSafe[/B] Function GetCursorPos Lib "user32" (ByRef lpPoint As POINT) As Long
Private Declare [B]PtrSafe[/B] Function GetWindowDC Lib "user32" (ByVal hwnd&) As Long




Private Type POINT
    x As Long
    y As Long
End Type




Private Type RECT
  Left                  As Long
  Top                   As Long
  Right                 As Long
  Bottom                As Long
End Type




Private Declare [B]PtrSafe[/B] Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare [B]PtrSafe [/B]Function ReleaseDC Lib "user32" (ByVal hwnd&, ByVal hDC&) As Long
Private Declare [B]PtrSafe[/B] Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex&) As Long
Private Declare [B]PtrSafe[/B] Function GetDeviceCaps Lib "gdi32" (ByVal hDC&, ByVal nIndex&) As Long
Private Declare [B]PtrSafe[/B] Function GetCurrentThreadId Lib "kernel32" () As Long




Private Function ScreenDPI&(bVert As Boolean)
Static lDPI&(1), lDC&
If lDPI(0) = 0 Then
    lDC = GetDC(0)
    lDPI(0) = GetDeviceCaps(lDC, 88&)    'horz
    lDPI(1) = GetDeviceCaps(lDC, 90&)    'vert
    lDC = ReleaseDC(0, lDC)
End If
ScreenDPI = lDPI(Abs(bVert))
End Function




Private Function PTtoPX&(Points!, bVert As Boolean)
  PTtoPX = Points * ScreenDPI(bVert) / 72
End Function




Sub Picture1_Click()                            ' assign this to the picture
Dim pLoc As POINT, Colour&, lDC, wnd As Window, rng As Range, rc As RECT, i%
Set wnd = ActiveCell.Parent.Parent.Windows(1)
lDC = GetWindowDC(0)
GetCursorPos pLoc
Colour = GetPixel(lDC, pLoc.x, pLoc.y)
i = 0
Set rng = wnd.VisibleRange.Cells(1, 1)
Do
    Set rng = rng.Offset(1)
    i = i + 1
    If i > 50 Then Exit Do
    GetRangeRect rng, rc
Loop While i < wnd.VisibleRange.Rows.Count And rc.Top < pLoc.y
If Colour = 16777215 Then
    MsgBox "You did not click a line."
Else
    MsgBox "The worksheet row is " & rng.Row - 1
End If
End Sub




Sub GetRangeRect(ByVal rng As Range, ByRef rc As RECT)
Dim wnd As Window
Set wnd = rng.Parent.Parent.Windows(1)
With rng
    rc.Left = PTtoPX(.Left * wnd.Zoom / 100, 0) + wnd.PointsToScreenPixelsX(0)
    rc.Top = PTtoPX(.Top * wnd.Zoom / 100, 1) + wnd.PointsToScreenPixelsY(0)
    rc.Right = PTtoPX(.Width * wnd.Zoom / 100, 0) + rc.Left
    rc.Bottom = PTtoPX(.Height * wnd.Zoom / 100, 1) + rc.Top
End With
End Sub

Now I am getting the excel row number but I am not sure about to which way is better to adjust height like I need to adjust the excel sheet's row height according to the XY locations or else? does that make sense?
 
Upvote 0
Adding more...
For Instance, by adding the following code I am able to adjust the height of the row but I need to match the height of that row exactly with the table's row in the picture.

Code: 
Rows(rng.Row - 1).RowHeight = 25
 
Upvote 0
Does this give you the desired precision?

Code: 
Sub Picture1_Click()                            ' assign this to the picture
Dim pLoc As POINT, Colour&, wnd As Window, rng As Range, rc As RECT, i%
Set wnd = ActiveCell.Parent.Parent.Windows(1)
GetCursorPos pLoc
Colour = GetPixel(GetWindowDC(0), pLoc.x, pLoc.y)
i = 0
Set rng = wnd.VisibleRange.Cells(1, 1)
Do
    Set rng = rng.Offset(1)
    i = i + 1
    If i > 50 Then Exit Do
    GetRangeRect rng, rc
Loop While i < wnd.VisibleRange.Rows.Count And rc.Top < pLoc.y
If Colour = 16777215 Then
    MsgBox "You did not click a line."
Else
    MsgBox "The worksheet row is " & rng.Row - 1
End If
i = 0
Set rng = rng.Offset(-2)
Do                                               ' match row with clicked image line
    i = i + 1: If i > 50 Then Exit Do
    Rows(rng.Row).RowHeight = Rows(rng.Row).RowHeight + 1
    GetRangeRect rng.Offset(1), rc
Loop While rc.Top < pLoc.y
If rc.Top > pLoc.y Then Rows(rng.Row).RowHeight = Rows(rng.Row).RowHeight - 1
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question
Setting multiple row heights in VBA
Replies
2
Views
176
Extivalis
E
M
  • Question
Merge rows instead of adjusting row height for wrapped text
Replies
0
Views
315
mortensonman
M
J
  • Solved
Adjusting Column Height/Width using VBA
Replies
4
Views
466
JP801
J
C
  • Solved
Row height problem
Replies
2
Views
775
Alex Blakenburg
A
M
  • Question
Change image and row height in response to changes in column width to maintain aspect ratio
Replies
2
Views
476
Fluff
Fluff

Forum statistics

Threads
1,214,944
Messages
6,122,392
Members
449,081
Latest member
JAMES KECULAH

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