Hello again. I just couldn't do it - get out from this program. When free-selecting a section of an image in a painting, the selection line can easily be crossed several times and the selection will be made correctly. That was my next goal.
I guess partly because I was trying to apply the solution that Steve wrote here, partly because I was looking at TerryRitchie's source code and eventually somehow connected it all together in my head and reworked my version.
Now I can say that I am satisfied. Try this version. When selecting, make different figure eights, curls, spirals, feel free to cross the selection line several times. The only condition - the beginning and end of the selection line must connect (as in previous versions). Now I would say it finally works the same as in drawing.
In the source code is intentionally only commented with apostrophes the sections of the program that there are for debugging.
Source code upgraded, so line for selecting is not visible in output image now.
I guess partly because I was trying to apply the solution that Steve wrote here, partly because I was looking at TerryRitchie's source code and eventually somehow connected it all together in my head and reworked my version.
Now I can say that I am satisfied. Try this version. When selecting, make different figure eights, curls, spirals, feel free to cross the selection line several times. The only condition - the beginning and end of the selection line must connect (as in previous versions). Now I would say it finally works the same as in drawing.
In the source code is intentionally only commented with apostrophes the sections of the program that there are for debugging.
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
Source code upgraded, so line for selecting is not visible in output image now.