09-25-2024, 07:06 PM
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.
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