-
Apr 21st, 2017, 08:35 PM
#1
Thread Starter
Lively Member
vbRichClient Cairo - How to get a clipping like this
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...
-
Apr 21st, 2017, 08:46 PM
#2
Re: vbRichClient Cairo - How to get a clipping like this
So, you want the coordinates of the rectangle based from the blue coordinates? If so, you can test each blue coordinate something like this:
Code:
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
-
Apr 22nd, 2017, 07:53 AM
#3
Re: vbRichClient Cairo - How to get a clipping like this
Funny! The way I read the OP is that they want you to give the coords of the blue spots.
-
Apr 22nd, 2017, 08:15 AM
#4
Re: vbRichClient Cairo - How to get a clipping like this
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.
-
Apr 22nd, 2017, 09:56 AM
#5
Re: vbRichClient Cairo - How to get a clipping like this
Originally Posted by 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...
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)
Code:
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
-
Apr 24th, 2017, 04:53 AM
#6
Thread Starter
Lively Member
Re: vbRichClient Cairo - How to get a clipping like this
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.
-
Apr 24th, 2017, 05:11 AM
#7
Thread Starter
Lively Member
Re: vbRichClient Cairo - How to get a clipping like this
Olaf. You almost did the job for me ...again
Code:
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.
-
Apr 24th, 2017, 05:22 AM
#8
Thread Starter
Lively Member
Re: vbRichClient Cairo - How to get a clipping like this
The following are two helper functions I use to determine match of a pixel:
Code:
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:
Code:
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.
Last edited by Resurrected; Apr 24th, 2017 at 05:25 AM.
-
Apr 24th, 2017, 05:28 AM
#9
Thread Starter
Lively Member
Re: vbRichClient Cairo - How to get a clipping like this
There is a method Cairo objects:
Code:
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?
-
Apr 24th, 2017, 08:31 AM
#10
Re: vbRichClient Cairo - How to get a clipping like this
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.
-
Apr 24th, 2017, 09:05 PM
#11
Thread Starter
Lively Member
Re: vbRichClient Cairo - How to get a clipping like this
Originally Posted by jpbro
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
-
Apr 25th, 2017, 03:18 PM
#12
Re: vbRichClient Cairo - How to get a clipping like this
Originally Posted by Resurrected
That helps
BTW, the function can also hand-out normal ByteValues, when you fill-in the last 3 optional ByRef-Params:
Code:
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:
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:
Code:
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
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|