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

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off
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

P
  • Question Question
Seeking Code / Macro to Edit Row Height
Replies
1
Views
70
rpaulson
rpaulson
Livin404
  • Question Question
Adjust height of row(s) using VBA
Replies
1
Views
320
rlv01
R
E
  • Solved
Setting multiple row heights in VBA
Replies
2
Views
842
Extivalis
E
J
  • Question Question
Macro to adjust cell heights with wrapped text
Replies
2
Views
901
Jest
J
A
  • Solved
Row Height adjusted based on content - not for a cell but for a range of cells
Replies
8
Views
128
kvsrinivasamurthy
K

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

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