vbRichClient Cairo - How to get a clipping like this

[Resurrected]

Basically if I have the 4 coordinates marked in blue, the problem will just be solved, but I don't know how. I can't find much useful information in the object viewer...

[LaVolpe]

So, you want the coordinates of the rectangle based from the blue coordinates? If so, you can test each blue coordinate something like this:

Dim X as Long, Y as Long, cX as Long, cY as long  ' cx & cy are your right & bottom rectangle edges
Dim pts As Long, coords(0 to 3) As POINTAPI ' or whatever data structure those blue coords are in
    X = coords(0).X: Y = coords(0).Y: cX = X: cY = Y  ' initialize
    For pts = 1 To 3  ' test the other 3 coords
        If coords(pts).X < X Then 
            X = coords(pts).X
        ElseIf coords(pts).X > cX Then
            cX = coords(pts).X
        End If
        If coords(pts).Y < Y Then 
            Y = coords(pts).Y
        ElseIf coords(pts).Y > cY Then
            cY = coords(pts).Y
        End If
    Next

When the loop finishes you should have the bounding rectangle

[Steve Grant]

Funny! The way I read the OP is that they want you to give the coords of the blue spots.

[passel]

I read it that way too. It sounds like he wants to be able to auto-crop something by finding the extreme edges of the image, i.e. some sort of edge detection perhaps.

[Schmidt]

Basically if I have the 4 coordinates marked in blue, the problem will just be solved, but I don't know how. I can't find much useful information in the object viewer...

In case this is about detecting the bounds of the "Inner-Image" on top of a relative constant BackColor,
then you can do that with an appropriate Pixel-Analysis on the Cairo-Surface in question...
(which should be of type 'ImageSurface' then, based on a Pixel-allocation - but that's usually the default)

I've explained the built-in Pixel-Functions of the RC5-Cairo-Wrapper already here in a small example:
http://www.vbforums.com/showthread.p...airo-Surfaces)

But in your case, I guess you will *not* need to run an Edge-detection-algo in a first step -
instead (when your BG-Color is constant), you can try a much simpler algo first, which the following Demo explains...

Into an empty Form-Project (project needs a reference to vbRichClient5)

Option Explicit

Private Srf As cCairoSurface, x1 As Long, y1 As Long, x2 As Long, y2 As Long

Private Sub Form_Load()
  AutoRedraw = True: ScaleMode = vbPixels: BackColor = &H888888
  WriteDemoImage 'write a tst.bmp and load it into a CairoSurface in the following line
  Set Srf = Cairo.CreateSurface(0, 0, ImageSurface, New_c.FSO.GetTmpPath & "tst.bmp")

  Set Picture = Srf.Picture 'visualize the loaded Test-Surface on the Form
 
  FindBoundingRect Srf, x1, y1, x2, y2, 0 '<- note, or play around with the optional Margin-Param
  Debug.Print x1, y1, x2, y2
  
  DrawWidth = 5 'report the two Points we have found (TopLeft and BottomRight-Points)
    PSet (x1, y1), vbBlue
    PSet (x2, y2), vbBlue
  Refresh
  Caption = "Click Me, to Cut out the detected inner-region"
End Sub

Private Sub WriteDemoImage() 'this creates a simple Test-Bitmap (written out into the temp-folder)
  Dim Pic As VB.PictureBox
  Set Pic = Controls.Add("VB.PictureBox", "Pic")
      Pic.BorderStyle = 0: Pic.ScaleMode = vbPixels: Pic.AutoRedraw = True: Pic.BackColor = vbWhite
      Pic.Move 0, 0, 200, 200
      Pic.Line (100, 50)-(150, 100), vbRed
      Pic.Line (150, 100)-(100, 150), vbRed
      Pic.Line (100, 150)-(50, 100), vbRed
      Pic.Line (50, 100)-(100, 50), vbRed
  SavePicture Pic.Image, New_c.FSO.GetTmpPath & "tst.bmp"
End Sub

Private Sub Form_Click() 'demonstrates a Blit-Operation into a second Cairo-Surface
  Set Picture = GetClipSurfaceFrom(Srf, x1, y1, x2 - x1 + 1, y2 - y1 + 1).Picture
End Sub

Private Function GetClipSurfaceFrom(Srf As cCairoSurface, x, y, dx, dy) As cCairoSurface
  With Cairo.CreateSurface(dx, dy).CreateContext 'create a Surface in the new Size (along with a Context)
       .SetSourceSurface Srf, -x, -y 'set the outer, original Surface as the Blit-Source
       .Paint 'paint onto our new (somewhat smaller) Surface from the (offset-shifted) Source
    Set GetClipSurfaceFrom = .Surface 'return the new Surface directly from its context
  End With
End Function

Private Sub FindBoundingRect(Srf As cCairoSurface, x1, y1, x2, y2, Optional ByVal Margin As Long)
Dim PCmp As Long, Pxls() As Long, x As Long, y As Long
  If Not Srf.BindToArrayLong(Pxls) Then Err.Raise vbObjectError, , "Unable to bind Pixel-Array"
  
  PCmp = Pxls(0, 0) 'in this simple demo, we assume that the Compare-Color can be found in the TopLeft-Pixel
  
  x1 = 0
    For x = 0 To UBound(Pxls, 1): For y = 0 To UBound(Pxls, 2)
      If Pxls(x, y) <> PCmp Then x1 = x - Margin: GoTo 1
    Next y, x
1 If x1 < 0 Then x1 = 0
  
  y1 = 0
    For y = 0 To UBound(Pxls, 2): For x = 0 To UBound(Pxls, 1)
      If Pxls(x, y) <> PCmp Then y1 = y - Margin: GoTo 2
    Next x, y
2 If y1 < 0 Then y1 = 0
  
  x2 = UBound(Pxls, 1)
    For x = UBound(Pxls, 1) To 0 Step -1: For y = 0 To UBound(Pxls, 2)
      If Pxls(x, y) <> PCmp Then x2 = x + Margin: GoTo 3
    Next y, x
3 If x2 > UBound(Pxls, 1) Then x2 = UBound(Pxls, 1)
  
  y2 = UBound(Pxls, 2)
    For y = UBound(Pxls, 2) To 0 Step -1: For x = 0 To UBound(Pxls, 1)
      If Pxls(x, y) <> PCmp Then y2 = y + Margin: GoTo 4
    Next x, y
4 If y2 > UBound(Pxls, 2) Then y2 = UBound(Pxls, 2)
  
  Srf.ReleaseArrayLong Pxls
End Sub
 
Private Sub Form_Terminate()
  If Forms.Count = 0 Then New_c.CleanupRichClientDll
End Sub

Here's what the above Code will produce:


HTH

Olaf

[Resurrected]

LaVolpe: When the loop finishes you should have the bounding rectangle

Thank you so much for putting out the code. It isn't what I really meant, though ...

Steve Grant: Funny! The way I read the OP is that they want you to give the coords of the blue spots.

passel: I read it that way too. It sounds like he wants to be able to auto-crop something by finding the extreme edges of the image, i.e. some sort of edge detection perhaps.

Thanks for clearing things up. My bad English.

[Resurrected]

Olaf. You almost did the job for me ...again

Private Sub FindBoundingRect(Srf As cCairoSurface, x1, y1, x2, y2, Optional ByVal Margin As Long)
Dim PCmp As Long, Pxls() As Long, x As Long, y As Long
  If Not Srf.BindToArrayLong(Pxls) Then Err.Raise vbObjectError, , "Unable to bind Pixel-Array"
  
  PCmp = Pxls(0, 0) 'in this simple demo, we assume that the Compare-Color can be found in the TopLeft-Pixel
  
  x1 = 0
    For x = 0 To UBound(Pxls, 1): For y = 0 To UBound(Pxls, 2)
      If Pxls(x, y) <> PCmp Then x1 = x - Margin: GoTo 1
    Next y, x
1 If x1 < 0 Then x1 = 0
  
  y1 = 0
    For y = 0 To UBound(Pxls, 2): For x = 0 To UBound(Pxls, 1)
      If Pxls(x, y) <> PCmp Then y1 = y - Margin: GoTo 2
    Next x, y
2 If y1 < 0 Then y1 = 0
  
  x2 = UBound(Pxls, 1)
    For x = UBound(Pxls, 1) To 0 Step -1: For y = 0 To UBound(Pxls, 2)
      If Pxls(x, y) <> PCmp Then x2 = x + Margin: GoTo 3
    Next y, x
3 If x2 > UBound(Pxls, 1) Then x2 = UBound(Pxls, 1)
  
  y2 = UBound(Pxls, 2)
    For y = UBound(Pxls, 2) To 0 Step -1: For x = 0 To UBound(Pxls, 1)
      If Pxls(x, y) <> PCmp Then y2 = y + Margin: GoTo 4
    Next x, y
4 If y2 > UBound(Pxls, 2) Then y2 = UBound(Pxls, 2)
  
  Srf.ReleaseArrayLong Pxls
End Sub

The FindBoundingRect subroutine is very concise, far better than my own implementation which I'd rather not post here. How can you guys make those complex algos, by picturing a matrix inside the head, and then moving a point through it or something? My head will get spinning after just a short time. I honestly don't know how to do this correctly. I am so sorry.

[Resurrected]

The following are two helper functions I use to determine match of a pixel:

Public Function IsColorMatched(lColor As Long, R As Long, G As Long, B As Long, Optional Approx As Long = 0) As Boolean
    Dim CurR&, CurG&, CurB&
    LongToRGB lColor, CurR&, CurG&, CurB&
    If Approx > 0 Then
        If Not (CurR + Approx >= R And CurR - Approx <= R) Then Exit Function
        If Not (CurG + Approx >= G And CurG - Approx <= G) Then Exit Function
        If Not (CurB + Approx >= B And CurB - Approx <= B) Then Exit Function
    Else
        If CurR <> R Then Exit Function
        If CurG <> G Then Exit Function
        If CurB <> B Then Exit Function
    End If
    IsColorMatched = True
End Function
Public Sub LongToRGB(ByVal lColor As Long, ByRef lRed As Long, ByRef lGreen As Long, ByRef lBlue As Long)
    lRed = (lColor And &HFF0000) \ &H10000
    lGreen = (lColor And &HFF00&) \ &H100&
    lBlue = lColor And &HFF
End Sub

When I need an exact pixel match, I set Approx to 0; Otherwise, I set Approx to a value bigger than 0, creating a range of for the match. In Olaf's example, the pixel value has to be an exact value:

If Pxls(x, y) <> PCmp Then

Pxls is an array of Longs, produced by Srf.BindToArrayLong. I don't know how to create a range for the color represented by a long value, so I split the long into RGB variables first. Probably it's much more efficient to use a byte array and utilize bitwise comparison, which I don't know how, either.

[Resurrected]

There is a method Cairo objects:

Sub ColorSplit(Color As Long, [R As Double], [G As Double], [B As Double], [Shade As Double = 1], [b_R As Byte], [b_G As Byte], [b_B As Byte])

I can't get correct R, G, B doubles out of it. I thought param R,G,B should be the passing out values? When and how is this method used?

[jpbro]

I tried ColorSplit here and it seems to work fine. Remember, in Cairo R G and B values floating point numbers ranging from 0 to 1, so for example:

ColorSplit vbRed, R, G, B

will set R to 1, and G and B to 0.

You can get a colour value from 0 to 255 (for use in the VB RGB function for example) by multiplying your ColorSplit result variables by 255.

[Resurrected]

You can get a colour value from 0 to 255 (for use in the VB RGB function for example) by multiplying your ColorSplit result variables by 255.

That helps

[Schmidt]

That helps

BTW, the function can also hand-out normal ByteValues, when you fill-in the last 3 optional ByRef-Params:

Private Sub Form_Load()
  Static D(0 To 2) As Double
  Cairo.ColorSplit vbWhite, D(0), D(1), D(2)
  Debug.Print D(0), D(1), D(2)
  
  Static B(0 To 2) As Byte
  Cairo.ColorSplit vbWhite, , , , , B(0), B(1), B(2)
  Debug.Print B(0), B(1), B(2)
End Sub

The above printing-out:

 1             1             1 
 255           255           255

As for writing an extra-Function for the tolerant Pixel-Comparison (which in turn calls even more functions inside) -
that'd be a showstopper with regards to performance (there's images which might have millions of Pixels).

To keep it speedy, one should precalculate a lookup-table (a simple array) with all the possible results
for each of the 4 Color-Channels (B, G, R and A). This is a comparably small loop, which fills up an
Array of 4*256=1024 Values (one can use a ByteArray to store these 1024 Boolean-Values as 0 and 1).

After such an Array is precalculated, the inner loops for the Pixel-comparisons will remain very fast
(an Array-Lookup is significantly faster than a function-call).

Here's the performance-optimized routine again:

Option Explicit

Private Srf As cCairoSurface, x1 As Long, y1 As Long, x2 As Long, y2 As Long

Private Sub Form_Load()
  AutoRedraw = True: ScaleMode = vbPixels: BackColor = &H888888
  WriteDemoImage 'write a tst.bmp and load it into a CairoSurface in the following line
  Set Srf = Cairo.CreateSurface(0, 0, ImageSurface, New_c.FSO.GetTmpPath & "tst.bmp")
 
  Set Picture = Srf.Picture 'visualize the loaded Test-Surface on the Form
  
  If MsgBox("Compare without Tolerance?", vbYesNo) = vbYes Then
    FindBoundingRect Srf, x1, y1, x2, y2, 0 '<- note the margin-parameter
  Else 'we compare with a tolerance of 35, to "ignore" the greyish area...
    FindBoundingRect Srf, x1, y1, x2, y2, 0, 35, 255, 255, 255, 255 'using plain white as the Compare-Color
  End If
  
  Debug.Print x1, y1, x2, y2
  
  DrawWidth = 5 'report the two Points we have found (TopLeft and BottomRight-Points)
    PSet (x1, y1), vbBlue
    PSet (x2, y2), vbBlue
  Refresh
  Caption = "Click Me, to Cut out the detected inner-region"
End Sub

Private Sub WriteDemoImage() 'this creates a simple Test-Bitmap (written out into the temp-folder)
  Dim Pic As VB.PictureBox
  Set Pic = Controls.Add("VB.PictureBox", "Pic")
      Pic.BorderStyle = 0: Pic.ScaleMode = vbPixels: Pic.AutoRedraw = True: Pic.BackColor = vbWhite
      Pic.Move 0, 0, 200, 200
      Pic.Line (25, 25)-(175, 175), &HDDDDDD, BF
      Pic.Line (100, 50)-(150, 100), vbRed
      Pic.Line (150, 100)-(100, 150), vbRed
      Pic.Line (100, 150)-(50, 100), vbRed
      Pic.Line (50, 100)-(100, 50), vbRed
  SavePicture Pic.Image, New_c.FSO.GetTmpPath & "tst.bmp"
End Sub

Private Sub Form_Click() 'demonstrates a Blit-Operation into a second Cairo-Surface
  Set Picture = GetClipSurfaceFrom(Srf, x1, y1, x2 - x1 + 1, y2 - y1 + 1).Picture
End Sub

Private Function GetClipSurfaceFrom(Srf As cCairoSurface, x, y, dx, dy) As cCairoSurface
  With Cairo.CreateSurface(dx, dy).CreateContext 'create a Surface in the new Size (along with a Context)
       .SetSourceSurface Srf, -x, -y 'set the outer, original Surface as the Blit-Source
       .Paint 'paint onto our new (somewhat smaller) Surface from the (offset-shifted) Source
    Set GetClipSurfaceFrom = .Surface 'return the new Surface directly from its context
  End With
End Function

Private Sub FindBoundingRect(Srf As cCairoSurface, x1, y1, x2, y2, _
            Optional ByVal Margin As Long, Optional ByVal Tolerance_0_to_100 As Long = 10, _
            Optional ByVal R& = -1, Optional ByVal G& = -1, Optional ByVal B& = -1, Optional ByVal A& = -1)
  
  Dim PCmp(0 To 3, 0 To 255) As Byte, Pxls() As Byte, x As Long, y As Long, i As Long
  If Not Srf.BindToArray(Pxls) Then Err.Raise vbObjectError, , "Unable to bind Pixel-Array"

  If Tolerance_0_to_100 < 0 Then Tolerance_0_to_100 = 0
  If Tolerance_0_to_100 > 100 Then Tolerance_0_to_100 = 100
  
  'when no BGRA-Values were given, we use the components of the TopLeft-Pixel for Color-Range-comparisons
  If B = -1 Then B = Pxls(0, 0)
  If G = -1 Then G = Pxls(1, 0)
  If R = -1 Then R = Pxls(2, 0)
  If A = -1 Then A = Pxls(3, 0)
  
  'now we fill a lookup-table (prior to the Pixel-Loops) to speed-up the comparisons
  For i = 0 To 255
    If Abs(B - i) > Tolerance_0_to_100 Then PCmp(0, i) = 1
    If Abs(G - i) > Tolerance_0_to_100 Then PCmp(1, i) = 1
    If Abs(R - i) > Tolerance_0_to_100 Then PCmp(2, i) = 1
    If Abs(A - i) > Tolerance_0_to_100 Then PCmp(3, i) = 1
  Next i
  
  x1 = 0
    For x = 0 To UBound(Pxls, 1): For y = 0 To UBound(Pxls, 2)
      If PCmp(x And 3, Pxls(x, y)) Then x1 = x - Margin * 4: GoTo 1
    Next y, x
1 If x1 < 0 Then x1 = 0 Else x1 = x1 \ 4
  
  y1 = 0
    For y = 0 To UBound(Pxls, 2): For x = x1 * 4 To UBound(Pxls, 1)
      If PCmp(x And 3, Pxls(x, y)) Then y1 = y - Margin: GoTo 2
    Next x, y
2 If y1 < 0 Then y1 = 0
  
  x2 = UBound(Pxls, 1)
    For x = UBound(Pxls, 1) To x1 * 4 Step -1: For y = y1 To UBound(Pxls, 2)
      If PCmp(x And 3, Pxls(x, y)) Then x2 = x + Margin * 4: GoTo 3
    Next y, x
3 If x2 > UBound(Pxls, 1) Then x2 = UBound(Pxls, 1) \ 4 Else x2 = x2 \ 4
  
  y2 = UBound(Pxls, 2)
    For y = UBound(Pxls, 2) To y1 Step -1: For x = x1 * 4 To x2 * 4
      If PCmp(x And 3, Pxls(x, y)) Then y2 = y + Margin: GoTo 4
    Next x, y
4 If y2 > UBound(Pxls, 2) Then y2 = UBound(Pxls, 2)
 
  Srf.ReleaseArray Pxls
End Sub
 
Private Sub Form_Terminate()
  If Forms.Count = 0 Then New_c.CleanupRichClientDll
End Sub

HTH

Olaf