Rows in image match with sheet rows height

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
 
There is a good chance that it could work like this:

o The user clicks the top table line
o The user clicks the bottom table line
o All lines in between get aligned with the worksheet rows

Would you like it this way?
 
Upvote 0

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
o The transfer code below extracts a pixel column from the image and transfers it to a worksheet named Object, along with colour numbers. It then determines the number of lines on the picture.

o Please test on your side and tell me if your lines have at least one true black pixel, as shown below.

o As written, the code works with an image named “image8” located at sheet “Plan8”.


AXwF1jL.jpg



Code:
Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As Long
    hPal As Long
End Type
Type POINTAPI
    x As Long
    y As Long
End Type
Type Size
    Width As Long
    Height As Long
End Type
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc&, ByVal hObject&) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" _
(ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc&, ByVal x&, ByVal y&) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle&, IPic As IPicture) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat%) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
 
Private Const CF_BITMAP = 2
Private Const PICTYPE_BITMAP = 1
Private Const CLR_INVALID = &HFFFF
Private Function GetPixelColorFromShape(ByVal Shp As Shape, _
ByRef Pt As POINTAPI, ByRef WidthHeight As Size) As Long
    Dim oPic As StdPicture
    Set oPic = PicFromShape(Shp)
    If oPic <> 0 Then GetPixelColorFromShape = PixelFromPoint(oPic, Pt, WidthHeight)
End Function


Private Function PixelFromPoint(ByVal Pic As StdPicture, ByRef Pt As POINTAPI, _
ByRef WidthHeight As Size) As Long
    Dim memDC As Long, tBm As BITMAP
    memDC = CreateCompatibleDC(0)
    Call SelectObject(memDC, Pic.Handle)
    Call GetObjectAPI(Pic.Handle, LenB(tBm), tBm)
    WidthHeight.Width = tBm.bmWidth - 1: WidthHeight.Height = tBm.bmHeight - 1
    PixelFromPoint = GetPixel(memDC, Pt.x, Pt.y)
    Call DeleteDC(memDC)
End Function


Private Function PicFromShape(Shp As Shape) As StdPicture
    Dim IID_IDispatch As GUID, uPicinfo As uPicDesc, IPic As StdPicture, hPtr&
    Shp.CopyPicture xlScreen, xlBitmap
    OpenClipboard 0
    hPtr = GetClipboardData(CF_BITMAP)
    CloseClipboard
    With IID_IDispatch
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
    With uPicinfo
        .Size = Len(uPicinfo)
        .Type = PICTYPE_BITMAP
        .hPic = hPtr
        .hPal = 0
    End With
    OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic
    Set PicFromShape = IPic
End Function


Sub Transfer2Sheet()
Dim PixelColor, tPt As POINTAPI, tPicSize As Size, im, jm, rng As Range, r%, f As Range, i%, rwn$
tPt.x = 23
tPt.y = 12
PixelColor = GetPixelColorFromShape(Plan8.Shapes("image8"), tPt, tPicSize)
im = tPicSize.Height
jm = tPicSize.Width
tPt.x = jm / 2
tPt.y = 1
i = 0
Application.ScreenUpdating = False
Sheets("object").Activate
For i = 1 To im
    tPt.y = i
    PixelColor = GetPixelColorFromShape(Plan8.Shapes("image8"), tPt, tPicSize)
    Cells(i, 1).Interior.Color = PixelColor
    Cells(i, 2) = Cells(i, 1).Interior.Color
Next
Application.ScreenUpdating = True
r = Range("b" & Rows.Count).End(xlUp).Row
Set rng = Range("b1:b" & r)
rwn = " "
i = 0
Set f = rng.Find(0, rng.Cells(1, 1), xlValues, xlWhole, xlByRows, xlNext)
Do
    rwn = rwn & f.Row & "  "
    Set rng = Range(f, Cells(r, 2))
    Set f = rng.Find(16777215, rng.Cells(1, 1), xlValues, xlWhole, xlByRows, xlNext)    ' find white
    Set rng = Range(f, Cells(r, 2))
    Set f = rng.Find(0, rng.Cells(1, 1), xlValues, xlWhole, xlByRows, xlNext)           ' find black
    i = i + 1
Loop While Not f Is Nothing And i < 20
MsgBox "Lines at rows " & rwn, 64, i & " lines"
End Sub
 
Upvote 0
Sorry my system was crashed I was trying to recover data, I didn't understand how should I use it should I replace the old module code with this one and reassign the macro to picture?
 
Upvote 0
o Copy the code on post #13 to a new module and run the Transfer2Sheet subroutine. The goal is to determine where the table lines are; it should work if the chosen pixel column has no black pixels outside the lines.

o As written, the code works with an image named “image8” located at sheet “Plan8”.
 
Upvote 0

Forum statistics

Threads
1,224,824
Messages
6,181,186
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

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