Posts: 1,041
Threads: 140
Joined: Apr 2022
Reputation:
23
04-12-2025, 10:32 PM
(This post was last modified: 04-12-2025, 10:34 PM by madscijr.)
If you have an image and want to erase (make transparent) a section of it in the shape of another "mask" image (or that image's inverse), how might that be accomplished in QB64PE in a fast efficient way, where the resulting image could still be manipulated, saved, etc.?
Similarly, has anyone done a fast "magic wand" type select to "select" a portion of an image (that can then be copied/drawn on/erased/etc.) starting at a given x,y location matching a given color with an adjustable tolerance level? Or a fast flood fill with a variable tolerance level? Any help appreciated!
Posts: 3,019
Threads: 358
Joined: Apr 2022
Reputation:
282
04-13-2025, 12:11 AM
(This post was last modified: 04-13-2025, 12:14 AM by SMcNeill.)
Easiest way here is just to write a loop:
Code: (Select All) _Source image2
_Dest image1
_DontBlend 'so 0 will change and update the image rather than blend to nothing
FOR x = 0 to _width(image2)
FOR y = 0 to _height(image2)
IF POINT(x,y) <> 0 THEN PSET(x2 + x, y2 + y), 0 'make transparent
NEXT
NEXT
If the point in the 2nd image isn't blank (0 , or whatever your background color might be on that image), then make that point blank on the first image.
Same way for a tolerance level. Just change that <> 0 to the color you want, or the color range you want.
IF POINT(x,y) >= _RGBA32(100,100,100,0) _ANDALSO POINT(x,y) <= _RGBA32(100,100,100,255)....
Posts: 1,041
Threads: 140
Joined: Apr 2022
Reputation:
23
That's straightforward, pixel by pixel, but is it fast?
Guess I'll run some code and find out!
Thanks!
Posts: 92
Threads: 3
Joined: Apr 2022
Reputation:
18
(04-13-2025, 01:15 AM)madscijr Wrote: That's straightforward, pixel by pixel, but is it fast?
Guess I'll run some code and find out!
Thanks!
I don't know who is more, but maybe it is something you want?
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
'create alpha mask for image
Mask& = _NewImage(maxX - minX + 20, maxY - minY + 20, 32)
_Dest Mask&
Cls , _RGB32(255)
'here next rows is my new acces to this:
' 1) calculate all points in image border and write it to array 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) 'write all new points to field nP
nP(UnP + Fnp).x = LP(Fnp).X
nP(UnP + Fnp).y = LP(Fnp).Y
Next
'2) recalculate points on selected image border to mask image size
For recal = 0 To UBound(nP)
nP(recal).x = -minX + nP(recal).x
nP(recal).y = -minY + nP(recal).y
Next recal
'3) now use LINE statement and make LINE from minX to selected image border on left
' and from selected image border on right to maxX
' 3.1 draw selected image border
'_AutoDisplay
'_Dest 0
'Cls
' Print UBound(nP)
' Sleep
'Screen Mask&
For LineDraw = 0 To UBound(nP)
PSet (10 + nP(LineDraw).x, 10 + nP(LineDraw).y), _RGB32(254)
Next
Paint (_Width(Mask&) - 1, 0), _RGB32(0), _RGB32(254)
'Sleep
'here is done mask: Black color - was is not selected, White color - was is selected
_SetAlpha 0, _RGB32(255), Mask&
_SetAlpha 0, _RGB32(254), Mask&
'create done image + mask: Step 1 - apply full image
' Step 2 - apply mask:
doneImage& = _NewImage(maxX - minX, maxY - minY, 32)
'step 1
_PutImage (0, 0), Image&, doneImage&, (minX, minY)-(maxX, maxY)
'step 2
_PutImage (-10, -10), Mask&, doneImage&
'erase ram
_FreeImage Mask&
_FreeImage Image&
'return to my screen
_Dest 0
_Source 0
'view output
Cls
_PutImage (0, 0), doneImage&
_Display
Sleep
_FreeImage doneImage&
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
Posts: 1,041
Threads: 140
Joined: Apr 2022
Reputation:
23
Thanks @Steffan-68, I look forward to playing with your and Steve's code when I get back to the PC (turning out to be a busy weekend!)
Posts: 353
Threads: 54
Joined: May 2022
Reputation:
52
04-13-2025, 03:34 PM
(This post was last modified: 04-13-2025, 03:41 PM by Petr.)
If I understand correctly, you have two images. One with a mask, the other full. According to the mask you want to set the transparent area. In that case the solution with point is absolutely bad and slow. What you are looking for is _ClearColor, or _SetAlpha. I think this with a rectangle is a simple and clear example:
Code: (Select All)
MyScreen = _ScreenImage
Mask = _NewImage(100, 100, 32) 'background is transparent
_Dest Mask
Cls , _RGB32(255, 255, 0) 'background is now not transparent, is yellow in Mask image
Color _RGB32(255) 'set color for foreground
Line (10, 10)-(90, 90), _RGB32(255), BF 'create white rectangle
_ClearColor _RGB32(255), Mask 'create white color _RGB32(255, 255, 255) transparent
_Dest 0
Screen _NewImage(_DesktopWidth, _DesktopHeight, 32)
_FullScreen
Do Until InKey$ <> ""
While _MouseInput: Wend
Mx = _MouseX
My = _MouseY
_PutImage , MyScreen 'put background
_PutImage (Mx, My), Mask, 0 'put image contains transparent mask (white rectangle in Mask image)
_Display
_Limit 20
Loop
_FreeImage MyScreen
_FreeImage Mask
End
Posts: 353
Threads: 54
Joined: May 2022
Reputation:
52
In my thread, there is a program called Paint2 that uses this property to color various shapes regardless of the color of the edges, thus bypassing the limitations of the Paint command. https://qb64phoenix.com/forum/showthread.php?tid=1507 and is based on masking.
Posts: 353
Threads: 54
Joined: May 2022
Reputation:
52
Small upgrade. _SetAlpha allow you much more options than _ClearColor:
Code: (Select All)
MyScreen = _ScreenImage
Mask = _NewImage(265, 265, 32) 'background is transparent
_Dest Mask
Cls , _RGB32(255, 255, 0) 'background is now not transparent, is yellow in Mask image
Color _RGB32(255) 'set color for text
For f = 0 To 255
Line (10 + f, 10 + f)-(255 - f, 255 - f), _RGB32(f), B 'create 255 different colored rectangles
_SetAlpha 255 - f, _RGB32(f), Mask 'create 8 bit scaled transparent image - each color use own transparent level
Next
_Dest 0
Screen _NewImage(_DesktopWidth, _DesktopHeight, 32)
_FullScreen
Do Until InKey$ <> ""
While _MouseInput: Wend
Mx = _MouseX - 127
My = _MouseY - 127
_PutImage , MyScreen 'put background
_PutImage (Mx, My), Mask, 0 'put image contains transparent mask (white rectangle in Mask image)
_Display
_Limit 20
Loop
_FreeImage MyScreen
_FreeImage Mask
End
Posts: 1,041
Threads: 140
Joined: Apr 2022
Reputation:
23
04-13-2025, 06:18 PM
(This post was last modified: 04-13-2025, 07:19 PM by madscijr.)
I'll have to look at @Petr's latest, but I tried the 3 examples and am having trouble with all of them... here is the code all in one program, with a description of the problems with each... Thanks again for your help, I'm sure I'll figure these out eventually, but out of time for now...
Code: (Select All) Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
Dim in$
Do
Screen 0: _AutoDisplay
Cls
Print "1. Steve_1 <- COPIES RECTANGLE BUT NOT MASK PATTERN?"
Print "2. Petr_1 <- MOVES BOX BUT NOTHING ELSE? AFTER EXITING STUCK IN LORES MODE?"
Print "3. Steffan68_1 <- CAN DRAW LINES BUT NOTHING HAPPENS & CAN'T EXIT? "
Input "Your choice (Q to quit)"; in$
in$ = UCase$(Left$(_Trim$(in$), 1))
Select Case in$
Case "1": Steve_1
Case "2": Petr_1
Case "3": Steffan68_1
Case "Q": Exit Do
End Select
Loop
End
' /////////////////////////////////////////////////////////////////////////////
' I tried using Steve's pixel-by-pixel method here, but not working...
' based on:
' Reply #2 from SMcNeill, Yesterday, 08:11 PM (This post was last modified: Yesterday, 08:14 PM by SMcNeill.)
' https://qb64phoenix.com/forum/showthread.php?tid=3612&pid=33505#pid33505
'
' Easiest way here is just to write a loop:
' If the point in the 2nd image isn't blank
' (0, or whatever your background color might be on that image),
' then make that point blank on the first image.
' Same way for a tolerance level.
' Just change that <> 0 to the color you want, or the color range you want.
' IF POINT(x,y) >= _RGBA32(100,100,100,0) _ANDALSO POINT(x,y) <= _RGBA32(100,100,100,255)....
Sub Steve_1
Dim sBgFile$
Dim imgSrc&
Dim imgDst&
Dim imgMsk&
Dim x1, y1 As Integer ' start point to copy from imgSrc&
Dim x2, y2 As Integer ' end point to copy from imgSrc&
Dim dx, dy As Integer ' point on imgDst& where portion of imgSrc& will be copied
Dim tx, ty As Integer ' point on screen to show imgDst&
Dim sx, sy As Integer ' for loop
Dim cx, cy As Integer ' calculated
Dim iSize As Integer
Dim NextColor~&
Randomize Timer
' INIT SCREEN
Screen _NewImage(800, 600, 32)
_ScreenMove 0, 0: _Dest 0: Cls , cBlue
' INIT SOURCE IMAGE
' horizontal green on red lines
imgSrc& = _NewImage(800, 600, 32)
_Dest imgSrc&: Cls , cRed
For cy = 1 To 600 Step 10
'DrawRectSolid iX, iY, iSizeW, iSizeH, fgColor
DrawRectSolid 1, cy, 800, 5, cLime
Next cy
' INIT MASK IMAGE
' "swiss cheese"
imgMsk& = _NewImage(800, 600, 32)
_Dest imgMsk&: Cls , cEmpty
For cy = 1 To 600 Step 25
For cx = 1 To 800 Step 25
' place random size swiss cheese hole semi-randomly
iSize = RandomNumber%(3, 15)
dx = RandomNumber%(0, 5) - 3
dy = RandomNumber%(0, 5) - 3
'DrawCircle 0, iX, iY, iRadius, iThickness, fgColor, bgColor
DrawCircle 0, cx + dx, cy + dy, iSize, iSize, cBlack, cBlack
Next cx
Next cy
' INIT DEST IMAGE
' vertical magenta on cyan stripes
imgDst& = _NewImage(100, 300, 32)
_Dest imgDst&: Cls , cCyan
For cx = 1 To 100 Step 5
'DrawRectSolid iX, iY, iSizeW, iSizeH, fgColor
DrawRectSolid cx, 1, 4, 300, cMagenta
Next cx
' COPY SOURCE TO DEST USING MASK
dx = 25: dy = 50
x1 = 300: x2 = 350: y1 = 200: y2 = 400
'_DontBlend ' so 0 will change and update the image rather than blend to nothing
For sx = x1 To x2
For sy = y1 To y2
' CHECK IF PIXEL LOCATION IN MASK IS BLACK
_Source imgMsk&
'If Point(sx, sy) <> cEmpty Then
If Point(sx, sy) = cBlack Then
' COPY PIXEL FROM THIS LOCATION FROM SOURCE
_Source imgSrc&
NextColor~& = Point(sx, sy)
' WRITE THE PIXEL TO RELATIVE LOCATION IN DEST
_Dest imgDst&
cx = dx + (sx - x1)
cy = dy + (sy - y1)
PSet (cx, cy), NextColor~&
End If
Next sy
Next sx
' COPY DEST TO SCREEN
_Dest 0
tx = 100: ty = 250
'_PUTIMAGE (dx1, dy1)-(dx2, dy2), sourceHandle&, destHandle&,(sx1, sy1)
_PutImage (tx, ty), imgDst&
' WAIT FOR USER
PressAnyKey
' CLEAN UP
If imgMak& < -1 Or imgMak& > 0 Then _FreeImage imgMak&
If imgSrc& < -1 Or imgSrc& > 0 Then _FreeImage imgSrc&
If imgDst& < -1 Or imgDst& > 0 Then _FreeImage imgDst&
End Sub ' Steve_1
' /////////////////////////////////////////////////////////////////////////////
' Reply #4 from Steffan-68, 7 hours ago
' https://qb64phoenix.com/forum/showthread.php?tid=3612&pid=33514#pid33514
'
' (Yesterday, 09:15 PM) madscijr Wrote:
' >That's straightforward, pixel by pixel, but is it fast?
' >Guess I'll run some code and find out! Thanks!
' I don't know who is more, but maybe it is something you want?
' copy/paste polygon image
' use mouse for inserting image
Sub Steffan68_1
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 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
'create alpha mask for image
Mask& = _NewImage(maxX - minX + 20, maxY - minY + 20, 32)
_Dest Mask&
Cls , _RGB32(255)
'here next rows is my new acces to this:
' 1) calculate all points in image border and write it to array 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) 'write all new points to field nP
nP(UnP + Fnp).x = LP(Fnp).X
nP(UnP + Fnp).y = LP(Fnp).Y
Next
'2) recalculate points on selected image border to mask image size
For recal = 0 To UBound(nP)
nP(recal).x = -minX + nP(recal).x
nP(recal).y = -minY + nP(recal).y
Next recal
'3) now use LINE statement and make LINE from minX to selected image border on left
' and from selected image border on right to maxX
' 3.1 draw selected image border
'_AutoDisplay
'_Dest 0
'Cls
' Print UBound(nP)
' Sleep
'Screen Mask&
For LineDraw = 0 To UBound(nP)
PSet (10 + nP(LineDraw).x, 10 + nP(LineDraw).y), _RGB32(254)
Next
Paint (_Width(Mask&) - 1, 0), _RGB32(0), _RGB32(254)
'Sleep
'here is done mask: Black color - was is not selected, White color - was is selected
_SetAlpha 0, _RGB32(255), Mask&
_SetAlpha 0, _RGB32(254), Mask&
'create done image + mask: Step 1 - apply full image
' Step 2 - apply mask:
doneImage& = _NewImage(maxX - minX, maxY - minY, 32)
'step 1
_PutImage (0, 0), Image&, doneImage&, (minX, minY)-(maxX, maxY)
'step 2
_PutImage (-10, -10), Mask&, doneImage&
'erase ram
'_FreeImage Mask&
'_FreeImage Image&
If Mask& < -1 Or Mask& > 0 Then _FreeImage Mask&
If Image& < -1 Or Image& > 0 Then _FreeImage Image&
'return to my screen
_Dest 0
_Source 0
'view output
Cls
_PutImage (0, 0), doneImage&
_Display
PressAnyKey
'Sleep
'_FreeImage doneImage&
'End
End If
End If
_Limit 30
_Display
Loop
If doneImage& < -1 Or doneImage& > 0 Then _FreeImage doneImage&
If Image& < -1 Or Image& > 0 Then _FreeImage Image&
End Sub ' Steffan68_1
' /////////////////////////////////////////////////////////////////////////////
Sub PressAnyKey
Dim M$: Dim ty%, tx%, mx%, my%
M$ = "PRESS ANY KEY TO CONTINUE"
Color _RGB32(0, 0, 255), _RGB32(255, 255, 255)
ty% = (_Height(0) / _FontHeight) - 1 ' how many text lines will fit
tx% = (_Width(0) / _FontWidth) - 1 ' how many text columns will fit
mx% = (tx% / 2) - (Len(M$) / 2): my% = (ty% / 2)
Locate my%, mx%: Print "PRESS ANY KEY TO CONTINUE"
_AutoDisplay
Sleep
_KeyClear ' CLEAR KEYBOARD BUFFER
End Sub ' PressAnyKey
' /////////////////////////////////////////////////////////////////////////////
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 ' GETPOINTS
' /////////////////////////////////////////////////////////////////////////////
' Reply #6 from Petr, 15 minutes ago (This post was last modified: 8 minutes ago by Petr.)
' https://qb64phoenix.com/forum/showthread.php?tid=3612&pid=33519#pid33519
' If I understand correctly, you have two images.
' One with a mask, the other full.
' According to the mask you want to set the transparent area.
' In that case the solution with point is absolutely bad and slow.
' What you are looking for is _ClearColor, or _SetAlpha.
' I think this with a rectangle is a simple and clear example:
Sub Petr_1
MyScreen = _ScreenImage
Mask = _NewImage(100, 100, 32) ' background is transparent
_Dest Mask
Cls , _RGB32(255, 255, 0) ' background is now not transparent, is yellow in Mask image
Color _RGB32(255) ' set color for foreground
Line (10, 10)-(90, 90), _RGB32(255), BF ' create white rectangle
_ClearColor _RGB32(255), Mask ' create white color _RGB32(255, 255, 255) transparent
_Dest 0
Screen _NewImage(_DesktopWidth, _DesktopHeight, 32)
_FullScreen
Do Until InKey$ <> ""
While _MouseInput: Wend
Mx = _MouseX
My = _MouseY
_PutImage , MyScreen ' put background
_PutImage (Mx, My), Mask, 0 ' put image contains transparent mask (white rectangle in Mask image)
_Display
_Limit 20
Loop
PressAnyKey
If MyScreen < -1 Or MyScreen > 0 Then _FreeImage MyScreen
If Mask < -1 Or Mask > 0 Then _FreeImage Mask
'_FreeImage MyScreen
'_FreeImage Mask
'End
End Sub ' Petr_1
' /////////////////////////////////////////////////////////////////////////////
' BROKEN VERSION!
Sub Steve_1b
Dim sBgFile$
Dim imgSrc&
Dim imgMask&
Dim x1, y1 As Integer ' start point to copy from imgSrc&
Dim x2, y2 As Integer ' end point to copy from imgSrc&
Dim dx, dy As Integer ' point on imgDst& where portion of imgSrc& will be copied
Dim tx, ty As Integer ' point on screen to show imgDst&
Dim sx, sy As Integer ' for loop
Dim cx, cy As Integer ' calculated
Dim NextColor~&
Screen _NewImage(800, 600, 32)
_ScreenMove 0, 0: _Dest 0: Cls , cBlack
'_PutImage , bgImage&, 0 ' Add the background
'imgSrc& = _ScreenImage: x1 = 300: x2 = 350: y1 = 200: y2 = 400
sBgFile$ = "erase-mask-image.png"
imgSrc& = _LoadImage(m_ProgramPath$ + sBgFile$, 32)
imgMask& = _NewImage(100, 300, 32): dx = 25: dy = 50
_Dest imgMask&: Cls , cRed
'DrawRectSolid iX, iY, iSizeW, iSizeH, fgColor
'DrawCircle 0, iX, iY, iRadius, iThickness, fgColor, bgColor
_Source imgSrc&
_Dest 0
_DontBlend ' so 0 will change and update the image rather than blend to nothing
'For sx = 0 To _Width(imgSrc&)
For sx = x1 To x2
'For sy = 0 To _Height(imgSrc&)
For sy = y1 To y2
cx = dx + (sx - x1)
cy = dy + (sy - y1)
' *****************************************************************************
' *** BEGIN DEBUG
If _TRUE = _FALSE Then
_Dest 0
print _
"sx=" + _TRIM$(str$(sx)) + ", " + _
"sy=" + _TRIM$(str$(sy)) + ", " + _
"dx=" + _TRIM$(str$(dx)) + ", " + _
"dy=" + _TRIM$(str$(dy)) + ", " + _
"x1=" + _TRIM$(str$(x1)) + ", " + _
"y1=" + _TRIM$(str$(y1)) + ", "
print _
"cx = dx + (sx - x1) = " + _
_TRIM$(str$(dx)) + " + (" + _TRIM$(str$(sx)) + " - " + _TRIM$(str$(x1)) + ") = " + _
_TRIM$(str$(cx))
print "cy = dy + (sy - y1) = " + _
_TRIM$(str$(dy)) + " + (" + _TRIM$(str$(sy)) + " - " + _TRIM$(str$(y1)) + ") = " + _
_TRIM$(str$(cy)) + _
""
_Dest imgDst&
_DontBlend ' so 0 will change and update the image rather than blend to nothing
End If
' *** END DEBUG
' *****************************************************************************
_Source imgMask&
If Point(sx, sy) <> 0 Then
_Source imgSrc&
NextColor~& = Point(sx, sy)
_Dest 0
PSet (cx, cy), NextColor~&
'PSet (cx, cy), 0 ' make transparent
End If
Next sy
Next sx
_Dest 0
'_PUTIMAGE (dx1, dy1)-(dx2, dy2), sourceHandle&, destHandle&,(sx1, sy1)
_PutImage (tx, ty), imgDst&, 0
PressAnyKey
If bgImage& < -1 Or bgImage& > 0 Then _FreeImage bgImage&
If imgSrc& < -1 Or imgSrc& > 0 Then _FreeImage imgSrc&
If imgDst& < -1 Or imgDst& > 0 Then _FreeImage imgDst&
End Sub ' Steve_1b
' /////////////////////////////////////////////////////////////////////////////
' Reply #7
' From: Petr, 10 minutes ago
' In my thread, there is a program called Paint2 that uses this
' property to color various shapes regardless of the color of
' the edges, thus bypassing the limitations of the Paint command.
' https://qb64phoenix.com/forum/showthread.php?tid=1507
' and is based on masking.
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D RECTANGLE (SOLID)
'DrawRectSolid iX, iY, iSizeW, iSizeH, fgColor
Sub DrawRectSolid (iX As Integer, iY As Integer, iSizeW As Integer, iSizeH As Integer, fgColor As _Unsigned Long)
Line (iX, iY)-(iX + (iSizeW - 1), iY + (iSizeH - 1)), fgColor, BF ' Draw a solid rectangle
End Sub ' DrawRectSolid
' /////////////////////////////////////////////////////////////////////////////
' bplus: The Gold Standard is even better than THE QB64 CIRCLE sub in this respect!
' https://forum.qb64.org/index.php?topic=1044.135
' from Steve Gold standard
' Renamed fcirc to DrawCircleSolid
' Not as fast as DrawCircleTopLeft but pretty fast.
' Example:
' Screen _NewImage(800, 600, 32)
' _ScreenMove 250, 60
' For r = 250 To 0 Step -60
' DrawCircleSolid 400, 300, r, _RGBA(255, 255, 255, 100)
' Next r
'DrawCircle 0, iX, iY, iRadius, iThickness, fgColor, bgColor
Sub DrawCircle (img&, iX As Integer, iY As Integer, iRadius As Integer, iThickness As Integer, fgColor As _Unsigned Long, bgColor As _Unsigned Long)
Dim iLoop As Integer
Dim iNextRadius As Integer
Dim iRadiusError As Integer
Dim iNextX As Integer
Dim iNextY As Integer
If (img& <= 0) And (iThickness > 0) And (fgColor <> cEmpty) Then
' Select target image
_Dest img& ': Cls , cEmpty
' Draw circle fill
If bgColor <> cEmpty Then
iNextRadius = Abs(iRadius)
iRadiusError = -iNextRadius
iNextX = iNextRadius
iNextY = 0
If iNextRadius = 0 Then
PSet (iX, iY), bgColor
Else
' Draw the middle span here so we don't draw it twice in the main loop,
' which would be a problem with blending turned on.
Line (iX - iNextX, iY)-(iX + iNextX, iY), bgColor, BF
While iNextX > iNextY
iRadiusError = iRadiusError + iNextY * 2 + 1
If iRadiusError >= 0 Then
If iNextX <> iNextY + 1 Then
Line (iX - iNextY, iY - iNextX)-(iX + iNextY, iY - iNextX), bgColor, BF
Line (iX - iNextY, iY + iNextX)-(iX + iNextY, iY + iNextX), bgColor, BF
End If
iNextX = iNextX - 1
iRadiusError = iRadiusError - iNextX * 2
End If
iNextY = iNextY + 1
Line (iX - iNextX, iY - iNextY)-(iX + iNextX, iY - iNextY), bgColor, BF
Line (iX - iNextX, iY + iNextY)-(iX + iNextX, iY + iNextY), bgColor, BF
Wend
End If
End If
' Draw circle outline
If fgColor <> cEmpty Then
If iRadius = 0 Then
PSet (iX, iY), fgColor
Else
iNextRadius = iRadius
For iLoop = 1 To iThickness
' DRAW CIRCLE
' CIRCLE (x, y), radius, color
'CIRCLE [[[STEP]]](column, row), radius%, [drawColor%][, startRadian!, stopRadian!] [, aspect!]
Circle (iX, iY), iNextRadius, fgColor
'Line (iLoop * 8, iHeight * 16)-(iLoop * 8 + 8, _Height), cGray, BF
'Circle (iX, iY), 4, cRed
iNextRadius = iNextRadius - 1
If iNextRadius = 0 Then
PSet (iX, iY), fgColor
Exit For
End If
Next iLoop
End If
End If
End If
End Sub ' DrawCircle
' /////////////////////////////////////////////////////////////////////////////
' Generate random value between Min and Max inclusive.
' Note: random-number generator should be initialized with Randomize Timer
Function RandomNumber% (Min%, Max%)
Dim NumSpread%
NumSpread% = (Max% - Min%) + 1
RandomNumber% = Int(Rnd * NumSpread%) + Min% ' GET RANDOM # BETWEEN Max% AND Min%
End Function ' RandomNumber%
' /////////////////////////////////////////////////////////////////////////////
' Some functions
Function cBlack~& ()
cBlack = _RGB32(0, 0, 0)
End Function ' cBlack~&
Function cGray~& ()
cGray = _RGB32(128, 128, 128)
End Function ' cGray~&
Function cLightGray~& ()
cLightGray = _RGB32(211, 211, 211)
End Function ' cLightGray~&
Function cWhite~& ()
cWhite = _RGB32(255, 255, 255)
End Function ' cWhite~&
Function cRed~& ()
cRed = _RGB32(255, 0, 0)
End Function ' cRed~&
Function cMagenta~& ()
cMagenta = _RGB32(255, 0, 255)
End Function ' cMagenta~&
Function cBlue~& ()
cBlue = _RGB32(0, 0, 255)
End Function ' cBlue~&
Function cCyan~& ()
cCyan = _RGB32(0, 255, 255)
End Function ' cCyan~&
Function cLime~& ()
cLime = _RGB32(0, 255, 0)
End Function ' cLime~&
Function cYellow~& ()
cYellow = _RGB32(255, 255, 0)
End Function ' cYellow~&
Function cOrange~& ()
cOrange = _RGB32(255, 165, 0)
End Function ' cOrange~&
Function cEmpty~& ()
cEmpty = _RGB32(0, 0, 0, 0)
End Function ' cEmpty~&
Posts: 3,019
Threads: 358
Joined: Apr 2022
Reputation:
282
04-13-2025, 09:11 PM
(This post was last modified: 04-13-2025, 09:13 PM by SMcNeill.)
Your Steve1 routine seems a little complex to one Steve. 
Try this:
Code: (Select All)
$Color:32
Screen _NewImage(640, 480, 32)
image = _NewImage(320, 240, 32) 'this would be the image I was going to load
_Dest image
Circle (100, 100), 75, Red: Paint (100, 100), Red 'just to create a circle on my image
Circle (150, 150), 75, Blue: Paint (150, 150), Blue 'an overlapping circle
_Dest 0 'set dest back to main screen
Cls , Gold
Sleep 'so we can see the pure gold screen
Mask 100, 100, image 'this used that image as a mask to blank the screen
Sleep
System
Sub Mask (xPos, yPos, image)
b = _Blend: s = _Source: _Source image
_DontBlend
For x = 0 To _Width(image) - 1: For y = 0 To _Height(image) - 1
If Point(x, y) Then PSet (x + xPos, y + yPos), 0
Next y, x
If b Then _Blend
_Source s
End Sub
|
