Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
Copying and pasting a non-rectangular area of screen
#10
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


Reply


Messages In This Thread
RE: Copying and pasting a non-rectangular area of screen - by Petr - 09-25-2024, 07:06 PM



Users browsing this thread: 4 Guest(s)