Rows in image match with sheet rows height

[bilalrcc]

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

do

 

[Worf]

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?

 

[bilalrcc]

Yes that's awesome.

 

[Worf]

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”.

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

 

[bilalrcc]

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?

 

[Worf]

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”.