zoom very slow(Solved)

New to FreeBASIC? Post your questions here.
Post Reply
toto971
Posts: 86
Joined: Jul 22, 2013 15:27

zoom very slow(Solved)

Post by toto971 »

Hello all,
i have this code

Code: Select all

dim shared as integer wm,mx,my,i,j,nx,ny,wn,dw,wid,hegt,zoom
dim shared as uinteger colr
dim shared as any Ptr imags,ims

ScreenRes 640, 400, 32

imags=ImageCreate(640,400)
imageinfo imags,wid,hegt
circle imags,(320,200),20,Rgb(199,1,2),,,,f
'line imags,(90,80)-(100,90),Rgb(199,1,2),bf
put (0,0),imags,trans

ims=imagecreate(wid,hegt)
do
    getmouse mx,my,wm

if dw<>0 then
    colr=point (mx,my,imags)
for i=0 to wid-1
         for j=0 to hegt-1
             if point(i,j,imags)=colr then
                                  imagedestroy ims:ims=0
                                  if dw>0 then zoom=wm         'roule + agrandissement
                                  if dw<0 then zoom=abs(1/wm)  'roule - reduction
                    pset ims,((zoom*(i-mx)+mx),(zoom*(j-my)+my)),colr
                    line ims,((zoom*(i-mx)+mx),(zoom*(j-my)+my))-((zoom*(i-mx)+mx+wm),(zoom*(j-my)+my+wm)),colr,bf
                                  ims=imagecreate(wid,hegt)
                              end if
                          next j
                      next i
                          end if
                             getmouse nx,ny,wn
                             dw=wn-wm    
loop
it zoom with wheel when cursor is in circle
some body can explain to me why it run very slow,and give me an equivalent
thanks
Last edited by toto971 on Jan 26, 2014 15:30, edited 1 time in total.
Top
sir_mud
Posts: 1401
Joined: Jul 29, 2006 3:00
Location: US
Contact:
Contact sir_mud

Re: zoom very slow

Post by sir_mud »

PSET has a fair bit of overhead and should be avoided in tight loops, search these forums for fast pset and you'll come up with a good option.
Top
toto971
Posts: 86
Joined: Jul 22, 2013 15:27

Re: zoom very slow

Post by toto971 »

i try this

Code: Select all

#macro ppset(_x,_y,colour)
   ' if onscreen then  'use if clipping needed
    pixel=row+pitch*(_y)+(_x) Shl 2
    *pixel=(colour)
   ' end if
    #endmacro

#macro p1point(_x,_y,colour)
    pixel=row+pitch*(_y)+(_x) Shl 2
    (colour)=*pixel
    #endmacro
    
dim shared as integer wm,mx,my,i,j,nx,ny,wn,dw,wid,hegt,zoom,w,h,pitch
dim shared as uinteger colr,colo
dim shared as uinteger ptr pixel
dim shared as any Ptr imags,ims
dim as any ptr row

ScreenRes 640, 400, 32

imags=ImageCreate(640,400)
imageinfo imags,wid,hegt
Screeninfo w,h,,,pitch
row=Screenptr

circle imags,(320,200),20,Rgb(199,1,2),,,,f
'line imags,(90,80)-(100,90),Rgb(199,1,2),bf
put (0,0),imags,trans

do
    getmouse mx,my,wm

if dw<>0 then
    p1point (mx,my,colr)
for i=0 to wid-1
         for j=0 to hegt-1
             p1point(i,j,colo)
             if colo=colr then
                                  if dw>0 then zoom=wm         'roule + agrandissement
                                  if dw<0 then zoom=abs(1/wm)  'roule - reduction
                                  ppset((zoom*(i-mx)+mx),(zoom*(j-my)+my),colr)
                              end if
                          next j
                      next i
                          end if
                             getmouse nx,ny,wn
                             dw=wn-wm    
loop
or

Code: Select all

#macro ppset(_x,_y,colour)
   ' if onscreen then  'use if clipping needed
    pixel=row+pitch*(_y)+(_x) Shl 2
    *pixel=(colour)
   ' end if
    #endmacro

#macro p1point(_x,_y,colour)
    pixel=row+pitch*(_y)+(_x) Shl 2
    (colour)=*pixel
    #endmacro
    
dim shared as integer wm,mx,my,i,j,nx,ny,wn,dw,wid,hegt,zoom,w,h,pitch
dim shared as uinteger colr,colo
dim shared as uinteger ptr pixel
dim shared as any Ptr imags,ims
dim as any ptr row

ScreenRes 640, 400, 32
Screeninfo w,h,,,pitch
row=Screenptr

circle (320,200),20,Rgb(199,1,2),,,,f
'line imags,(90,80)-(100,90),Rgb(199,1,2),bf

do
    getmouse mx,my,wm

if dw<>0 then
    p1point (mx,my,colr)
for i=0 to w-1
         for j=0 to h-1
             p1point(i,j,colo)
             if colo=colr then
                                  if dw>0 then zoom=wm         'roule + agrandissement
                                  if dw<0 then zoom=abs(1/wm)  'roule - reduction
                                  ppset((zoom*(i-mx)+mx),(zoom*(j-my)+my),colr)
                              end if
                          next j
                      next i
                          end if
                             getmouse nx,ny,wn
                             dw=wn-wm    
loop
but it don't work,why?
thanks
Top
BasicCoder2
Posts: 3906
Joined: Jan 01, 2009 7:03
Location: Australia

Re: zoom very slow

Post by BasicCoder2 »

toto971 wrote:Hello all,
i have this code
[...]
it zoom with wheel when cursor is in circle
some body can explain to me why it run very slow,and give me an equivalent
thanks
Can you be clearer about what the program is supposed to do?
Are you trying to change the size of the image according to how much it is scrolled?
Last edited by BasicCoder2 on Jan 26, 2014 17:40, edited 1 time in total.
Top
toto971
Posts: 86
Joined: Jul 22, 2013 15:27

Re: zoom very slow

Post by toto971 »

hello,
i have several image in screen,image(1),image(2) ...
image(x) could be a circle or a box or other
when i place mouse on image(4) for eg and when i use mouse wheel i want to change image size according wheel
wheel +1-->size+1
wheel-1-->size-1
thanks
Top
BasicCoder2
Posts: 3906
Joined: Jan 01, 2009 7:03
Location: Australia

Re: zoom very slow

Post by BasicCoder2 »

[deleted]
Last edited by BasicCoder2 on Jan 26, 2014 17:41, edited 1 time in total.
Top
MichaelW
Posts: 3500
Joined: May 16, 2006 22:34
Location: USA

Re: zoom very slow

Post by MichaelW »

This is a test of the zoom logic, which turned out to be more complex than I expected mostly because there is no way to zero the mouse wheel position counter that fbgfx maintains internally.

EDIT: Simplified the logic and added a short sleep to reduce the CPU usage.

Code: Select all

#define ZOOM_FACTOR 10
#define R_MIN       10
#define R_MAX       220

dim as integer x, y, w, w0, wdelta, rnew, r = 100

screenres 640, 480, 32
width 640\8, 480\16
circle (320, 240), r, &hff0000

do
  getmouse(x, y, w)
  if abs(320 - x) * abs(320 - x) + abs(240 - y) * abs(240 - y) < r * r then
      wdelta = w - w0
      if wdelta then
          locate 1,1
          print w;"  ",w0;"  ",wdelta;"  ";
          rnew = r + wdelta * ZOOM_FACTOR
          if rnew > R_MIN and rnew < R_MAX then
              circle (320, 240), r, 0
              r = rnew
              circle (320, 240), r, &hff0000
          end if
      end if
      sleep 10
  end if
  w0 = w
loop until inkey = chr(27)
I think it would make more sense to require the user to click the object to be zoomed to bring it into focus, then zoom it independent of the mouse cursor position, continuing until the user clicks the object a second time.

And provide the user with some sort of visual indicator when the object has the zoom focus.
Last edited by MichaelW on Jan 26, 2014 13:58, edited 3 times in total.
Top
BasicCoder2
Posts: 3906
Joined: Jan 01, 2009 7:03
Location: Australia

Re: zoom very slow

Post by BasicCoder2 »

[deleted]
Last edited by BasicCoder2 on Jan 26, 2014 17:42, edited 1 time in total.
Top
toto971
Posts: 86
Joined: Jul 22, 2013 15:27

Re: zoom very slow

Post by toto971 »

hello i find a code from D. J. Peters and Kristopher Windsor and Counting_Pine then i modify it according to my need

Code: Select all

' Map Zooming Demo!
' By Kristopher Windsor
#include "fbgfx.bi"

using fb
Type coord
  As Double x, y
End Type

Type coordi
  As Integer x, y
End Type

Declare Sub _MultiPut(Byval lpTarget As Any Ptr = 0, _
             Byval xMidPos  As Integer, _
             Byval yMidPos  As Integer, _
             Byval lpSource As Any Ptr, _
             Byval xScale   As Single = 1, _
             Byval yScale   As Single = 0, _ 'set to xScale value if not set
             Byval Rotate   As Single = 0, _
             Byval alphavalue As Integer = 255)


Dim As Integer mouse_scroll, mouse_scroll_previous,sx,sy
Dim As Double scale
Dim As any Ptr map
Dim As coordi mouse
Dim As coord mapsize, mapposition, viewportsize, viewportposition 'all coords in pixels; position is topleft pos on screen
Dim As coord zoomtarget, newzoomtarget 'based on mouse coords; but in map coords


  ScreenInfo sx,sy
  screenres sx,0.995*sy,32,,GFX_SHAPED_WINDOW
  Color RGBA(255,0,255,255),RGBA(255,0,255,255)
  cls

mouse = Type(0, 0)
mapsize = Type(sx,sy)
mapposition = Type(0, 0)
viewportsize = Type(sx, sy)
viewportposition = Type(0, 0)
scale = viewportsize.x / mapsize.x

map = imagecreate(mapsize.x, mapsize.y)
Circle map, (640, 400),50,Rgb(199,1,2),,, 1, F
'or
'line map,(600,400)-(650,450),Rgb(199,1,2),bf

Do
  mouse_scroll_previous = mouse_scroll
  If Getmouse(mouse.x, mouse.y, mouse_scroll) Then mouse_scroll = mouse_scroll_previous
  
  zoomtarget = Type((mouse.x - viewportposition.x - mapposition.x) / scale, _
    (mouse.y - viewportposition.y - mapposition.y) / scale)
  
  If mouse_scroll <> mouse_scroll_previous and point(mouse.x,mouse.y)=Rgb(199,1,2) Then
    
    Select Case mouse_scroll - mouse_scroll_previous
    Case Is < 0
      scale /= 1.1
    Case Is > 0
      scale *= 1.1
    End Select
    If scale < .05 Then scale = .05
    If scale > 5 Then scale = 5
    
    newzoomtarget = Type((mouse.x - viewportposition.x - mapposition.x) / scale, _
      (mouse.y - viewportposition.y - mapposition.y) / scale)
    With mapposition
      .x -= (zoomtarget.x - newzoomtarget.x) * scale
      .y -= (zoomtarget.y - newzoomtarget.y) * scale
    End With
  End If
  Screenlock
  Cls
  _multiput(, _
   viewportposition.x + mapsize.x * scale / 2 + mapposition.x, _ ' +mapsize.x * scale / 2 because multiput wants to center coords
    viewportposition.y + mapsize.y * scale / 2 + mapposition.y, _
    map, scale, scale)
  Screenunlock
  Sleep(10, 1)
Loop

imagedestroy(map)


' Multiput by Joshy (D. J. Peters)
' Alpha Blending by Counting_Pine
' Above said functions combined by Kristopher Windsor

'multiput(target, x, y, source, scale,, rotate, alpha)
Sub _MultiPut(Byval lpTarget As Any Ptr = 0, _
             Byval xMidPos  As Integer, _
             Byval yMidPos  As Integer, _
             Byval lpSource As Any Ptr, _
             Byval xScale   As Single = 1, _
             Byval yScale   As Single = 0, _ 'set to xScale value if not set
             Byval Rotate   As Single = 0, _
             Byval alphavalue As Integer = 255)

  If alphavalue < -1 Or alphavalue > 255 Then Exit Sub
  If xScale < 0.001 Then xScale = 0.001
  If yScale = 0 Then yScale = xScale
  If yScale < 0.001 Then yScale = 0.001

  Dim As Integer MustRotate, MustLock

  'variables for the alpha blending
  Dim As Uinteger srb = Any
  Dim As Uinteger drb = Any
  Dim As Uinteger rb = Any
  Dim As Uinteger sr = Any, sg = Any, sb = Any, sa = Any, sa2 = Any
  Dim As Uinteger dr = Any, dg = Any, db = Any, da = Any, da2 = Any
  Dim As Uinteger r = Any,  g = Any,  b = Any,  a = Any

  If lpTarget= 0 Then MustLock = 1
  If Rotate <> 0 Then MustRotate = 1

  Dim As Integer  TargetWidth,TargetHeight,TargetPitch

  If MustLock Then
    Screeninfo    _
    TargetWidth , _
    TargetHeight,,, _
    TargetPitch
    lpTarget=Screenptr
  Else
    TargetWidth  = Cptr(Uinteger Ptr,lpTarget)[2]
    TargetHeight = Cptr(Uinteger Ptr,lpTarget)[3]
    TargetPitch  = Cptr(Uinteger Ptr,lpTarget)[4]
    lpTarget    += 32
  End If

  Dim As Integer   SourceWidth,SourceHeight,SourcePitch
  If Cptr(Integer Ptr,lpSource)[0] = 7 Then
    SourceWidth  = Cptr(Uinteger Ptr,lpSource)[2]
    SourceHeight = Cptr(Uinteger Ptr,lpSource)[3]
    SourcePitch  = Cptr(Uinteger Ptr,lpSource)[4]
    lpSource    += 32
  Else
    SourceWidth  = Cptr(Ushort Ptr,lpSource)[0] Shr 3
    SourceHeight = Cptr(Ushort Ptr,lpSource)[1]
    SourcePitch  = SourceWidth
    lpSource    += 2
  End If
#define xs 0 'screen
#define ys 1
#define xt 2 'texture
#define yt 3
  Dim As Single Points(3,3)
  points(0,xs)=-SourceWidth/2 * xScale
  points(1,xs)= SourceWidth/2 * xScale
  points(2,xs)= points(1,xs)
  points(3,xs)= points(0,xs)

  points(0,ys)=-SourceHeight/2 * yScale
  points(1,ys)= points(0,ys)
  points(2,ys)= SourceHeight/2 * yScale
  points(3,ys)= points(2,ys)

  points(1,xt)= SourceWidth-1
  points(2,xt)= points(1,xt)
  points(2,yt)= SourceHeight-1
  points(3,yt)= points(2,yt)

  Dim As Uinteger i
  Dim As Single x,y
  If MustRotate Then
    For i=0 To 3
      x=points(i,xs)*Cos(Rotate) - points(i,ys)*Sin(Rotate)
      y=points(i,xs)*Sin(Rotate) + points(i,ys)*Cos(Rotate)
      points(i,xs)=x:points(i,ys)=y
    Next
  End If

  Dim As Integer yStart,yEnd,xStart,xEnd
  yStart=100000:yEnd=-yStart:xStart=yStart:xEnd=yEnd

#define LI 0   'LeftIndex
#define RI 1   'RightIndex
#define  IND 0 'Index
#define NIND 1 'NextIndex
  Dim As Integer CNS(1,1) 'Counters

  For i=0 To 3
    points(i,xs)=Int(points(i,xs)+xMidPos)
    points(i,ys)=Int(points(i,ys)+yMidPos)
    If points(i,ys)<yStart Then yStart=points(i,ys):CNS(LI,IND)=i
    If points(i,ys)>yEnd   Then yEnd  =points(i,ys)
    If points(i,xs)<xStart Then xStart=points(i,xs)
    If points(i,xs)>xEnd   Then xEnd  =points(i,xs)
  Next
  If yStart =yEnd         Then Exit Sub
  If yStart>=TargetHeight Then Exit Sub
  If yEnd   <0            Then Exit Sub
  If xStart = xEnd        Then Exit Sub
  If xStart>=TargetWidth  Then Exit Sub
  If xEnd   <0            Then Exit Sub

  Dim As Ubyte    Ptr t1,s1
  Dim As Ushort   Ptr t2,s2
  Dim As Uinteger Ptr t4,s4


#define ADD 0
#define CMP 1
#define SET 2
  Dim As Integer ACS(1,2) 'add compare and set
  ACS(LI,ADD)=-1:ACS(LI,CMP)=-1:ACS(LI,SET)=3
  ACS(RI,ADD)= 1:ACS(RI,CMP)= 4:ACS(RI,SET)=0

#define EX  0
#define EU  1
#define EV  2
#define EXS 3
#define EUS 4
#define EVS 5
  Dim As Single E(2,6),S(6),Length,uSlope,vSlope
  Dim As Integer U,UV,UA,UN,V,VV,VA,VN
  
  ' share the same highest point
  CNS(RI,IND)=CNS(LI,IND)

  ' loop from Top to Bottom
  While yStart<yEnd
    'Scan Left and Right sides together
    For i=LI To RI
      ' bad to read but fast and short ;-)
      If yStart=points(CNS(i,IND),ys) Then
        CNS(i,NIND)=CNS(i,IND)+ACS(i,Add)
        If CNS(i,NIND)=ACS(i,CMP) Then CNS(i,NIND)=ACS(i,SET)
        While points(CNS(i,IND),ys) = points(CNS(i,NIND),ys)
          CNS(i, IND)=CNS(i,NIND)
          CNS(i,NIND)=CNS(i, IND)+ACS(i,Add)
          If CNS(i,NIND)=ACS(i,CMP) Then CNS(i,NIND)=ACS(i,SET)
        Wend
        E(i,EX) = points(CNS(i, IND),xs)
        E(i,EU) = points(CNS(i, IND),xt)
        E(i,EV) = points(CNS(i, IND),yt)
        Length  = points(CNS(i,NIND),ys)
        Length -= points(CNS(i, IND),ys)
        If Length <> 0.0 Then
          E(i,EXS) = points(CNS(i, NIND),xs)-E(i,EX):E(i,EXS)/=Length
          E(i,EUS) = points(CNS(i, NIND),xt)-E(i,EU):E(i,EUS)/=Length
          E(i,EVS) = points(CNS(i, NIND),yt)-E(i,EV):E(i,EVS)/=Length
        End If
        CNS(i,IND)=CNS(i,NIND)
      End If
    Next

    If (yStart<0)                              Then Goto SkipScanLine
    xStart=E(LI,EX)+0.5:If xStart>=TargetWidth Then Goto SkipScanLine
    xEnd  =E(RI,EX)-0.5:If xEnd  < 0           Then Goto SkipScanLine
    If (xStart=xEnd)                           Then Goto SkipScanLine

    Length=xEnd-xStart
    uSlope=E(RI,EU)-E(LI,EU):uSlope/=Length
    vSlope=E(RI,EV)-E(LI,EV):vSlope/=Length
    If xstart<0 Then
      Length=Abs(xStart)
      U=Int(E(LI,EU)+uSlope*Length)
      V=Int(E(LI,EV)+vSlope*Length)
      xStart = 0
    Else
      U=Int(E(LI,EU)):V=Int(E(LI,EV))
    End If
    If xEnd>=TargetWidth Then xEnd=TargetWidth-1
    UV=Int(uSlope):UA=(uSlope-UV)*10000:UN=0
    VV=Int(vSlope):VA=(vSlope-VV)*10000:VN=0
    xEnd-=xStart

    t4=Cptr(Integer Ptr,lpTarget)+yStart*(TargetPitch Shr 2)+xStart:xStart=0
    Select Case alphavalue
    Case 255
      While xStart<xEnd
        s4=Cptr(Integer Ptr,lpSource)+V*(SourcePitch Shr 2)+U
        If (*s4 And &HFFFFFF) <> &HFF00FF Then *t4 = *s4
        U+=UV:UN+=UA:If UN>=10000 Then U+=1:UN-=10000
        V+=VV:VN+=VA:If VN>=10000 Then V+=1:VN-=10000
        If u<0 Then u=0
        If v<0 Then v=0
        xStart+=1:t4+=1
      Wend
    Case -1
      While xStart<xEnd
        s4=Cptr(Integer Ptr,lpSource)+V*(SourcePitch Shr 2)+U
        If (*s4 And &HFFFFFF) <> &HFF00FF Then
          '***** start alpha blending
          sa = *s4 Shr 24
          da = 256 - sa
          
          srb = *s4 And &h00ff00ff
          sg  = *s4 Xor srb

          drb = *t4 And &h00ff00ff
          dg  = *t4 Xor drb

          rb = (drb * da + srb * sa) And &hff00ff00
          g  = (dg  * da + sg  * sa) And &h00ff0000

          *t4 = (rb Or g) Shr 8 Or &hff000000
          '***** end alpha blending
        End If
        U+=UV:UN+=UA:If UN>=10000 Then U+=1:UN-=10000
        V+=VV:VN+=VA:If VN>=10000 Then V+=1:VN-=10000
        If u<0 Then u=0
        If v<0 Then v=0
        xStart+=1:t4+=1
      Wend
    Case Else
      sa  = alphavalue
      da  = 256 - sa
      
      While xStart<xEnd
        s4=Cptr(Integer Ptr,lpSource)+V*(SourcePitch Shr 2)+U
        If (*s4 And &HFFFFFF) <> &HFF00FF Then
          '***** start alpha blending
          srb = *s4 And &h00ff00ff
          sg  = *s4 Xor srb

          drb = *t4 And &h00ff00ff
          dg  = *t4 Xor drb

          rb = (drb * da + srb * sa) And &hff00ff00
          g  = (dg  * da + sg  * sa) And &h00ff0000

          *t4 = (rb Or g) Shr 8 Or &hff000000
          '***** end alpha blending
        End If
        U+=UV:UN+=UA:If UN>=10000 Then U+=1:UN-=10000
        V+=VV:VN+=VA:If VN>=10000 Then V+=1:VN-=10000
        If u<0 Then u=0
        If v<0 Then v=0
        xStart+=1:t4+=1
      Wend
    End Select
    
    SkipScanLine:
    E(LI,EX)+=E(LI,EXS):E(LI,EU)+=E(LI,EUS):E(LI,EV)+=E(LI,EVS)
    E(RI,EX)+=E(RI,EXS):E(RI,EU)+=E(RI,EUS):E(RI,EV)+=E(RI,EVS)
    yStart+=1:If yStart=TargetHeight Then yStart=yEnd 'exit loop
  Wend
End Sub
that exactly what i want
thanks to all
Top
dodicat
Posts: 7983
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: zoom very slow(Solved)

Post by dodicat »

You can set up a fake mouse wheel which can be reset.
Here the magnification is at the mouse, and altered my the mouse wheel, and a mouse click will reset the fake mouse wheel.

Code: Select all

 


Sub resetwheel(Byval mw As Integer,Byref flag As Integer)
    flag=mw
End Sub

Function wheel(Byval mw As Integer,flag As Integer) As Integer
    wheel= mw-flag
End Function

Sub inspector( im As Any Ptr=0)
    Dim As Integer mx,my,mw,mb,pmw:Getmouse mx,my,mw,mb
    Static As Integer flag
    mw=Abs(mw)
    Draw String(10,10),"Pseudo wheel  " &wheel(mw,flag),Rgb(0,0,0)
    If mb Then  resetwheel(mw,flag)
    Line (mx-40,my-40)-(mx+40,my+40),Rgb(100,0,0),B
    Dim As Uinteger col
    pmw=wheel(mw,flag)
    For x As Integer=mx-40 To mx+40
        For y As Integer=my-40 To my+40
            col=Point(x,y,im)
            Var NewX=pmw*(x-mx)+mx:Var NewY=pmw*(y-my)+my
            Line(NewX-pmw/2,NewY-pmw/2)-(NewX+pmw/2,NewY+pmw/2),col,BF
        Next y
    Next x
    Line (mx-40*pmw,my-40*pmw)-(mx+40*pmw,my+40*pmw),Rgb(100,0,0),B   
End Sub

Dim As Integer w,h
Screen 19,32
Screeninfo w,h
Dim As Any Ptr im=Imagecreate(w,h,Rgb(200,200,200))
'draw things to image
Line im,(w\2-60,h\2-60)-(w\2+60,h\2+60),Rgb(200,50,0),bf
For z As Integer=1 To 50
    Circle im,(Rnd*w,Rnd*h),1+Rnd*50,Rgb(Rnd*255,Rnd*255,Rnd*255),,,,f
Next z

Do
    Screenlock
    Cls
    Put(0,0),im,Pset
    inspector(im)
    Screenunlock
    Sleep 1,1
Loop Until Inkey=Chr(27)
Sleep
Imagedestroy im
Top
dodicat
Posts: 7983
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: zoom very slow(Solved)

Post by dodicat »

You can set up a fake mouse wheel which can be reset.
Here the magnification is at the mouse, and altered my the mouse wheel, and a mouse click will reset the fake mouse wheel.

Code: Select all

 


Sub resetwheel(Byval mw As Integer,Byref flag As Integer)
    flag=mw
End Sub

Function wheel(Byval mw As Integer,flag As Integer) As Integer
    wheel= mw-flag
End Function

Sub inspector( im As Any Ptr=0)
    Dim As Integer mx,my,mw,mb,pmw:Getmouse mx,my,mw,mb
    Static As Integer flag
    mw=Abs(mw)
    Draw String(10,10),"Pseudo wheel  " &wheel(mw,flag),Rgb(0,0,0)
    If mb Then  resetwheel(mw,flag)
    Line (mx-40,my-40)-(mx+40,my+40),Rgb(100,0,0),B
    Dim As Uinteger col
    pmw=wheel(mw,flag)
    For x As Integer=mx-40 To mx+40
        For y As Integer=my-40 To my+40
            col=Point(x,y,im)
            Var NewX=pmw*(x-mx)+mx:Var NewY=pmw*(y-my)+my
            Line(NewX-pmw/2,NewY-pmw/2)-(NewX+pmw/2,NewY+pmw/2),col,BF
        Next y
    Next x
    Line (mx-40*pmw,my-40*pmw)-(mx+40*pmw,my+40*pmw),Rgb(100,0,0),B   
End Sub

Dim As Integer w,h
Screen 19,32
Screeninfo w,h
Dim As Any Ptr im=Imagecreate(w,h,Rgb(200,200,200))
'draw things to image
Line im,(w\2-60,h\2-60)-(w\2+60,h\2+60),Rgb(200,50,0),bf
For z As Integer=1 To 50
    Circle im,(Rnd*w,Rnd*h),1+Rnd*50,Rgb(Rnd*255,Rnd*255,Rnd*255),,,,f
Next z

Do
    Screenlock
    Cls
    Put(0,0),im,Pset
    inspector(im)
    Screenunlock
    Sleep 1,1
Loop Until Inkey=Chr(27)
Sleep
Imagedestroy im
Top
BasicCoder2
Posts: 3906
Joined: Jan 01, 2009 7:03
Location: Australia

Re: zoom very slow(Solved)

Post by BasicCoder2 »

dodicat wrote:You can set up a fake mouse wheel which can be reset.
Here the magnification is at the mouse, and altered my the mouse wheel, and a mouse click will reset the fake mouse wheel.
Excellent solution and demo. A variable magnifying glass. I tried it with a photo image.
bload "c:/FreeBasic/magnify/pic.bmp",im
For some reason at its minimum the magnification of the image is upside down and back the front?
The orientation is ok when I scroll up the magnification.
Top
dodicat
Posts: 7983
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: zoom very slow(Solved)

Post by dodicat »

Yea,thanks BasicCoder2., it could be refined I suppose.
For some reason my post shows twice!
At Jan 26, 2014, 1811 local time.
Strange?
Top
toto971
Posts: 86
Joined: Jul 22, 2013 15:27

Re: zoom very slow(Solved)

Post by toto971 »

hello,
very good code dodicat
thanks
Top
Post Reply

Return to “Beginners”