Posts: 723
Threads: 118
Joined: Apr 2022
Reputation:
106
Has anyone made a routine to copy a paste a non-rectangular area of the screen? Or does QB64PE have a built-in way? I'm working on a new drawing program and trying to add a feature where you can draw an enclosed area with the mouse, copy it, and paste it. Making a circle area routine was easy, but having some difficulty with the any shape one. I'm doing a polygon approach for the any shaped one, capture all the pixels inside the drawn polygon. Wondered if someone here has already made such a routine that is working.
Here's the circle copy/paste that is working ok.
- Dav
Code: (Select All)
Screen _NewImage(1000, 700, 32)
For t = 1 To 7000
Color _RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Print _Trim$(Str$(Int(Rnd * 10)));
Next
Circle (100, 100), 51, _RGB(255, 255, 255)
x& = GetCircle&(100, 100, 50)
Locate 2, 24:: Color _RGB(255, 255, 255)
Print " Copied this area of the screen "
_Delay 2
Cls
Do
PutCircle Rnd * _Width, Rnd * _Height, x&, Rnd * 255
_Limit 30
Loop Until InKey$ <> ""
Function GetCircle& (cx, cy, radius)
If circleimg& <> 0 Then _FreeImage circleimg&
circleimg& = _NewImage(radius * 2, radius * 2) '
_Dest circleimg&
For x = 0 To radius * 2
For y = 0 To radius * 2
If Sqr((x - radius) ^ 2 + (y - radius) ^ 2) <= radius Then
clr& = Point(cx - radius + x, cy - radius + y)
PSet (x, y), clr&
End If
Next
Next
GetCircle& = _CopyImage(circleimg&)
_FreeImage circleimg&
_Dest 0
End Function
Sub PutCircle (cx, cy, img&, alpha)
If img& = 0 Then Exit Sub
radius = _Width(img&) / 2
_Source img&
_Dest 0
For x = 0 To radius * 2
For y = 0 To radius * 2
If Sqr((x - radius) ^ 2 + (y - radius) ^ 2) <= radius Then
clr~& = Point(x, y)
r = _Red32(clr~&)
g = _Green32(clr~&)
b = _Blue32(clr~&)
PSet (cx + x, cy + y), _RGBA(r, g, b, alpha)
End If
Next
Next
_Source 0
End Sub
Posts: 31
Threads: 6
Joined: Apr 2024
Reputation:
5
09-25-2024, 12:39 PM
(This post was last modified: 09-25-2024, 12:42 PM by ahenry3068.)
(09-25-2024, 12:26 PM)Dav Wrote: Has anyone made a routine to copy a paste a non-rectangular area of the screen? Or does QB64PE have a built-in way? I'm working on a new drawing program and trying to add a feature where you can draw an enclosed area with the mouse, copy it, and paste it. Making a circle area routine was easy, but having some difficulty with the any shape one. I'm doing a polygon approach for the any shaped one, capture all the pixels inside the drawn polygon. Wondered if someone here has already made such a routine that is working.
Here's the circle copy/paste that is working ok.
- Dav
Code: (Select All)
Screen _NewImage(1000, 700, 32)
For t = 1 To 7000
Color _RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Print _Trim$(Str$(Int(Rnd * 10)));
Next
Circle (100, 100), 51, _RGB(255, 255, 255)
x& = GetCircle&(100, 100, 50)
Locate 2, 24:: Color _RGB(255, 255, 255)
Print " Copied this area of the screen "
_Delay 2
Cls
Do
PutCircle Rnd * _Width, Rnd * _Height, x&, Rnd * 255
_Limit 30
Loop Until InKey$ <> ""
Function GetCircle& (cx, cy, radius)
If circleimg& <> 0 Then _FreeImage circleimg&
circleimg& = _NewImage(radius * 2, radius * 2) '
_Dest circleimg&
For x = 0 To radius * 2
For y = 0 To radius * 2
If Sqr((x - radius) ^ 2 + (y - radius) ^ 2) <= radius Then
clr& = Point(cx - radius + x, cy - radius + y)
PSet (x, y), clr&
End If
Next
Next
GetCircle& = _CopyImage(circleimg&)
_FreeImage circleimg&
_Dest 0
End Function
Sub PutCircle (cx, cy, img&, alpha)
If img& = 0 Then Exit Sub
radius = _Width(img&) / 2
_Source img&
_Dest 0
For x = 0 To radius * 2
For y = 0 To radius * 2
If Sqr((x - radius) ^ 2 + (y - radius) ^ 2) <= radius Then
clr~& = Point(x, y)
r = _Red32(clr~&)
g = _Green32(clr~&)
b = _Blue32(clr~&)
PSet (cx + x, cy + y), _RGBA(r, g, b, alpha)
End If
Next
Next
_Source 0
End Sub
I don't have any code handy but I have a good idea how you must go about it. Because of how Video Ram is layed out _PutImage & _GetImage only operate on rectangular images. I believe you MUST be in 32 bit color mode to do this but what you have to do is do a _GetImage of what you want. Then Mask out the shape with pixels that have an _Alpha (opacity) value of 0. Then when you do the _PutImage the ALPHA=0 pixels will not be visible. Depending on the shape the masking code will be different. Your code is clever but I have the feeling that it might be to slow for animation. (Maybe not though, It is a bit amazing how fast modern computers are. But my code mind set is stuck on slower systems)
Posts: 238
Threads: 42
Joined: May 2022
Reputation:
28
Yeah, I dealt with it. Finally, I used a transparent background, I selected the farthest coordinates from the array of points that bounded the polygon, thus obtaining a rectangular slice with a transparent background, and I sent that to the new handle of the new image with the _PutImage command. It's significantly faster than solving it point by point. I'll try to find it or write it right away.
Posts: 370
Threads: 23
Joined: May 2022
Reputation:
56
I agree with @ahenry3068 and @Petr. Doing it using alpha masks will be the fastest for 32-bpp images.
Posts: 723
Threads: 118
Joined: Apr 2022
Reputation:
106
Thank you all for the advice, that sounds like a good idea. Will get working on it.
- Dav
Posts: 238
Threads: 42
Joined: May 2022
Reputation:
28
09-25-2024, 03:10 PM
(This post was last modified: 09-25-2024, 03:10 PM by Petr.)
Hey, I needed to dust the cobwebs out of my brain anyway and this caught my eye (obviously I couldn't find the old source), so a bit of thinking and here's the output. Mark any shape, the condition is that you must connect the beginning of the line with the end (tolerance of 5 pixels from each other). After marking the selection of the image, the program will only show you what you marked with the selection.
Code: (Select All)
'copy/paste polygon image
'use mouse for inserting image
Image& = _ScreenImage
_Delay .5
Screen _NewImage(_DesktopWidth, _DesktopHeight, 32)
_FullScreen
Cls
Type Points
As Integer x, y
End Type
ReDim P(20000) As Points
Do
_PutImage , Image& 'place complete image to screen
Locate 1
Print "Use mouse, press left button and select any image area"
While _MouseInput
Wend
MX = _MouseX
MY = _MouseY
LB = _MouseButton(1)
Print LB, MX, MY, j, max
If LB = -1 Then
'insert coordinate to array if is left mouse button pressed
If oMX <> MX Or oMY <> MY Then 'if is mouse moved to other position
P(j).x = MX ' add new coordinates to array P
P(j).y = MY
oMX = MX ' and memorize old coordinates
oMY = MY
j = j + 1
max = 0
i = UBound(P)
If j = i Then ' if array P is full, add next 20000 records
ReDim _Preserve P(i + 20000) As Points
max = 0
End If
End If
End If
'draw selected area: find used indexes
If max = 0 Then 'lock for search maximum once if now record is not added
max = UBound(P)
Do Until P(max).x > 0 Or P(max).y > 0
If max > 0 Then max = max - 1 Else Exit Do
Loop
End If
If max Then
PReset (P(0).x, P(0).y)
For D = 1 To max
Line -(P(D).x, P(D).y)
Next
End If
'control if area is completed
If max > 10 Then
If Abs(P(max).x - P(0).x) < 5 And Abs(P(max).y - P(0).y) < 5 Then
Print "select complete!"
'find maximal/minimal X and Y
c = 0
minX = _Width
minY = _Height
Do Until c = max
If minX > P(c).x Then minX = P(c).x
If maxX < P(c).x Then maxX = P(c).x
If minY > P(c).y Then minY = P(c).y
If maxY < P(c).y Then maxY = P(c).y
c = c + 1
Loop
'copy full rectangle image area to new image
copyImg& = _NewImage(maxX - minX, maxY - minY, 32)
_PutImage (0, 0), Image&, copyImg&, (minX, minY)-(maxX, maxY)
'create alpha mask for image
Mask& = _NewImage(maxX - minX, maxY - minY, 32)
_Dest Mask&
Cls 'now is the background color black and alpha is full - set to 0,0,0,255
For D = 1 To max
Line (-minX + P(D - 1).x, -minY + P(D - 1).y)-(-minX + P(D).x, -minY + P(D).y), _RGB32(100)
Next
Line (-minX + P(0).x, -minY + P(0).y)-(-minX + P(max).x, -minY + P(max).y), _RGB32(100)
Paint (_Width(Mask&) \ 2, _Height(Mask&) \ 2), _RGB32(100) 'colorize selected area
_SetAlpha 0, _RGB32(100), Mask&
'place mask image
_PutImage , Mask&, copyImg&
_FreeImage Mask&
_Dest 0
_Source 0
'view output
Cls
_PutImage (0, 0), copyImg&
_FreeImage copyImg&
End
End If
End If
_Limit 30
_Display
Loop
![[Image: output.png]](https://i.ibb.co/cbNqTG2/output.png)
Posts: 2,694
Threads: 326
Joined: Apr 2022
Reputation:
217
The way I'd go about this would be to :
1) Make a _CopyImage of the existing screen.
2) Set _DontBlend on that CopyImage
3) When clicking the mouse, I'd draw a line from point A to point B in COLOR 0 (no alpha, no red, no green, no blue.) Do this until you enclose the area you want to copy. Keep the max top/left/bottom/right coordinates to make a box later.
4) PAINT that screen in COLOR 0, outside the box to keep.
5) Turn _Blend on for that CopyImage
6) You can now _PutImage that top/left/bottom/right box onto the main screen.
7) Freeimage that _CopyImage
Posts: 723
Threads: 118
Joined: Apr 2022
Reputation:
106
Thanks for the code, @Petr! That looks good. I have to leave home for the rest of the day now but will sure play with your code when getting back home. Have a good day.
- Dav
Posts: 238
Threads: 42
Joined: May 2022
Reputation:
28
There's a bug, I'll look into fixing it after the meal. Specifically, line 101. That's bullshit, isn't it? This has to be replaced. We need to find for a specific Y coordinate two marginal X coordinates. And we are back to sorting numbers, mama mia...
Posts: 238
Threads: 42
Joined: May 2022
Reputation:
28
I've been messing around with it a bit, but I'm still not completely satisfied. Although it is possible to mark the shape of the letter C without error, there are still situations when the selection of the image is done incorrectly.
The original version took the center of the image as a fixed point at which the selection image is always present. That was wrong. This version will count all the points around the selection and then try to determine the point between the two boundaries where the color fill for the mask will be done. Well, sometimes is this operation wrong done. If anyone wants to add own version, please, I'd be happy to take a look.
Code: (Select All)
'copy/paste polygon image
'use mouse for inserting image
Image& = _ScreenImage
_Delay .5
Screen _NewImage(_DesktopWidth, _DesktopHeight, 32)
_FullScreen
Cls
Type Points
As Integer x, y
End Type
Type LinePoints
X As Integer
Y As Integer
End Type
ReDim Shared LP(0) As LinePoints
ReDim nP(0) As Points
ReDim P(20000) As Points
Do
_PutImage , Image& 'place complete image to screen
Locate 1
Print "Use mouse, press left button and select any image area"
While _MouseInput
Wend
MX = _MouseX
MY = _MouseY
LB = _MouseButton(1)
Print LB, MX, MY, j, max
If LB = -1 Then
'insert coordinate to array if is left mouse button pressed
If oMX <> MX Or oMY <> MY Then 'if is mouse moved to other position
P(j).x = MX ' add new coordinates to array P
P(j).y = MY
oMX = MX ' and memorize old coordinates
oMY = MY
j = j + 1
max = 0
i = UBound(P)
If j = i Then ' if array P is full, add next 20000 records
ReDim _Preserve P(i + 20000) As Points
max = 0
End If
End If
End If
'draw selected area: find used indexes
If max = 0 Then 'lock for search maximum once if now record is not added
max = UBound(P)
Do Until P(max).x > 0 Or P(max).y > 0
If max > 0 Then max = max - 1 Else Exit Do
Loop
End If
If max Then
PReset (P(0).x, P(0).y)
For D = 1 To max
Line -(P(D).x, P(D).y)
Next
End If
'control if area is completed
If max > 10 Then
If Abs(P(max).x - P(0).x) < 5 And Abs(P(max).y - P(0).y) < 5 Then
Print "select complete!"
'find maximal/minimal X and Y
c = 0
minX = _Width
minY = _Height
Do Until c = max
If minX > P(c).x Then minX = P(c).x
If maxX < P(c).x Then maxX = P(c).x
If minY > P(c).y Then minY = P(c).y
If maxY < P(c).y Then maxY = P(c).y
c = c + 1
Loop
'copy full rectangle image area to new image
copyImg& = _NewImage(maxX - minX, maxY - minY, 32)
_PutImage (0, 0), Image&, copyImg&, (minX, minY)-(maxX, maxY)
'create alpha mask for image
Mask& = _NewImage(maxX - minX, maxY - minY, 32)
_Dest Mask&
Cls 'now is the background color black and alpha is full - set to 0,0,0,255
For D = 1 To max
Line (-minX + P(D - 1).x, -minY + P(D - 1).y)-(-minX + P(D).x, -minY + P(D).y), _RGB32(100)
Next
Line (-minX + P(0).x, -minY + P(0).y)-(-minX + P(max).x, -minY + P(max).y), _RGB32(100)
'Paint (_Width(Mask&) \ 2, _Height(Mask&) \ 2), _RGB32(100) 'colorize selected area
'this is bad: if you select "C" character, program works badly, also:
'every y has its own X, so I write out X for a specific y:
'faulty reasoning. It's not like that. Some points are not in the field because they were drawn by the line statement.
'therefore, the missing points must be counted and then only look for two neighbors, because otherwise it may happen that
'you find two which, however, are not directly adjacent.
'I name the new field with added points nP
For FillnP = 0 To max - 1
ReDim LP(0) As LinePoints
GETPOINTS P(FillnP).x, P(FillnP).y, P(FillnP + 1).x, P(FillnP + 1).y, LP()
UnP = UBound(nP)
ReDim _Preserve nP(UnP + UBound(LP)) As Points
For Fnp = 0 To UBound(LP) 'calculate all new points to field nP
nP(UnP + Fnp).x = LP(Fnp).X
nP(UnP + Fnp).y = LP(Fnp).Y
Next
Next
ReDim LP(0) As LinePoints
GETPOINTS P(0).x, P(0).y, P(max).x, P(max).y, LP()
UnP = UBound(nP)
ReDim _Preserve nP(UnP + UBound(LP)) As Points
For Fnp = 0 To UBound(LP) 'calculate all new points to field nP
nP(UnP + Fnp).x = LP(Fnp).X
nP(UnP + Fnp).y = LP(Fnp).Y
Next
ReDim Xes(rec) As Integer 'array for X - points in one Y line
For Sy = 0 To UBound(nP)
MyY = nP(Sy).y
rec = 0
ReDim Xes(rec) As Integer
For Sx = 0 To UBound(nP)
If nP(Sx).y = MyY Then
rec = rec + 1
ReDim _Preserve Xes(rec) As Integer
Xes(rec) = nP(Sx).x
End If
Next Sx
'_Dest 0
' Print "for Y = "; MyY; "have found "; rec; "X points";
' If rec Then
' For RList = 1 To rec
' Print Xes(RList)
'Next
'End If
If rec = 2 Then
If Xes(1) < Xes(2) Then Swap Xes(1), Xes(2)
If Abs(Xes(1) - Xes(2)) > 10 Then
MyX = Xes(2) + (Xes(1) - Xes(2)) \ 2
' _Dest 0
' Print "calculated MyX "; MyX
' _Display
' Sleep
GoTo test
End If
End If
' _Display
' Sleep
Next Sy
test:
_Dest Mask&
Paint (-minX + MyX, -minY + MyY), _RGB32(100) 'colorize selected area
_SetAlpha 0, _RGB32(100), Mask&
'place mask image
_PutImage , Mask&, copyImg&
_FreeImage Mask&
_Dest 0
_Source 0
'view output
Cls
_PutImage (0, 0), copyImg&
_FreeImage copyImg&
End
End If
End If
_Limit 30
_Display
Loop
Sub GETPOINTS (x1, y1, x2, y2, A() As LinePoints)
Dim lenght As Integer
lenght = _Hypot(x1 - x2, y1 - y2) 'Fellippe Heitor show me using this great function.
ReDim A(lenght) As LinePoints
For fill = 0 To lenght
If x1 > x2 Then A(fill).X = x1 - fill * ((x1 - x2) / lenght)
If x1 < x2 Then A(fill).X = x1 + fill * ((x2 - x1) / lenght)
If x1 = x2 Then A(fill).X = x1
If y1 > y2 Then A(fill).Y = y1 - fill * ((y1 - y2) / lenght)
If y1 < y2 Then A(fill).Y = y1 + fill * ((y2 - y1) / lenght)
If y1 = y2 Then A(fill).Y = y1
Next
End Sub
|
