Mouse Move

[TurtleProgrammer]

For a test I drew an object on the screen and now I would like to use the mouse to move the object to new coordinates in the program. Can this be done or is it too much for FreeBasic?

[dafhi]

recent post
viewtopic.php?f=5&t=26049

[BasicCoder2]

Can this be done or is it too much for FreeBasic?

All GUI objects are rectangles.
Note this could be modified to test if mouse button is down over a particular rectangle or part of a rectangle.

Code: Select all

const SCRW = 640
const SCRH = 480

screenres SCRW,SCRH,32
color rgb(0,0,0),rgb(255,255,255):cls

type RECTANGLE
    as integer x
    as integer y
    as integer w
    as integer h
    as ulong   c  'color
end type

sub drawRectangle(rec as RECTANGLE)
    line (rec.x,rec.y)-(rec.x+rec.w,rec.y+rec.h),rec.c,b
end sub

dim shared as RECTANGLE rec1,rec2  'create 2 objects

'initialize object
rec1.x = 100
rec1.y = 100
rec1.w = 50
rec1.h = 60
rec1.c = rgb(255,0,0)

rec2.x = 200
rec2.y = 100
rec2.w = 50
rec2.h = 60
rec2.c = rgb(0,0,255)

sub update()
    screenlock
    cls
    drawRectangle(rec1)
    drawRectangle(rec2)
    screenunlock
end sub

sub moveObject(rec as RECTANGLE)
    dim as integer mx,my,ox,oy,mb
    getmouse mx,my,,mb
    ox = mx
    oy = my
    while mb = 1
        getmouse mx,my,,mb
        if (mx<>ox or my<>oy) and (mx<>-1 or my<>-1) then 'mouse must have moved
            rec.x = rec.x + mx - ox 'add the difference
            rec.y = rec.y + my - oy
            ox = mx  'save new position of mouse
            oy = my
            'keep rectangle within window
            if rec.x < 0 then rec.x = 0
            if rec.x+rec.w >= SCRW then rec.x = SCRW-rec.w-1
            if rec.y < 0 then rec.y = 0
            if rec.y+rec.h >= SCRH then rec.y = SCRH-rec.h-1
            update()  'show moved rectangle
        end if
        sleep 2 'needed in loop
    wend
end sub

'================================== main code =============================
dim as integer mx,my,ox,oy,mb
do
    update()
    getmouse mx,my,,mb
    if mb = 1 then
        'is it over a rectangle?
        if mx>rec1.x and mx<rec1.x+rec1.w and my>rec1.y and my<rec1.y+rec1.h then
            moveObject(rec1)
        end if
        if mx>rec2.x and mx<rec2.x+rec2.w and my>rec2.y and my<rec2.y+rec2.h then
            moveObject(rec2)
        end if
    end if 'mouse button down
    sleep 2
loop until multikey(&H01)

[BasicCoder2]

This has two objects that can be moved around. For example they might be playing cards. For a full pack you would make a list of objects.

Code: Select all

screenres 640,480,32
color rgb(0,0,0),rgb(255,255,255):cls

type RECTANGLE
    as integer x
    as integer y
    as integer w
    as integer h
    as ulong   c  'color
end type

sub drawRectangle(rec as RECTANGLE)
    line (rec.x,rec.y)-(rec.x+rec.w,rec.y+rec.h),rec.c,b
end sub

dim shared as RECTANGLE rec1,rec2  'create 2 objects

'initialize object
rec1.x = 100
rec1.y = 100
rec1.w = 50
rec1.h = 60
rec1.c = rgb(255,0,0)

rec2.x = 200
rec2.y = 100
rec2.w = 50
rec2.h = 60
rec2.c = rgb(0,0,255)

sub update()
    screenlock
    cls
    drawRectangle(rec1)
    drawRectangle(rec2)
    screenunlock
end sub

sub moveObject(rec as RECTANGLE)
    dim as integer mx,my,ox,oy,mb
    getmouse mx,my,,mb
    ox = mx
    oy = my
    while mb = 1
        getmouse mx,my,,mb
        if mx<>ox or my<>oy then 'mouse must have moved
            rec.x = rec.x + mx - ox 'add the difference
            rec.y = rec.y + my - oy
            ox = mx  'save new position of mouse
            oy = my
            update()  'show moved rectangle
        end if
        sleep 2 'needed in loop
    wend
end sub

'================================== main code =============================
dim as integer mx,my,ox,oy,mb
do
    update()
    getmouse mx,my,,mb
    if mb = 1 then
        'is it over a rectangle?
        if mx>rec1.x and mx<rec1.x+rec1.w and my>rec1.y and my<rec1.y+rec1.h then
            moveObject(rec1)
        end if
        if mx>rec2.x and mx<rec2.x+rec2.w and my>rec2.y and my<rec2.y+rec2.h then
            moveObject(rec2)
        end if
    end if 'mouse button down
    sleep 2
loop until multikey(&H01)

[dodicat]

Here are some disc objects.

Code: Select all

type disc
    as long x,y 'centre
    as long radius
    as ulong colour
end type

'is x,y in disc c?
function indisc(c as disc,x as long,y as long) as long
return (c.x-x)*(c.x-x) +(c.y-y)*(c.y-y)<= c.radius*c.radius
end function

Function DetectDiscsAreClose( B1 As disc,B2 As disc) As single 
    Dim As Long xdiff = B2.x-B1.x
    Dim As Long ydiff = B2.y-B1.y
    If Abs(xdiff) > (B2.radius+B1.radius) Then Return 0
    If Abs(ydiff) > (B2.radius+B1.radius) Then Return 0
    var L=Sqr(xdiff*xdiff+ydiff*ydiff)
    If L<=(B2.radius+B1.radius) Then Function=L else Function=0
End Function

 sub TouchingDiscs(b() as disc)
    for n1 as Long=lbound(b) to ubound(b)-1
        for n2 as Long=n1+1 to ubound(b)
            dim as single  L= DetectDiscsAreClose(b(n1),b(n2))
            if L then
       dim as single  impulsex=(b(n1).x-b(n2).x)/L
       dim as single  impulsey=(b(n1).y-b(n2).y)/L
       dim as single  impactx=-sgn(b(n1).x-b(n2).x)
       dim as single  impacty=-sgn(b(n1).y-b(n2).y)
       dim as single  dot=impulsex*impactx+impulsey*impacty
       b(n1).x-=dot*impulsex*2 
       b(n1).y-=dot*impulsey*2 
       b(n2).x+=dot*impulsex*2
       b(n2).y+=dot*impulsey*2 
       end if
next n2
next n1
end sub

sub drawdiscs(d() as disc)
    TouchingDiscs(d())
    screenlock
    cls
    for n as long=lbound(d) to ubound(d)
        circle(d(n).x,d(n).y),d(n).radius,d(n).colour,,,,f
    next n
    screenunlock
    sleep 1,1
end sub

sub creatediscs(d() as disc)
for n as long=lbound(d) to ubound(d)
    d(n).x=rnd*800
    d(n).y=rnd*600
    d(n).radius=10+rnd*50
    d(n).colour=rgba(rnd*255,rnd*255,rnd*255,200)
next n
end sub

sub MoveByMouse(d() as disc,i as long,mx as long,my as long,button as long)
    Dim As long x=mx,y=my,dx,dy,b
    dim as long idx=d(i).x-mx,idy=d(i).y-my
    While button = 1
        drawdiscs(d())
     Getmouse mx,my,,button
         If mx>0 And my>0 Then
         If mx<>x Or my<>y Then
            dx = mx - x
            dy = my - y
            x = mx
            y = my
            d(i).x=x+dx+idx
            d(i).y=y+dy+idy
            'don't let active disc off screen (pushed ones are ignored)
            if d(i).x< -d(i).radius+5 then d(i).x=-d(i).radius+5
            if d(i).y< -d(i).radius+5 then d(i).y=-d(i).radius+5
            if d(i).x>800+d(i).radius-5 then d(i).x=800+d(i).radius-5
            if d(i).y>600+d(i).radius-5 then d(i).y=600+d(i).radius-5
        end if
        end if
    wend
    end sub

sub mainsub
screen 19,32,,64  '64 for using alpha blend
dim as disc d(1 to 20)
creatediscs(d())

dim as long mx,my,button,ox,oy
do
    getmouse mx,my,,button
    for n as long=lbound(d) to ubound(d)
        if indisc(d(n),mx,my) and button=1 then 'if mouse is in a disc
          movebymouse(d(),n,mx,my,button)        'smooth drag keeping positions intact
            exit for
        end if
    next n
    drawdiscs(d())
    loop until inkey=chr(27)'escape key
end sub
'==================
mainsub
end


 

[dodicat]

This is windows only.
A little sharper.

Code: Select all

Declare Function settimer Alias "timeBeginPeriod"(As Ulong=1) As Long
Declare Function freetimer Alias "timeEndPeriod"(As Ulong=1) As Long
type disc
    as long x,y 'centre
    as long radius
    as ulong colour
end type

'is x,y in disc c?
function indisc(c as disc,x as long,y as long) as long
return (c.x-x)*(c.x-x) +(c.y-y)*(c.y-y)<= c.radius*c.radius
end function

Function DetectDiscsAreClose( B1 As disc,B2 As disc) As single 
    Dim As Long xdiff = B2.x-B1.x
    Dim As Long ydiff = B2.y-B1.y
    If Abs(xdiff) > (B2.radius+B1.radius) Then Return 0
    If Abs(ydiff) > (B2.radius+B1.radius) Then Return 0
    var L=Sqr(xdiff*xdiff+ydiff*ydiff)
    If L<=(B2.radius+B1.radius) Then Function=L else Function=0
End Function

 sub TouchingDiscs(b() as disc)
    for n1 as Long=lbound(b) to ubound(b)-1
        for n2 as Long=n1+1 to ubound(b)
            dim as single  L= DetectDiscsAreClose(b(n1),b(n2))
            if L then
       dim as single  impulsex=(b(n1).x-b(n2).x)/L
       dim as single  impulsey=(b(n1).y-b(n2).y)/L
       dim as single  impactx=-sgn(b(n1).x-b(n2).x)
       dim as single  impacty=-sgn(b(n1).y-b(n2).y)
       dim as single  dot=impulsex*impactx+impulsey*impacty
       b(n1).x-=dot*impulsex*2 
       b(n1).y-=dot*impulsey*2 
       b(n2).x+=dot*impulsex*2
       b(n2).y+=dot*impulsey*2 
       end if
next n2
next n1
end sub

sub drawdiscs(d() as disc)
    TouchingDiscs(d())
    screenlock
    cls
    for n as long=lbound(d) to ubound(d)
        circle(d(n).x,d(n).y),d(n).radius,d(n).colour,,,,f
    next n
    screenunlock
    settimer
    sleep 1,1  'sleep 1 millisecond only
    freetimer
end sub

sub creatediscs(d() as disc)
for n as long=lbound(d) to ubound(d)
    d(n).x=rnd*800
    d(n).y=rnd*600
    d(n).radius=10+rnd*50
    d(n).colour=rgba(rnd*255,rnd*255,rnd*255,200)
next n
end sub

sub MoveByMouse(d() as disc,i as long,mx as long,my as long,button as long)
    Dim As long x=mx,y=my,dx,dy,b
    dim as long idx=d(i).x-mx,idy=d(i).y-my
    While button = 1
        drawdiscs(d())
     Getmouse mx,my,,button
         If mx>0 And my>0 Then
         If mx<>x Or my<>y Then
            dx = mx - x
            dy = my - y
            x = mx
            y = my
            d(i).x=x+dx+idx
            d(i).y=y+dy+idy
            'don't let active disc off screen (pushed ones are ignored)
            if d(i).x< -d(i).radius+5 then d(i).x=-d(i).radius+5
            if d(i).y< -d(i).radius+5 then d(i).y=-d(i).radius+5
            if d(i).x>800+d(i).radius-5 then d(i).x=800+d(i).radius-5
            if d(i).y>600+d(i).radius-5 then d(i).y=600+d(i).radius-5
        end if
        end if
    wend
    end sub

sub mainsub
screen 19,32
dim as disc d(1 to 20)
creatediscs(d())

dim as long mx,my,button,ox,oy
do
    getmouse mx,my,,button
    for n as long=lbound(d) to ubound(d)
        if indisc(d(n),mx,my) and button=1 then 'if mouse is in a disc
          movebymouse(d(),n,mx,my,button)        'smooth drag keeping positions intact
            exit for
        end if
    next n
    drawdiscs(d())
    loop until inkey=chr(27)'escape key
end sub
'==================
mainsub
end


 

[MrSwiss]

A rectangle again, but in this case, the mouse status is clearly indicated:

• rectangle, black border = mouse is NOT on rectangle
• rectangle, red border = mouse over rectangle (no button pressed)
• rectangle, yellow border/filled = mouse on rect. & left button pressed
• rectangle, yellow border/filled blue = (as above) & mouse moving

Additional checks prevent rectangle moved out of window ...

Code: Select all

' Move_Object_With_Mouse.bas -- 2017-10-28, by MrSwiss

Type RECTANGLE
    As Short    x, y, iw, ih            ' QB Integer (16bit)
    Declare Function InBox(ByVal As Short, ByVal As Short) As Boolean
    Declare Sub      ShowB(ByVal As ULong, ByVal As ULong=0, ByVal As Boolean=FALSE)
End Type                                ' however: a 1/4 size of a FB Integer (64bit)

Function RECTANGLE.InBox( _
    ByVal m_x As Short, ByVal m_y As Short _    ' mouse pos. to compare with rect.
    ) As Boolean
    If m_x = -1 OrElse m_y = -1 Then Return FALSE   ' mouse outside of window
    With This
        If m_x > .x AndAlso m_x < .x + .iw Then ' check x-axis
            If m_y > .y AndAlso m_y < .y + .ih Then ' check y-axis
                Return TRUE             ' mouse inside rect.
            End If
        End If
    End With
    Return FALSE                        ' mouse outside rect.
End Function
Sub RECTANGLE.ShowB( _
    ByVal bc As ULong, ByVal fc As ULong=0, _   ' border color | fill color
    ByVal fill As Boolean=FALSE _               ' fill (default: none)
    )
    With This
    If fill Then
        ScreenLock
        Cls
        If fc = 0 Then
            Line (.x, .y)-Step(.iw, .ih), bc, BF    ' show rect. filled
        Else
            Line (.x, .y)-Step(.iw, .ih), bc, B     ' show rect. painted
            Paint (.x+1, .y+1), fc, bc              ' aka: diff. fill color
        EndIf
        ScreenUnLock
    Else
        ScreenLock
        Cls : Line (.x, .y)-Step(.iw, .ih), bc, B   ' show box (empty)
        ScreenUnLock
    EndIf
    End With
End Sub
' -------------------------------------------------------------------------
' initialisation
Dim As RECTANGLE    rec1                ' create object
                                        ' initialize object (simplified)
With rec1                               ' less typing, simplifies reading
    .x = 100                            ' x pos.
    .y = 100                            ' y pos.
    .iw = (50-1)                        ' width relative to x (w-1)
    .ih = (60-1)                        ' height relative to y (h-1)
End With

' some predefined colors
Const As ULong  white = &hFFFFFFFF, black = &hFF000000, _
                blue  = &hFF0000FF, yellow = &hFFFFBF00, _
                red   = &hFFFF0000
' -------------------------------------------------------------------------
ScreenRes(640, 480, 32)                 ' screen size + color depth
Color(black, white) : Cls               ' define fgc, bgc

Dim As Integer  mx, my, mb              ' mouse vars
Dim As Short    ox, oy                  ' intemediate save vars

Do
    With rec1
    .ShowB(black)                       ' show black box (empty)
    GetMouse(mx, my,, mb)               ' get mouse status + pos.
    If .InBox(mx, my) Then              ' mouse inside box?
        .ShowB(red)                     ' show red box (mouse over box)
        ox = mx : oy = my               ' save current mouse pos. (x and y)
        While mb And 1                  ' left mouse button pressed
            .ShowB(yellow,, TRUE)       ' show selected (yellow, filled)
            GetMouse(mx, my,, mb)       ' keep mouse vars. updated
            If mx <> ox OrElse my <> oy then    ' mouse has new pos.
                .x += mx - ox : .y += my - oy   ' calc. + add offsets
                ox = mx : oy = my       ' save current mouse pos.
                .ShowB(yellow, blue, TRUE)  ' show moving (diff. fill)
            End If
            Sleep(2, 1)
        Wend
        If (.x + .iw) > 639 OrElse .x < 0 Then
            If (.y + .ih) > 479 OrElse .y < 0 Then
                .x = 295 : .y = 210     ' prevent box out of window
            End If
        End If
    End If
    End With

    Sleep(2, 1)
Loop Until Len(InKey)
' ----- EOF -----

[BasicCoder2]

So here is another version. Sorry no OOP.

Rectangle's border is red if mouse is not over it.
Rectangle's border is blue if mouse is over it.
Rectangle's border is green if mouse if down over it.
You can move rectangle when mouse is down over it.

Code: Select all

const SCRW = 640
const SCRH = 480

screenres SCRW,SCRH,32
color rgb(0,0,0),rgb(100,100,255):cls

dim as integer mx,my,mb,ox,oy  'mouse variables

type RECTANGLE
    as integer x
    as integer y
    as integer w
    as integer h
    as integer a   'mouse on, off or down on rectangle
    as string  t   'text
end type

dim shared as RECTANGLE rec1
rec1.x = 100
rec1.y = 100
rec1.w = 100
rec1.h = 50
rec1.a = 0
rec1.t = ""


sub DrawButton(rec as RECTANGLE)
    
    if rec.a = 0 then
        line (rec.x,rec.y)-(rec.x+rec.w,rec.y+rec.h),rgb(255,200,200),bf
        line (rec.x,rec.y)-(rec.x+rec.w,rec.y+rec.h),rgb(255,0,0),b
        draw string (rec.x+6,rec.y+20)," FREEDOM",rgb(0,0,0)
    end if
    if rec.a = 1 then
        line (rec.x,rec.y)-(rec.x+rec.w,rec.y+rec.h),rgb(200,255,200),bf
        line (rec.x,rec.y)-(rec.x+rec.w,rec.y+rec.h),rgb(0,255,0),b
        draw string (rec.x+6,rec.y+20)," GOT ME !",rgb(0,0,0)
    end if
    if rec.a = 2 then
        line (rec.x,rec.y)-(rec.x+rec.w,rec.y+rec.h),rgb(200,200,255),bf
        line (rec.x,rec.y)-(rec.x+rec.w,rec.y+rec.h),rgb(0,0,255),b
        draw string (rec.x+6,rec.y+20)," OVER ME ",rgb(0,0,0)
    end if

end sub

sub update()
    screenlock
    cls
    drawButton(rec1)
    screenunlock
end sub

do
    rec1.a = 0
    getmouse mx,my,,mb
    if mx>rec1.x and mx<rec1.x+rec1.w and my>rec1.y and my< rec1.y+rec1.h then
        if mb = 1 then
            rec1.a = 1
            update()    'to show mouse down before any move
            'move rectangle while mouse button down
            ox = mx
            oy = my
            while mb = 1
                getmouse mx,my,,mb
                if (mx<>ox or my<>oy) and (mx<>-1 or my<>-1) then  'mouse moved
                    rec1.x = rec1.x + mx-ox
                    rec1.y = rec1.y + my-oy
                    ox = mx
                    oy = my
                    'keep rectangle within window
                    if rec1.x < 0 then rec1.x = 0
                    if rec1.x+rec1.w >= SCRW then rec1.x = SCRW-rec1.w-1
                    if rec1.y < 0 then rec1.y = 0
                    if rec1.y+rec1.h >= SCRH then rec1.y = SCRH-rec1.h-1
                    update()
                end if
                sleep 2,1
            wend
        else
            rec1.a = 2
        end if
    end if
    
    update()

    sleep 2
loop until multikey(&H01)

[BasicCoder2]

Here we have two rectangles...

Code: Select all

const SCRW = 640
const SCRH = 480

screenres SCRW,SCRH,32
color rgb(0,0,0),rgb(100,100,255):cls

dim as integer mx,my,mb,ox,oy  'mouse variables

type RECTANGLE
    as integer x
    as integer y
    as integer w
    as integer h
    as integer a   'mouse on, off or down on rectangle
    as string  t   'text
end type

sub DrawButton(rec as RECTANGLE)
    
    if rec.a = 0 then
        line (rec.x,rec.y)-(rec.x+rec.w,rec.y+rec.h),rgb(255,200,200),bf
        line (rec.x,rec.y)-(rec.x+rec.w,rec.y+rec.h),rgb(255,0,0),b
        draw string (rec.x+6,rec.y+20)," FREEDOM",rgb(0,0,0)
    end if
    if rec.a = 1 then
        line (rec.x,rec.y)-(rec.x+rec.w,rec.y+rec.h),rgb(200,255,200),bf
        line (rec.x,rec.y)-(rec.x+rec.w,rec.y+rec.h),rgb(0,255,0),b
        draw string (rec.x+6,rec.y+20)," GOT ME !",rgb(0,0,0)
    end if
    if rec.a = 2 then
        line (rec.x,rec.y)-(rec.x+rec.w,rec.y+rec.h),rgb(200,200,255),bf
        line (rec.x,rec.y)-(rec.x+rec.w,rec.y+rec.h),rgb(0,0,255),b
        draw string (rec.x+6,rec.y+20)," OVER ME ",rgb(0,0,0)
    end if

end sub

dim shared as RECTANGLE rec(0 to 1)
rec(0).x = 100
rec(0).y = 100
rec(0).w = 100
rec(0).h = 50
rec(0).a = 0
rec(0).t = ""
rec(1).x = 400
rec(1).y = 100
rec(1).w = 100
rec(1).h = 50
rec(1).a = 0
rec(1).t = ""

sub update()
    screenlock
    cls
    for i as integer = 0 to 1
        drawButton(rec(i))
    next i
    screenunlock
end sub

do

    getmouse mx,my,,mb
    for i as integer = 0 to 1
        rec(i).a = 0
        if mx>rec(i).x and mx<rec(i).x+rec(i).w and my>rec(i).y and my< rec(i).y+rec(i).h then
            if mb = 1 then
                rec(i).a = 1
                update()    'to show mouse down before any move
                'move rectangle while mouse button down
                ox = mx
                oy = my
                while mb = 1
                    getmouse mx,my,,mb
                    if (mx<>ox or my<>oy) and (mx<>-1 or my<>-1) then  'mouse moved
                        rec(i).x = rec(i).x + mx-ox
                        rec(i).y = rec(i).y + my-oy
                        ox = mx
                        oy = my
                        'keep rectangle within window
                        if rec(i).x < 0 then rec(i).x = 0
                        if rec(i).x+rec(i).w >= SCRW then rec(i).x = SCRW-rec(i).w-1
                        if rec(i).y < 0 then rec(i).y = 0
                        if rec(i).y+rec(i).h >= SCRH then rec(i).y = SCRH-rec(i).h-1
                        update()
                    end if
                    sleep 2,1
                wend
            else
                rec(i).a = 2
            end if
        end if
    next i
    
    update()

    sleep 2
loop until multikey(&H01)

[MrSwiss]

Here we have two rectangles...

likewise ...

Sorry no OOP.

Btw: this is in no way, anything OOP related, since:
at best, it could be called a "glorified Type" or "static Class" (no: inheritance,
constructor, destructor, operator, type extends object, e.t.c.).

Just because I'm lazy, I've added a initializer (don't like init "by hand"):

Code: Select all

' Move_Object_With_Mouse2.bas -- 2017-10-29, by MrSwiss

Type RECTANGLE
    As Short    x, y, iw, ih            ' QB Integer (16bit)
    Declare Sub      InitR(ByVal As Short, ByVal As Short, ByVal As Short, ByVal As Short)
    Declare Function InBox(ByVal As Short, ByVal As Short) As Boolean
    Declare Sub      ShowB(ByVal As ULong, ByVal As ULong=0, ByVal As Boolean=FALSE)
End Type                                ' however: a 1/4 size of a FB Integer (64bit)

Sub RECTANGLE.InitR( _
    ByVal _x As Short, ByVal _y As Short, _
    ByVal _w As Short, ByVal _h As Short _
    )
    With This
        .x = _x : .y = _y
        .iw = _w - 1 : .ih = _h - 1
    End With
End Sub
Function RECTANGLE.InBox( _
    ByVal m_x As Short, ByVal m_y As Short _    ' mouse pos. to compare with rect.
    ) As Boolean
    If m_x = -1 OrElse m_y = -1 Then Return FALSE   ' mouse outside of window
    With This
        If m_x > .x AndAlso m_x < .x + .iw Then ' check x-axis
            If m_y > .y AndAlso m_y < .y + .ih Then ' check y-axis
                Return TRUE                     ' mouse inside rect.
            End If
        End If
    End With
    Return FALSE                                ' mouse outside rect.
End Function
Sub RECTANGLE.ShowB( _
    ByVal bc As ULong, ByVal fc As ULong=0, _   ' border color | fill color
    ByVal fill As Boolean=FALSE _               ' fill (default: none)
    )
    With This
    If fill Then
        ScreenLock
        If fc = 0 Then
            Line (.x, .y)-Step(.iw, .ih), bc, BF' show rect. filled (w. border color)
        Else
            Line (.x, .y)-Step(.iw, .ih), bc, B ' show rect. painted
            Paint (.x+1, .y+1), fc, bc          ' aka: diff. fill color
        EndIf
        ScreenUnLock
    Else
        ScreenLock
        Line (.x, .y)-Step(.iw, .ih), bc, B     ' show box (empty)
        ScreenUnLock
    EndIf
    End With
End Sub
' -------------------------------------------------------------------------
' initialisation
Dim As RECTANGLE    rec(0 To 1)         ' create objects
' initialize objects (simplified with initializer)
rec(0).InitR(100, 100, 60, 50)          ' calc. (.iw & .ih), is now in .InitR()
rec(1).InitR(400, 350, 80, 30)

' some predefined colors
Const As ULong  white = &hFFFFFFFF, black = &hFF000000, _
                blue  = &hFF0000FF, yellow = &hFFFFBF00, _
                red   = &hFFFF0000
' -------------------------------------------------------------------------
ScreenRes(640, 480, 32)                 ' screen size + color depth
Color(black, white) : Cls               ' define fgc, bgc

Dim As Integer  mx, my, mb              ' mouse vars
Dim As Short    ox, oy, ab = -1         ' intermediate save vars

Do
    Cls
    If rec(0).InBox(mx, my) Then ab = 0 ' mouse inside box?
    If rec(1).InBox(mx, my) Then ab = 1
    For i As UInteger = 0 To UBound(rec)
        rec(i).ShowB(black)             ' show black boxes (empty)
    Next
    GetMouse(mx, my,, mb)               ' get mouse status + pos.

    If ab > -1 Then                     ' only if mouse over a rect.
    With rec(ab)                        ' select active rect. (ab = active box)
        Cls : .ShowB(red)               ' red (mouse hover)
        If ab = 0 Then rec(1).ShowB(black) Else rec(0).ShowB(black) 
        ox = mx : oy = my               ' save current mouse pos. (x and y)
        While mb And 1                  ' left mouse button pressed
            Cls : .ShowB(yellow,, TRUE)       ' show selected (yellow, filled)
            If ab = 0 Then rec(1).ShowB(black) Else rec(0).ShowB(black)
            GetMouse(mx, my,, mb)       ' keep mouse vars. updated
            If mx <> ox OrElse my <> oy then    ' mouse has new pos.
                .x += mx - ox : .y += my - oy   ' calc. + add offsets
                ox = mx : oy = my       ' save current mouse pos.
                Cls : rec(ab).ShowB(yellow, blue, TRUE)  ' show moving (diff. fill)
                If ab = 0 Then rec(1).ShowB(black) Else rec(0).ShowB(black)
            End If
            Sleep(2, 1)
        Wend
        If (.x + .iw) > 639 OrElse .x < 0 Then
            If (.y + .ih) > 479 OrElse .y < 0 Then
                .x = 295 : .y = 210     ' prevent box out of window
            End If
        End If
    End With
    End If


    Sleep(2, 1) : ab = -1
Loop Until Len(InKey)
' ----- EOF -----

[MrSwiss]

With only a few changes in the main-loop:
(and, larger array + added initializers), we can now use as may rectangles, as we want ...
(That is what I call dynamical code, it's able to adapt to changes, e.g. array size.)

Clearly the end of statically coded, since: code would have to be adapted again,
(main and/or subroutines) for every further change (e.g. different array size).

Below, just as a sample: four rectangles (two of them are overlapping):

Code: Select all

' Move_Object_With_Mouse3.bas -- 2017-10-29, by MrSwiss

Type RECTANGLE
    As Short    x, y, iw, ih            ' QB Integer (16bit)
    Declare Sub      InitR(ByVal As Short, ByVal As Short, ByVal As Short, ByVal As Short)
    Declare Function InBox(ByVal As Short, ByVal As Short) As Boolean
    Declare Sub      ShowB(ByVal As ULong, ByVal As ULong=0, ByVal As Boolean=FALSE)
End Type                                ' however: a 1/4 size of a FB Integer (64bit)

Sub RECTANGLE.InitR( _
    ByVal _x As Short, ByVal _y As Short, _
    ByVal _w As Short, ByVal _h As Short _
    )
    With This
        .x = _x : .y = _y
        .iw = _w - 1 : .ih = _h - 1
    End With
End Sub
Function RECTANGLE.InBox( _
    ByVal m_x As Short, ByVal m_y As Short _    ' mouse pos. to compare with rect.
    ) As Boolean
    If m_x = -1 OrElse m_y = -1 Then Return FALSE   ' mouse outside of window
    With This
        If m_x > .x AndAlso m_x < .x + .iw Then ' check x-axis
            If m_y > .y AndAlso m_y < .y + .ih Then ' check y-axis
                Return TRUE                     ' mouse inside rect.
            End If
        End If
    End With
    Return FALSE                                ' mouse outside rect.
End Function
Sub RECTANGLE.ShowB( _
    ByVal bc As ULong, ByVal fc As ULong=0, _   ' border color | fill color
    ByVal fill As Boolean=FALSE _               ' fill (default: none)
    )
    With This
    If fill Then
        ScreenLock
        If fc = 0 Then
            Line (.x, .y)-Step(.iw, .ih), bc, BF' show rect. filled (w. border color)
        Else
            Line (.x, .y)-Step(.iw, .ih), bc, B ' show rect. painted
            Paint (.x+1, .y+1), fc, bc          ' aka: diff. fill color
        EndIf
        ScreenUnLock
    Else
        ScreenLock
        Line (.x, .y)-Step(.iw, .ih), bc, B     ' show box (empty)
        ScreenUnLock
    EndIf
    End With
End Sub
' -------------------------------------------------------------------------
' initialisation
Dim As RECTANGLE    rec(0 To 3)         ' create objects
' initialize objects (simplified with initializer)
rec(0).InitR(100, 100, 60, 50)          ' calc. (.iw & .ih), is now in .InitR()
rec(1).InitR(400, 350, 80, 30)
rec(2).InitR(100, 350, 20, 70)
rec(3).InitR(400, 350, 50, 80)

' some predefined colors
Const As ULong  white = &hFFFFFFFF, black = &hFF000000, _
                blue  = &hFF0000FF, yellow = &hFFFFBF00, _
                red   = &hFFFF0000
' -------------------------------------------------------------------------
ScreenRes(640, 480, 32)                 ' screen size + color depth
Color(black, white) : Cls               ' define fgc, bgc

Dim As Integer  mx, my, mb              ' mouse vars
Dim As Short    ox, oy, ab = -1         ' intermediate save vars

Do
    Cls
    GetMouse(mx, my,, mb)               ' get mouse status + pos.
    For i As UInteger = 0 To UBound(rec)
        rec(i).ShowB(black)             ' show black boxes (empty)
        If rec(i).InBox(mx, my) Then ab = i ' mouse inside a abox? (set it active)
    Next

    If ab > -1 Then                     ' only if mouse over a rect.
    With rec(ab)                        ' select active rect. (ab = active box)
        Cls : .ShowB(red)               ' red (mouse hover)
        For i As UInteger = 0 To UBound(rec)
            If i <> ab Then rec(i).ShowB(black) ' show all not selected
        Next
        ox = mx : oy = my               ' save current mouse pos. (x and y)
        While mb And 1                  ' left mouse button pressed
            Cls : .ShowB(yellow,, TRUE)       ' show selected (yellow, filled)
            For i As UInteger = 0 To UBound(rec)
                If i <> ab Then rec(i).ShowB(black) ' show all not selected
            Next
            GetMouse(mx, my,, mb)       ' keep mouse vars. updated
            If mx <> ox OrElse my <> oy then    ' mouse has new pos.
                .x += mx - ox : .y += my - oy   ' calc. + add offsets
                ox = mx : oy = my       ' save current mouse pos.
                Cls : rec(ab).ShowB(yellow, blue, TRUE) ' show moving (diff. fill)
                For i As UInteger = 0 To UBound(rec)
                    If i <> ab Then rec(i).ShowB(black) ' show all not selected
                Next
            End If
            Sleep(10, 1)
        Wend
        If (.x + .iw) > 639 OrElse .x < 0 Then
            If (.y + .ih) > 479 OrElse .y < 0 Then
                .x = 295 : .y = 210     ' prevent box out of window
            End If
        End If
    End With
    End If

    Sleep(20, 1) : ab = -1
Loop Until Len(InKey)
' ----- EOF -----

[BasicCoder2]

The original question was "how to move an object with the mouse" and I think it was answered in my first response although I should have included mouse outside window and border limits. I have just fixed that in my first post. There has been no feedback from TurtleProgammer so you wouldn't really know.

Using an initializer routine makes sense. Ideally it would also create the object (add to list).
Something like this except perhaps using redim instead of a fixed number of rectangles possible.

Code: Select all

screenres 640,480,32

type RECTANGLE
    as integer x
    as integer y
    as integer w
    as integer h
    as integer a   'mouse on, off or down on rectangle
    as string  t   'text
end type

dim shared as integer totalRectangles
totalRectangles = 0

dim shared as RECTANGLE rec(0 To 100)  'up to 100 rectangles

sub addRectangle(x as integer,y as integer,w as integer,h as integer)
    if totalRectangles < 100 then
        rec(totalRectangles).x = x
        rec(totalRectangles).y = y
        rec(totalRectangles).w = w
        rec(totalRectangles).h = h
        totalRectangles = totalRectangles + 1
    end if
end sub

sub printRectangles()
    if totalRectangles > 0 then
        For index As Integer = 0 to totalRectangles-1
            Print rec(index).x
            print rec(index).y
            print rec(index).w
            print rec(index).h
            print "-------------"
        Next
    end if
end sub

for i as integer = 0 to 4  'add five rectangles to list
    addRectangle(int(rnd(1)*600),int(rnd(1)*400),50,50)
next i

printRectangles()

sleep

[MrSwiss]

There has been no feedback from TurtleProgammer ...

Seems, like this guy/gal hasn't been taught some manners ... It's not the first time!

Ideally it would also create the object (add to list).

Well, that would typically go towards OOP (not redim = still a array of defined size),
with: Constructor / Destructor (allocating mem to a "new" instance / freeing it again
on destruction).

[dodicat]

Maybe old Turtle is on holiday or indisposed in some way.
Anyway, if these boxes are not to be getting on top of each other, I have some running code for this:

Code: Select all

Type FBimage
    i As Any Ptr=0
    As Long w   'box width
    As Long h   'box height
    As Long x   'x,y upper left corner
    As Long y
    As Long index 'box number
    As Long px(1 To 4),py(1 To 4)'the corners
    Declare Sub show 'put image
    Declare Function InImage(As Long,As Long) As Long
    Declare Sub MoveByMouse(As Long, As Long, As Long,As Long)
    Declare Static Sub setupboxes 'custom box sizes/positions'images
    Declare Constructor
    Declare Constructor(As Any Ptr,As Long,As Long)
End Type

Redim Shared As FBimage imgs(1 To 25)

Constructor Fbimage:End Constructor
Constructor FBimage(im As Any Ptr,xpos As Long,ypos As Long)
dim as integer tmp1,tmp2 'for 64 bit compiler
i=im
Imageinfo(i,tmp1,tmp2)
w=tmp1:h=tmp2
x=xpos:y=ypos
px(1)=x:py(1)=y
px(2)=x+w:py(2)=y
px(3)=x+w:py(3)=y+h
px(4)=x:py(4)=y+h
End Constructor

Sub Fbimage.show
    Put(x,y),i,Pset
End Sub

Sub release() Destructor
    For n As Long=1 To Ubound(imgs)
        Print "destroying image ",n
        Imagedestroy imgs(n).i:imgs(n).i=0 
    Next
    Sleep
End Sub

Function FBimage.InImage(mx As Long,my As Long) As Long
    Return mx<=x+w Andalso mx>=x Andalso my<=y+h And my>=y
End Function

Sub showscreen(n As Long=0)
    Screenlock
    Cls
    For m As Long=1 To Ubound(imgs)
        imgs(m).show
    Next m
    If n Then 'box border
        For z As Long=0 To 4
            Line (imgs(n).x+z,imgs(n).y+z)-(imgs(n).x+Imgs(n).w-z,imgs(n).y+imgs(n).h-z),Rgb(0,200,255),b
        Next z
    End If
    Screenunlock
    Sleep 1,1
End Sub

Function Overlapped() As Long
    For n1 As Long=1 To Ubound(imgs)-1
        For n2 As Long=n1+1 To Ubound(imgs)
            For n3 As Long=1 To 4
                If imgs(n1).InImage(imgs(n2).px(n3),imgs(n2).py(n3)) Then  Return -1
                If imgs(n2).InImage(imgs(n1).px(n3),imgs(n1).py(n3)) Then  Return -1
            Next n3
        Next n2
    Next n1
    Return 0
End Function

Sub FBimage.MoveByMouse(mx As Long,my As Long,button As Long,n As Long)
    Dim As Long x1=mx,y1=my,dx,dy,b
    Dim As Long idx=x-mx,idy=y-my
    While button = 1
        showscreen(n)
        Getmouse mx,my,,button
        If mx>0 And my>0 Then
            If mx<>x1 Or my<>y1  Then
                dx = mx-x1
                dy = my-y1
                x1 = mx
                y1 = my
                Var i2=This
                x=x1+dx+idx
                y=y1+dy+idy
                This=Type(this.i,x,y)
                If Overlapped() Then This=i2:Exit Sub
                
            End If
        End If
    Wend
End Sub

Sub FBimage.setupboxes()
    Dim As Long counter,ctrx,ctry
    Dim As Ulong col
    For x As Long=1 To 5
        Var xpos=100+70*(x-1)
        For y As Long=1 To 5
            counter+=1
            Var ypos= 300+50*(y-1)  
            If (x + y) Mod 2 Then col=Rgb(200,0,0) Else col=Rgb(0,200,0)
            imgs(counter)=Type(Imagecreate(49,69,col),ypos,xpos)
            imgs(counter).index=counter
            'centralize the number
            Var ln=Len(Str(imgs(counter).index))
            ctrx= imgs(counter).w/2-8*ln/2
            ctry= imgs(counter).h/2-8
            Draw String imgs(counter).i,(ctrx,ctry),""&counter,Rgb(0,0,0)
        Next y
    Next x
    'create odd one out with texture
    Redim Preserve imgs(1 To 26)
    imgs(26)=Type(Imagecreate(250,40),300,451)
    For x As Long=0 To 250
        For y As Long=0 To 40
            Pset imgs(26).i,(x,y),Rgb(x*5,(x Or y)*5,y*5)
        Next
    Next
    draw string imgs(26).i,(20,5),"Odd one out"
End Sub

Screenres 900,600,32,,64
Width 900\8,600\16
FBimage.setupboxes()

Dim As Long mx,my,mb
Do
    Getmouse mx,my,,mb
    If mb=2 Then FBimage.setupboxes()
    For n As Long=1 To Ubound(imgs)
        If Imgs(n).InImage(mx,my) Then imgs(n).MoveByMouse(mx,my,mb,n):Exit For
    Next n
    showscreen()
Loop Until Len(Inkey)

 

[MrSwiss]

Hi dodicat,

a nice example of constructor / destructor use ...