These tired old eyes...

[OldMoses]

...could use a magnifier. I had done something similar on the old forum, but wanted something more portable. It mainly consists of two SUBs, one to create a color masking image and the other to acquire the portion to be magnified and apply the mask. Right mouse click magnifies the portion the mouse is hovering over, while the mousewheel controls the magnification factor. Hotkeys are "+" and "-" to increase or decrease magnifier size, and "s" to toggle a rifle scoop type reticle. Esc to quit.

It uses the screen image for navigation, but takes the magnified content from the original loaded image.

I also zipped it with several demo images, both big and small, or comment out the _LOADIMAGE code and use one of your own. It comes enabled to Bruegel's "Triumph of Death". Not so much to be macabre, but because Bruegel is the medieval periods answer to Richard Scarry. It's just chock full of details, perfect for magnification.

The '63 Chevy P/U image is a smaller image that is stretched to fit the screen so it will be noticed that Mag factor 1 will actually shrink it. The other images are larger and shrunk to fit.

Code: (Select All)

'img& = _LOADIMAGE("aslan.jpg", 32)
'img& = _LOADIMAGE("1963_chev.jpg", 32)
img& = _LOADIMAGE("bruegelII.jpg", 32)

SCREEN _NEWIMAGE(_DESKTOPWIDTH, _DESKTOPHEIGHT - 80, 32)
DO UNTIL _SCREENEXISTS: LOOP
_SCREENMOVE 0, 0

'VARIABLES
DIM SHARED msk& '                                               reticle mask handle
DIM hratio '                                                    height ratio: screen / image
DIM wratio '                                                    width ratio: screen / image
DIM ratio '                                                     ratio to shrink image to screen
DIM magsiz%
DIM magfactor%
DIM scope%%

hratio = _HEIGHT(0) / _HEIGHT(img&)
wratio = _WIDTH(0) / _WIDTH(img&)
ratio = -hratio * (hratio < wratio) - wratio * (wratio <= hratio)
magsiz% = 250
magfactor% = 2
scope%% = 0
Make_Mask magsiz%, scope%%
DO
    CLS
    Image_Resize 0, 0, _WIDTH(0) - 1, _HEIGHT(0) - 1, img&, 0, "l", "u" 'placeimage to fit screen upper left corner
    _PRINTSTRING (0, 0), "Original size " + STR$(_WIDTH(img&)) + " x " + STR$(_HEIGHT(img&))
    _PRINTSTRING (0, 16), "Ratio= " + STR$(ratio) + "  Mag. factor= " + STR$(magfactor%)
    k$ = INKEY$
    IF k$ <> "" THEN
        IF k$ = CHR$(43) THEN '                                 "+" to increase magnifier size
            magsiz% = magsiz% + 25: vin%% = -1
        END IF
        IF k$ = CHR$(45) THEN '                                 "-" to decrease magnifier size
            magsiz% = magsiz% - 25: vin%% = -1
            IF magsiz% < 25 THEN magsiz% = 25
        END IF
        IF k$ = "s" THEN '                                      "s" to toggle scope reticle
            scope%% = NOT scope%%: vin%% = -1
        END IF
        IF vin%% THEN Make_Mask magsiz%, scope%% '              if valid input then redo mask overlay
        k$ = "": vin%% = 0 '                                    clear input & and valid input flag
    END IF
    ms = MBS
    IF ms AND 1 THEN '                                          left mouse button to show magnifier
        _MOUSEHIDE
        Magnify magfactor%, img&, magsiz%, ratio
    ELSE
        _MOUSESHOW "crosshair"
    END IF
    IF ms AND 512 THEN '                                        mousewheel to change magnification factor
        magfactor% = magfactor% - 1
        IF magfactor% < 1 THEN magfactor% = 1
    END IF
    IF ms AND 1024 THEN
        magfactor% = magfactor% + 1
        IF magfactor% > 30 THEN magfactor% = 30
    END IF
    _LIMIT 30
    _DISPLAY
LOOP UNTIL _KEYDOWN(27)
END


SUB Make_Mask (s%, sc%)
    cn% = _SHR(s%, 1) - 1 '                                     image center
    IF msk& < -1 THEN _FREEIMAGE msk& '                         remove old mask if any
    IF sc% THEN '                                               if scope enabled, draw crosshairs
        ret& = _NEWIMAGE(s%, s%, 32) '                          define reticle image
        _DEST ret& '                                            destination to reticle
        CLS '
        _CLEARCOLOR _RGB32(0, 0, 0) '                           background transparent
        CIRCLE (cn%, cn%), cn%, &HFFFF0000 '                    circular border
        CIRCLE (cn%, cn%), cn% - 1, &HFFFF0000
        CIRCLE (cn%, cn%), cn% - 2, &HFFFF0000
        LINE (0, cn%)-(s% - 1, cn%), &HFFFF0000 '               scope reticle
        LINE (s% / 3, cn% + 1)-(s% * (2 / 3), cn% + 1), &HFFFF0000
        LINE (cn% + 1, s% / 3)-(cn% + 1, s% * (2 / 3)), &HFFFF0000
        LINE (cn%, 0)-(cn%, s% - 1), &HFFFF0000
    END IF
    msk& = _NEWIMAGE(s%, s%, 32) '                              create mask image
    _DEST msk&
    COLOR , _RGB32(255, 0, 255) '                               fill mask with purple to clear color in SUB Magnify
    CLS
    FCirc cn%, cn%, cn%, _RGB32(0, 0, 0) '                      apply centered black circle to clearcolor in SUB Magnify
    IF ret& < -1 THEN _PUTIMAGE , ret&: _FREEIMAGE ret& '
    _DEST 0 '
END SUB 'Make_Mask


SUB Magnify (mf%, src&, s%, r!)
    hs% = _SHR(s%, 1): hf% = hs% / mf% '                        radius and mag at radius
    x% = map!(_MOUSEX, 0, _WIDTH(src&) * r!, 0, _WIDTH(src&) - 1) 'map mouse position relative to image
    y% = map!(_MOUSEY, 0, _HEIGHT(src&) * r!, 0, _HEIGHT(src&) - 1)
    mag& = _NEWIMAGE(s%, s%, 32) '                              Create magnifier lense
    _PUTIMAGE , src&, mag&, (x% - hf%, y% - hf%)-(x% + hf%, y% + hf%) 'portion of src& to mag&
    _DEST mag&
    _CLEARCOLOR _RGB32(0, 0, 0), msk& '                         set clearcolor to inner circle of mask
    _PUTIMAGE , msk&, mag& '                                    overlay on magnifier
    _CLEARCOLOR _RGB32(255, 0, 255), mag& '                     clearcolor purple corners of mag& placed by mask
    _PUTIMAGE (_MOUSEX - hs% - 1, _MOUSEY - hs% - 1), mag&, 0 ' place finished magnifier to screen, mouse centered
    _FREEIMAGE mag&
END SUB 'Magnify


SUB FCirc (CX AS INTEGER, CY AS INTEGER, RR AS INTEGER, C AS _UNSIGNED LONG) 'by Steve McNeill
    DIM R AS INTEGER, RError AS INTEGER
    DIM X AS INTEGER, Y AS INTEGER
    R = ABS(RR)
    RError = -R
    X = R
    Y = 0
    IF R = 0 THEN PSET (CX, CY), C: EXIT SUB
    LINE (CX - X, CY)-(CX + X, CY), C, BF
    WHILE X > Y
        RError = RError + Y * 2 + 1
        IF RError >= 0 THEN
            IF X <> Y + 1 THEN
                LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
                LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
            END IF
            X = X - 1
            RError = RError - X * 2
        END IF
        Y = Y + 1
        LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
        LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
    WEND
END SUB 'FCirc


SUB Image_Resize (xpos AS INTEGER, ypos AS INTEGER, xlim AS INTEGER, ylim AS INTEGER, i AS LONG, d AS LONG, xj AS STRING, yj AS STRING)
    DIM AS INTEGER xs, ys, xp, yp, xl, yl '                     ready for OPTION EXPLICIT programs
    xp = xpos: yp = ypos: xl = xlim: yl = ylim '                isolate sent parameters from any changes
    DIM AS SINGLE rt, xrt, yrt
    xrt = (xl - xp) / _WIDTH(i) '                               width of area divided by width of image
    yrt = (yl - yp) / _HEIGHT(i) '                              height of area divided by height of image
    rt = -xrt * (xrt < yrt) - yrt * (yrt <= xrt) '              pick the smaller of the two ratios to fit area
    xs = _WIDTH(i) * rt '                                       final image size ratio in x
    ys = _HEIGHT(i) * rt '                                      final image size ratio in y
    xp = -xp * (xj = "l") - (_SHR(xl - xp, 1) + xp - _SHR(xs, 1)) * (xj = "c") - (xl - xs) * (xj = "r")
    xl = xp + xs
    yp = -yp * (yj = "u") - (_SHR(yl - yp, 1) + yp - _SHR(ys, 1)) * (yj = "c") - (yl - ys) * (yj = "d")
    yl = yp + ys
    _PUTIMAGE (xp, yp)-(xl, yl), i, d
END SUB 'Image_Resize


FUNCTION map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)
    map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!
END FUNCTION 'map!


FUNCTION MBS% 'by Steve McNeill
    STATIC StartTimer AS _FLOAT
    STATIC ButtonDown AS INTEGER
    'STATIC ClickCount AS INTEGER
    CONST ClickLimit## = .4 'Less than 1/2 of a second to down, up a key to count as a CLICK.
    '                          Down longer counts as a HOLD event.
    SHARED Mouse_StartX, Mouse_StartY, Mouse_EndX, Mouse_EndY
    WHILE _MOUSEINPUT 'Remark out this block, if mouse main input/clear is going to be handled manually in main program.
        SELECT CASE SGN(_MOUSEWHEEL)
            CASE 1: tempMBS = tempMBS OR 512
            CASE -1: tempMBS = tempMBS OR 1024
        END SELECT
    WEND
    IF _MOUSEBUTTON(1) THEN tempMBS = tempMBS OR 1
    IF _MOUSEBUTTON(2) THEN tempMBS = tempMBS OR 2
    IF _MOUSEBUTTON(3) THEN tempMBS = tempMBS OR 4
    IF StartTimer = 0 THEN
        IF _MOUSEBUTTON(1) THEN 'If a button is pressed, start the timer to see what it does (click or hold)
            ButtonDown = 1: StartTimer = TIMER(0.01)
            Mouse_StartX = _MOUSEX: Mouse_StartY = _MOUSEY
        ELSEIF _MOUSEBUTTON(2) THEN
            ButtonDown = 2: StartTimer = TIMER(0.01)
            Mouse_StartX = _MOUSEX: Mouse_StartY = _MOUSEY
        ELSEIF _MOUSEBUTTON(3) THEN
            ButtonDown = 3: StartTimer = TIMER(0.01)
            Mouse_StartX = _MOUSEX: Mouse_StartY = _MOUSEY
        END IF
    ELSE
        BD = ButtonDown MOD 3
        IF BD = 0 THEN BD = 3
        IF TIMER(0.01) - StartTimer <= ClickLimit THEN 'Button was down, then up, within time limit.  It's a click
            IF _MOUSEBUTTON(BD) = 0 THEN tempMBS = 4 * 2 ^ ButtonDown: ButtonDown = 0: StartTimer = 0
        ELSE
            IF _MOUSEBUTTON(BD) = 0 THEN 'hold event has now ended
                tempMBS = 0: ButtonDown = 0: StartTimer = 0
                Mouse_EndX = _MOUSEX: Mouse_EndY = _MOUSEY
            ELSE 'We've now started the hold event
                tempMBS = tempMBS OR 32 * 2 ^ ButtonDown
            END IF
        END IF
    END IF
    MBS% = tempMBS
END FUNCTION 'MBS%