Welcome, Guest
You have to register before you can post on our site.

Username/Email:
  

Password
  





Search Forums

(Advanced Search)

Forum Statistics
» Members: 308
» Latest member: Donaldvem
» Forum threads: 1,741
» Forum posts: 17,901

Full Statistics

Latest Threads
The QB64 IDE shell
Forum: Utilities
Last Post: JasonPag
09-16-2024, 05:37 PM
» Replies: 9
» Views: 762
Importance regarding Ches...
Forum: Utilities
Last Post: JasonPag
09-01-2024, 06:34 PM
» Replies: 0
» Views: 31
Chess and Analysis and En...
Forum: Utilities
Last Post: JasonPag
08-28-2024, 02:37 PM
» Replies: 0
» Views: 32
DAY 009:_PutImage
Forum: Keyword of the Day!
Last Post: grymmjack
09-02-2023, 02:57 PM
» Replies: 54
» Views: 2,034
Fall Banner Contest?
Forum: Site Suggestions
Last Post: grymmjack
08-31-2023, 11:50 PM
» Replies: 36
» Views: 1,261
ColorPicker - Function th...
Forum: Dav
Last Post: Dav
08-31-2023, 11:04 PM
» Replies: 3
» Views: 315
Goals(1) = New Tile()
Forum: Works in Progress
Last Post: RhoSigma
08-31-2023, 09:45 PM
» Replies: 3
» Views: 127
micro(A)v11
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:14 PM
» Replies: 90
» Views: 3,589
Updating The Single Most ...
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:13 PM
» Replies: 7
» Views: 254
QBJS Image Question
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 05:49 PM
» Replies: 5
» Views: 155

 
  3D Terrain
Posted by: james2464 - 01-08-2023, 09:24 PM - Forum: Help Me! - Replies (25)

I've managed to figure out how to produce random terrain using a grid of triangles, and then assigning a slightly random z value to the points.   It's very primitive but could be useful to build on.   

But for now I'm stuck on how to detect or collide with this terrain.   It might be very complicated, or perhaps not.   Right now the spectator viewing is just like ghost mode, as in you can fly around and go through everything.   I'd like to make it so you can't pass through the textures at all.   Then if I can choose some textures as OK to pass throught (such as water surface) and others NOT OK to pass through, such as land, that would be ideal.   And later on, I'd like to be able to put a character on the surface and control it.    For now though, I'd like to understand how to detect these surfaces.    A square/rectangle room is not a problem, because you can just set limits on X,Y,Z movement.   Any flat surface is easy this way.   But the random terrain seems to need a different approach.

Code: (Select All)
'3d terrain on water - james2464 - Jan 2023
'Credit to 3D program and tutorial by MasterGy

Option _Explicit
Randomize Timer

Screen _NewImage(1000, 1000, 32)

Const pip180 = 3.141592 / 180

Dim Shared c(100) As Long
Dim scr, da, db, da2, dega, db2, degb, ss, ap, sqa
Dim sky_points, sky_image, actual_point, asq
Dim wx0, wy0, wz0, wx1, wy1, wz1, wx2, wy2, wz2, wx3, wy3, wz3, sx0, sy0, sx1, sy1, sx2, sy2, sx3, sy3
Dim mousex, mousey, mw, mouse_sens, vec_x, vec_y, vec_z, speed, moving
Dim sp3
Dim t, x, y, h, b, tz
Dim Shared trx(5000), try(5000), trz(5000) 'terrain points
Dim Shared fr1(5000), fr2(5000), fr3(5000), fr4(5000), fr5(5000), fr6(5000) 'terrain point groups  (hex)
Dim Shared maxterrain, maxp, shx, shy, shz

Cls


colour1

Dim Shared floor1, wall1, wall2, ground1, sky1, cbx(20)



wall1 = _NewImage(500, 100, 32): makewall
wall2 = _NewImage(500, 100, 32): makewall2
ground1 = _NewImage(500, 500, 32): makeground
'ground1 = _LoadImage("painting.jpg", 32)
sky1 = _NewImage(750, 750, 32): makesky

maketerrain

For t = 0 To 10: cbx(t) = _NewImage(400, 400, 32): Next t: makepallette

Dim Shared tximage(200)
For t = 0 To 10: tximage(t) = _CopyImage(cbx(t), 33): Next t

tximage(11) = _CopyImage(ground1, 33)
tximage(12) = _CopyImage(wall1, 33) 'office wall solid
tximage(13) = _CopyImage(wall2, 33) 'office wall with 3 windows


Type mapobject
    n As Integer 'object number
    x As Single 'x origin
    y As Single 'y origin
    z As Single 'z origin
    x1 As Single
    y1 As Single
    z1 As Single
    x2 As Single
    y2 As Single
    z2 As Single
    x3 As Single
    y3 As Single
    z3 As Single
    x4 As Single
    y4 As Single
    z4 As Single
    ix As Single 'image x
    iy As Single 'image y
    in As Integer 'image number - tximage()
End Type
Dim Shared raw(100) As mapobject, oo(900) As mapobject

'create texture point data array
Dim Shared tx(500, 19), txtot, rawtxtot

'objects and data points
Data 1,0,0,0,-1000,0,200,-1000,0,-200,1000,0,200,1000,0,-200,500,100,12: 'wall
Data 2,0,0,0,-4000,-4000,0,-4000,4000,0,4000,-4000,0,4000,4000,0,500,100,3: 'water

rawtxtot = 2: txtot = rawtxtot

'read data into array tx()
Dim t2
For t = 1 To txtot
    For t2 = 1 To 19
        Read tx(t, t2)
    Next t2
    'create 'raw' objects
    raw(t).n = tx(t, 1): raw(t).x = tx(t, 2): raw(t).y = tx(t, 3): raw(t).z = tx(t, 4)
    raw(t).x1 = tx(t, 5): raw(t).y1 = tx(t, 6): raw(t).z1 = tx(t, 7)
    raw(t).x2 = tx(t, 8): raw(t).y2 = tx(t, 9): raw(t).z2 = tx(t, 10)
    raw(t).x3 = tx(t, 11): raw(t).y3 = tx(t, 12): raw(t).z3 = tx(t, 13)
    raw(t).x4 = tx(t, 14): raw(t).y4 = tx(t, 15): raw(t).z4 = tx(t, 16)
    raw(t).ix = tx(t, 17): raw(t).iy = tx(t, 18): raw(t).in = tx(t, 19)
Next t


'object copies
Dim nn, nc, xc, yc, zc, ac
'nn = 1: nc = 1: xc = 0: yc = 0: zc = 400: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'wall
nn = 1: nc = 2: xc = 0: yc = 0: zc = 500: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'water


'create spectator
Dim Shared sp(6)
sp(0) = 0 'X position
sp(1) = 1500 'Y
sp(2) = 400 'Z
sp(3) = 0 'looking in the direction of the observer XZ
sp(4) = 0 'looking in the direction of the observer YZ
sp(5) = 1 'multiplier X-Y see
sp(6) = 1 'multiplier Z see

'create screen
scr = _NewImage(1000, 1000 / _DesktopWidth * _DesktopHeight, 32)
Screen scr
_MouseHide
_FullScreen
_Dest scr
_DisplayOrder _Hardware , _Software


'sky install
da = 11 'resolution sphere X
db = 7 'resolution sphere Y

sky_points = da * db
Dim sky_points(sky_points - 1, 9), sq(sky_points - 1, 7)
'sky_image = _LoadImage("sky.jpg", 33)
sky_image = _CopyImage(sky1, 33)

For da2 = 0 To da - 1
    dega = 360 / (da - 1) * da2 * pip180
    For db2 = 0 To db - 1
        degb = 180 / (db - 1) * db2 * pip180
        ss = 4000
        ap = da2 * db + db2
        sky_points(ap, 0) = Sin(degb) * Cos(dega) * ss
        sky_points(ap, 1) = Sin(degb) * Sin(dega) * ss
        sky_points(ap, 2) = Cos(degb) * ss
    Next db2
Next da2

For da2 = 0 To da - 2
    For db2 = 0 To db - 2
        sqa = da2 * db + db2
        sq(sqa, 0) = sqa
        sq(sqa, 1) = sq(sqa, 0) + 1
        sq(sqa, 2) = sq(sqa, 0) + db
        sq(sqa, 3) = sq(sqa, 2) + 1
        sq(sqa, 4) = _Width(sky_image) - (_Width(sky_image) / (da - 1) * da2) - 1
        sq(sqa, 5) = _Width(sky_image) - (_Width(sky_image) / (da - 1) * (da2 + 1)) - 1
        sq(sqa, 6) = Int(_Height(sky_image) / (db - 1) * db2)
        sq(sqa, 7) = Int(_Height(sky_image) / (db - 1) * (db2 + 1))
    Next db2
Next da2


'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================

Do
    _Limit 40

    processterrain
    processtextures



    'draw sky    *********************************************************************************
    't = 1  'use for checkered sky

    'rotating
    For actual_point = 0 To sky_points - 1
        sky_points(actual_point, 4) = sky_points(actual_point, 0)
        sky_points(actual_point, 5) = sky_points(actual_point, 1)
        sky_points(actual_point, 6) = sky_points(actual_point, 2)
        r2m sky_points(actual_point, 4), sky_points(actual_point, 5), sky_points(actual_point, 6)
    Next actual_point

    For asq = 0 To sky_points - 1
        wx0 = sky_points(sq(asq, 0), 4) + 0: wy0 = sky_points(sq(asq, 0), 5) + 0: wz0 = sky_points(sq(asq, 0), 6)
        wx1 = sky_points(sq(asq, 1), 4) + 0: wy1 = sky_points(sq(asq, 1), 5) + 0: wz1 = sky_points(sq(asq, 1), 6)
        wx2 = sky_points(sq(asq, 2), 4) + 0: wy2 = sky_points(sq(asq, 2), 5) + 0: wz2 = sky_points(sq(asq, 2), 6)
        wx3 = sky_points(sq(asq, 3), 4) + 0: wy3 = sky_points(sq(asq, 3), 5) + 0: wz3 = sky_points(sq(asq, 3), 6)
        sy0 = sq(asq, 6): sx0 = sq(asq, 4): sy1 = sq(asq, 7): sx1 = sq(asq, 4): sy2 = sq(asq, 6): sx2 = sq(asq, 5): sy3 = sq(asq, 7): sx3 = sq(asq, 5)
        't = t * -1 'use for checkered sky
        'If t > 0 Then 'use for checkered sky
        _MapTriangle (sx0, sy0)-(sx1, sy1)-(sx2, sy2), sky_image To(wx0, wy0, wz0)-(wx1, wy1, wz1)-(wx2, wy2, wz2), , _Smooth
        _MapTriangle (sx3, sy3)-(sx1, sy1)-(sx2, sy2), sky_image To(wx3, wy3, wz3)-(wx1, wy1, wz1)-(wx2, wy2, wz2), , _Smooth
        'End If 'use for checkered sky
    Next asq
    ' ****************************************************************************************************

    _Display


    '-------------------------------------------------------------
    'mouse input axis movement and mousewheel
    '-------------------------------------------------------------
    mousex = mousex * .6
    mousey = mousey * .6
    mw = 0
    While _MouseInput: mousex = mousex + _MouseMovementX: mousey = mousey + _MouseMovementY: mw = mw + _MouseWheel: Wend 'movement data read

    'control spectator
    mouse_sens = .0007 'mouse rotating sensitive
    sp(3) = sp(3) - mousex * mouse_sens
    sp(4) = sp(4) + mousey * mouse_sens
    If Abs(sp(4)) > _Pi / 2 Then sp(4) = _Pi / 2 * Sgn(sp(4))
    sp3 = sp(3) + (_KeyDown(Asc("d")) - _KeyDown(Asc("a"))) * 90 * pip180
    vec_x = (Sin(sp3) * (Cos(sp(4) + _Pi)))
    vec_y = (Cos(sp3) * (Cos(sp(4) + _Pi)))
    vec_z = -Sin(sp(4) + _Pi)
    If _KeyDown(Asc("a")) Or _KeyDown(Asc("d")) Then vec_z = 0
    speed = 2.5 'moving speed
    moving = Abs(_MouseButton(1) Or _KeyDown(Asc("w")) Or _KeyDown(Asc("a")) Or _KeyDown(Asc("d"))) * speed - Abs(_MouseButton(2) Or _KeyDown(Asc("s"))) * speed
    sp(0) = sp(0) + vec_x * moving
    sp(1) = sp(1) + vec_y * moving
    sp(2) = sp(2) + vec_z * moving

    'If sp(0) > 465 Then sp(0) = 465
    'If sp(1) > 465 Then sp(1) = 465
    'If sp(0) < -465 Then sp(0) = -465
    'If sp(1) < -465 Then sp(1) = -465

Loop Until _KeyDown(27)



'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================



Sub r2m (x, y, z)
    Dim x2, y2, z2
    x2 = x - sp(0)
    y2 = y - sp(1)
    z2 = z - sp(2)
    rotate_2d x2, y2, sp(3)
    rotate_2d y2, z2, sp(4) + _Pi / 2
    x = x2 * sp(5)
    y = y2 * sp(5)
    z = z2 * sp(6)
End Sub

Sub rotate_2d (x, y, ang)
    Dim x1, y1
    x1 = x * Cos(ang) - y * Sin(ang)
    y1 = x * Sin(ang) + y * Cos(ang)
    x = x1: y = y1
End Sub



Sub processtextures
    Dim t, x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4

    For t = 1 To txtot
        x1 = oo(t).x1: y1 = oo(t).y1: z1 = oo(t).z1
        x2 = oo(t).x2: y2 = oo(t).y2: z2 = oo(t).z2
        x3 = oo(t).x3: y3 = oo(t).y3: z3 = oo(t).z3
        x4 = oo(t).x4: y4 = oo(t).y4: z4 = oo(t).z4
        x = oo(t).ix: y = oo(t).iy
        r2m x1, y1, z1
        r2m x2, y2, z2
        r2m x3, y3, z3
        r2m x4, y4, z4
        _MapTriangle (0, 0)-(0, y)-(x, 0), tximage(oo(t).in) To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
        _MapTriangle (x, y)-(0, y)-(x, 0), tximage(oo(t).in) To(x4, y4, z4)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
    Next t

End Sub

Sub processterrain
    Dim t, t2, x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
    Dim xx1, yy1, zz1, xx2, yy2, zz2, xx3, yy3, zz3, xx4, yy4, zz4
    Dim flag, ct, scale1, txm
    flag = 0
    ct = 0
    scale1 = 2.
    shx = -500 'shift x position
    shy = -500 'shift y position
    shz = 502 'shift z position

    Do
        ct = ct + 1

        x1 = trx(fr1(ct)): y1 = try(fr1(ct)): z1 = trz(fr1(ct))
        x2 = trx(fr2(ct)): y2 = try(fr2(ct)): z2 = trz(fr2(ct))
        x3 = trx(fr3(ct)): y3 = try(fr3(ct)): z3 = trz(fr3(ct))

        xx1 = x1: yy1 = y1
        xx2 = x2: yy2 = y2
        xx3 = x3: yy3 = y3


        x1 = x1 * scale1: y1 = y1 * scale1: 'z1 = z1 * scale1
        x2 = x2 * scale1: y2 = y2 * scale1: 'z2 = z2 * scale1
        x3 = x3 * scale1: y3 = y3 * scale1: 'z3 = z3 * scale1


        x1 = x1 + shx: y1 = y1 + shy: z1 = z1 + shz
        x2 = x2 + shx: y2 = y2 + shy: z2 = z2 + shz
        x3 = x3 + shx: y3 = y3 + shy: z3 = z3 + shz


        r2m x1, y1, z1
        r2m x2, y2, z2
        r2m x3, y3, z3

        txm = 11
        _MapTriangle (xx1, yy1)-(xx2, yy2)-(xx3, yy3), tximage(txm) To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth

        If ct >= maxp Then flag = 1
    Loop Until flag = 1

End Sub


Sub objectcopy (nn, nc, xc, yc, zc, ac)
    Dim ct, t, t2, xt, yt
    ct = 0
    For t = 1 To rawtxtot
        If raw(t).n = nc Then
            ct = ct + 1
            t2 = txtot + ct
            oo(t2).n = nn: oo(t2).x = xc: oo(t2).y = yc: oo(t2).z = zc
            xt = raw(t).x1: yt = raw(t).y1: xyrotation xt, yt, ac: oo(t2).x1 = xt + xc: oo(t2).y1 = yt + yc: oo(t2).z1 = raw(t).z1 + zc
            xt = raw(t).x2: yt = raw(t).y2: xyrotation xt, yt, ac: oo(t2).x2 = xt + xc: oo(t2).y2 = yt + yc: oo(t2).z2 = raw(t).z2 + zc
            xt = raw(t).x3: yt = raw(t).y3: xyrotation xt, yt, ac: oo(t2).x3 = xt + xc: oo(t2).y3 = yt + yc: oo(t2).z3 = raw(t).z3 + zc
            xt = raw(t).x4: yt = raw(t).y4: xyrotation xt, yt, ac: oo(t2).x4 = xt + xc: oo(t2).y4 = yt + yc: oo(t2).z4 = raw(t).z4 + zc
            oo(t2).ix = raw(t).ix: oo(t2).iy = raw(t).iy: oo(t2).in = raw(t).in
        End If
    Next t
    txtot = txtot + ct
End Sub



Sub xyrotation (x, y, a)
    Dim xt, yt, h, h1, h2, xt2, yt2
    xt = x: yt = y
    h = _Hypot(yt, xt)
    h1 = _Atan2(xt, yt)
    h2 = h1 - a
    xt2 = Sin(h2) * h
    yt2 = Cos(h2) * h
    x = xt2
    y = yt2
End Sub



Sub makefloor
    Dim t, x1, y1
    Cls
    Line (0, 0)-(500, 500), c(18), BF 'floor background

    For t = 1 To 6000
        x1 = Int(Rnd * 500): y1 = Int(Rnd * 500): PSet (x1, y1), c(0)
        x1 = Int(Rnd * 500): y1 = Int(Rnd * 500): PSet (x1, y1), c(2)
        x1 = Int(Rnd * 500): y1 = Int(Rnd * 500): PSet (x1, y1), c(3)
    Next t
    '_Display
    _PutImage (0, 0)-(500, 500), 0, floor1, (0, 0)-(500, 500)
    'Sleep
End Sub



Sub makewall
    Dim t, x1, y1
    Cls
    Line (0, 0)-(500, 100), c(7), BF 'wall background
    For t = 1 To 6000
        x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(8)
        x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(9)
    Next t
    '_Display
    _PutImage (0, 0)-(500, 100), 0, wall1, (0, 0)-(500, 100)
    _ClearColor c(0), wall1
    'Sleep
End Sub


Sub makewall2
    Dim t, x1, y1
    Cls
    Line (0, 0)-(500, 100), c(7), BF 'wall2 background
    For t = 1 To 6000
        x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(8)
        x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(9)
    Next t
    Line (70, 25)-(150, 75), c(0), BF
    Line (210, 25)-(290, 75), c(0), BF
    Line (350, 25)-(430, 75), c(0), BF
    '_Display
    _PutImage (0, 0)-(500, 100), 0, wall2, (0, 0)-(500, 100)
    _ClearColor c(0), wall2
    'Sleep
End Sub




Sub makeground
    Dim t, x1, y1, s, s2
    s = 220
    s2 = (500 - s) / 2
    Cls
    Line (0, 0)-(500, 500), c(14), BF 'border/beach
    Line (0, 0)-(500, 500), c(40), BF 'ground background
    For t = 1 To 155
        x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
        Line (x1 - 30, y1 - 30)-(x1 + 30, y1 + 30), c(41), BF
        x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
        Line (x1 - 50, y1 - 50)-(x1 + 50, y1 + 50), c(42), BF
        x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
        Line (x1 - 20, y1 - 20)-(x1 + 20, y1 + 20), c(43), BF
        x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
        Line (x1 - 20, y1 - 20)-(x1 + 20, y1 + 20), c(44), BF
    Next t
    s = 790
    s2 = (500 - s) / 2

    For t = 1 To 7500
        x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
        PSet (x1, y1), c(41)
        x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
        PSet (x1, y1), c(42)
        x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
        PSet (x1, y1), c(43)
        x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
        PSet (x1, y1), c(44)
        x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
        PSet (x1, y1), c(41)
        x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
        PSet (x1, y1), c(42)
        x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
        PSet (x1, y1), c(43)
        x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
        PSet (x1, y1), c(44)

    Next t
    'Line (5, 5)-(495, 10), c(31), BF
    'Line (5, 495)-(495, 490), c(32), BF
    'Line (490, 5)-(495, 495), c(33), BF
    'Line (5, 5)-(10, 495), c(34), BF
    '_Display
    _PutImage (0, 0)-(500, 500), 0, ground1, (0, 0)-(500, 500)
    'Sleep
End Sub







Sub maketerrain
    Dim t, s, x, y, x1, y1, p, q, p2, ct, ct2, flag
    Dim xt, yt, xh, yh, vc, fx, fx1, fx2, mx, oldct
    Cls
    Line (0, 0)-(500, 500), c(1), B
    t = 0
    x1 = 500: y1 = 500
    s = 25
    fx = 1
    maxterrain = 0
    'create points  (trx,try,trz)
    For y = 0 To y1 Step s

        fx = Int(fx * -1)
        If fx > 0 Then
            fx1 = 0
        Else fx1 = s / 2
        End If

        For x = fx1 To x1 Step s
            t = t + 1
            trx(t) = x: try(t) = y
            Circle (x, y), 3, c(1)
            If x > s And x < x1 - s Then
                If y > s And y < y1 - s Then
                    'trz(t) = 0
                    trz(t) = 0 - Int(Rnd * 17) - 5
                    xh = Abs(trx(t) - x1 / 2)
                    yh = Abs(try(t) - y1 / 2)
                    vc = _Hypot(xh, yh)
                    vc = 170 - vc
                    trz(t) = trz(t) - vc / 4
                    'trz(t) = trz(t) - (Int(Rnd * vc))
                End If
            End If
        Next x
    Next y
    '_Display
    'Sleep
    maxterrain = t


    'display points
    p = Int(x1 / s) + 1
    q = Int(y1 / s) - 1
    fx = 1
    t = 0
    oldct = 0

    For y = 0 To y1 Step s
        fx = Int(fx * -1)
        If fx > 0 Then
            fx1 = 0
        Else fx1 = s / 2
        End If
        For x = fx1 To x1 Step s
            t = t + 1
            If y > s Then
                If x > s Then
                    If x < x1 - s Then
                        If y < y1 - s Then
                            Circle (trx(t), try(t)), 2, c(1)
                            Circle (trx(t), try(t)), 1, c(1)
                            Circle (trx(oldct), try(oldct)), 2, c(0)
                            Circle (trx(oldct), try(oldct)), 1, c(0)
                            'Line (trx(t), try(t))-(trx(t - p), try(t - p)), c(1)
                            'Line (trx(t), try(t))-(trx(t - p + 1), try(t - p + 1)), c(1)
                            'Line (trx(t), try(t))-(trx(t + p - 1), try(t + p - 1)), c(1)
                            'Line (trx(t), try(t))-(trx(t + p), try(t + p)), c(1)
                            'Line (trx(t), try(t))-(trx(t - 1), try(t - 1)), c(1)
                            'Line (trx(t), try(t))-(trx(t + 1), try(t + 1)), c(1)
                            oldct = t
                            '_Display
                            'Sleep
                            'Line (trx(t), try(t))-(trx(t - p), try(t - p)), c(0)
                            'Line (trx(t), try(t))-(trx(t - p + 1), try(t - p + 1)), c(0)
                            'Line (trx(t), try(t))-(trx(t + p - 1), try(t + p - 1)), c(0)
                            'Line (trx(t), try(t))-(trx(t + p), try(t + p)), c(0)
                            'Line (trx(t), try(t))-(trx(t - 1), try(t - 1)), c(0)
                            'Line (trx(t), try(t))-(trx(t + 1), try(t + 1)), c(0)

                        End If
                    End If
                End If
            End If
        Next x
    Next y

    '_Display
    'Sleep


    'create point groups (fr1,fr2,fr3)
    p = Int(x1 / s) + 1
    q = Int(y1 / s) - 1
    fx = 1
    t = 0
    ct = 0
    oldct = 0

    For y = 0 To y1 - 1 Step s
        fx = Int(fx * -1)
        If fx > 0 Then
            fx1 = 0
        Else fx1 = s / 2
        End If
        For x = fx1 To x1 Step s
            t = t + 1
            If fx > 0 Then

                ct = ct + 1
                fr1(ct) = t
                fr2(ct) = t - p
                fr3(ct) = t - p + 1
                Line (trx(t), try(t))-(trx(t - p), try(t - p)), c(32)
                Line (trx(t), try(t))-(trx(t - p + 1), try(t - p + 1)), c(32)
                Line (trx(t - p), try(t - p))-(trx(t - p + 1), try(t - p + 1)), c(32)
                '_Display
                'Sleep

                ct = ct + 1
                fr1(ct) = t
                fr2(ct) = t + p
                fr3(ct) = t + p - 1
                Line (trx(t), try(t))-(trx(t + p), try(t + p)), c(1)
                Line (trx(t), try(t))-(trx(t + p - 1), try(t + p - 1)), c(1)
                Line (trx(t + p), try(t + p))-(trx(t + p - 1), try(t + p - 1)), c(1)
                '_Display
                'Sleep

            Else

                ct = ct + 1
                fr1(ct) = t
                fr2(ct) = t + p
                fr3(ct) = t + p - 1
                Line (trx(t), try(t))-(trx(t + p), try(t + p)), c(33)
                Line (trx(t), try(t))-(trx(t + p - 1), try(t + p - 1)), c(33)
                Line (trx(t + p), try(t + p))-(trx(t + p - 1), try(t + p - 1)), c(33)
                '_Display
                'Sleep

                ct = ct + 1
                fr1(ct) = t + p + p - 1
                fr2(ct) = t + p
                fr3(ct) = t + p - 1
                Line (trx(t + p + p - 1), try(t + p + p - 1))-(trx(t + p), try(t + p)), c(34)
                Line (trx(t + p + p - 1), try(t + p + p - 1))-(trx(t + p - 1), try(t + p - 1)), c(34)
                Line (trx(t + p), try(t + p))-(trx(t + p - 1), try(t + p - 1)), c(34)
                '_Display
                'Sleep
            End If


            oldct = t
            Locate 35, 1
            Print t, ct
            '_Display
            'Sleep
        Next x
    Next y
    maxp = ct


    'fr1(t) = t - p
    'fr2(t) = t - p + 1
    'fr3(t) = t + p - 1




    'Cls
    't = t + 1
    'For ct = 1 To t
    'Print fr1(ct), fr2(ct), fr3(ct)
    'Next ct



    '_Display
    'Sleep

End Sub





Sub makesky
    Dim t, y, m
    Cls
    y = 750
    For t = 1 To y
        m = 255 * ((750 - t * .65) / 750)
        c(99) = _RGBA(200, 200, 255, m)
        Line (0, t)-(750, t), c(99)
    Next t
    'For t = 0 To 750 Step 25 'longituge lines
    'Line (t, 0)-(t, 750), c(1)
    'Next t
    'For t = 0 To 750 Step 25 'latitude lines
    'Line (0, t)-(750, t), c(1)
    'Next t
    '_Display
    _PutImage (0, 0)-(750, 750), 0, sky1, (0, 0)-(750, 750)
    'Sleep
End Sub




Sub makepallette
    Dim t
    For t = 0 To 10
        Cls
        Line (0, 0)-(400, 400), c(t), BF
        _PutImage (0, 0)-(400, 400), 0, cbx(t), (0, 0)-(400, 400)
        '_Display
        'Sleep
    Next t
End Sub



Sub colour1
    c(0) = _RGB(0, 0, 0)
    c(1) = _RGB(255, 255, 255)
    c(2) = _RGB(35, 25, 10)
    c(3) = _RGB(10, 45, 65)
    c(4) = _RGB(40, 50, 10)
    c(5) = _RGB(0, 25, 75)
    c(6) = _RGB(45, 35, 20)
    c(7) = _RGB(150, 150, 150)
    c(8) = _RGB(125, 125, 125)
    c(9) = _RGB(100, 100, 100)
    c(10) = _RGBA(75, 75, 75, 151)
    c(11) = _RGB(0, 0, 0)
    c(12) = _RGB(35, 25, 10)
    c(13) = _RGB(0, 45, 85)
    c(14) = _RGB(160, 150, 100)
    c(15) = _RGB(0, 25, 75)
    c(16) = _RGB(55, 25, 30)
    c(17) = _RGB(175, 175, 175)
    c(18) = _RGB(100, 100, 100)
    c(20) = _RGB(20, 30, 15)
    c(31) = _RGB(255, 255, 255)
    c(32) = _RGB(255, 0, 0)
    c(33) = _RGB(0, 55, 255)
    c(34) = _RGB(255, 255, 0)
    c(40) = _RGBA(45, 20, 25, 125)
    c(41) = _RGBA(50, 50, 30, 40)
    c(42) = _RGBA(20, 30, 15, 40)
    c(43) = _RGBA(75, 45, 15, 40)
    c(44) = _RGBA(40, 60, 30, 40)
    c(45) = _RGB(50, 50, 30)
    c(46) = _RGB(20, 30, 15)
    c(47) = _RGB(55, 45, 15)
    c(48) = _RGB(40, 50, 10)

End Sub

Print this item

  SAC -- Steve's Anorexic Code
Posted by: SMcNeill - 01-08-2023, 03:21 AM - Forum: SMcNeill - Replies (2)

Ahhh...  The smell of the past!  Many thanks to @keybone who dug up this old gem from the long lost days of the original qb64 forums over at .net, when Galleon was still around and in charge of things.

Code: (Select All)
'Steve's Anorexic Code
'This code has a very unique value to us.
'1) This allows us to append files to the end of our exe's very easily, and then extract them and clean them up afterwards.
'2) This works at a command line level, and lets us shell out from inside a program itself.

'To use this, first try it a few times with some BACKED UP copy of test files!!
'BACK EM UP!! BACK EM UP!! BACK EM UP!!

'Got that?  Good.

'Then run this as a standard program.
'Enter the name of the file you'd like to feed stuff to.
'And at first, -SET THE TABLE  Do this only once, as this sets us a counter for number of files "eatten"
'Then feed it something.  -GOBBLE filename$  <-- this is the file we tack to the end of our exe
'Feed it more files if you want.  Watch the exe grow in size as it absorbs the other files...

'Is it fat?  Did you feed it enough?
'If so, then -PUKE or -BARF  Throw them files back up!

'Phew!  Didn't that make a mess?
'Then -CLEAN UP
'See all them files go POOF and disappear again?  We clean up our mess afterwards.

'But this is MAGIC Anorexic Code!  The exe still has all those files in it that it barfed up.
'Tell it to -PUKE again.
'All those files are back once more!!

'Use this as a quick, easy way to tack needed files onto your exe to make certain that an user will always have them.
'I use this to  tack sound files, fonts, even images to my exe, and I extract them as needed.

'NOTE however, that this isn't just limited to EXE files.  You can use this to assemble 100 map files into 1 map compendium,
'  and then extract them when needed.  At the moment, we don't puke single files up -- we puke every file up -- but
'  someone could modify this easily enough to extract single files from a larger collection.

'To use as a shell command, use it like the following:
'  Shell _hide "SAC.exe g.exe -gobble z:\test.txt"    <--- this would add the test.txt file to the end of the g.exe file'
'  syntax is:  SAC.exe file1$ -command file2$
'      file1$ would be the file we want to write to -- or feed.
'      -command is the -command which we want to execute.  -SET THE TABLE, -GOBBLE, -BARF, -CLEAN UP

'Simple, and useful as heck!  :D


Dim Shared SAC_FileName As String
parameter$ = LTrim$(RTrim$(Command$))
If parameter$ <> "" Then
    dash = InStr(parameter$, "-")
    SAC_FileName = LTrim$(RTrim$(Left$(parameter$, dash - 1)))
    parameter$ = RTrim$(LTrim$(Right$(parameter$, Len(parameter$) - dash + 1)))
    Print SAC_FileName, parameter$
    End
    DoSAC parameter$
    System
End If

Print "Give me the name of your file to stuff =>";
Input SAC_FileName
Do
    Cls
    Print SAC_FileName
    Print
    Print "1) Initialize"
    Print "2) Gobble Something"
    Print "3) Puke"
    Print "4) Clean Up"
    Print "5) End"
    a$ = Input$(1)
    a = Val(a$)
    Select Case a
        Case 1: DoSAC "-INIT": Print "Initialized"
        Case 2:
            Print "Name of file to eat:";
            Input NAME$
            NAME$ = "-GOBBLE " + NAME$
            DoSAC NAME$
        Case 3: DoSAC "-BARF"
        Case 4: DoSAC "-CLEAN UP"
        Case 5: System
    End Select
    Sleep
Loop


Sub DoSAC (t$)
    Dim b As _Unsigned _Byte
    Dim text As String * 1
    Dim l(10) As _Unsigned _Integer64, l As _Unsigned _Integer64
    Dim SACfile As String * 255
    f = FreeFile
    Select Case UCase$(t$)
        Case "-SET THE TABLE", "-SET", "-INIT"
            'initialize
            Open SAC_FileName For Binary As #f
            Seek #f, LOF(f) + 1
            b = 0
            Put #f, , b
        Case "-BARF", "-PUKE"
            'puke it all up
            Open SAC_FileName For Binary As #f
            Seek #f, LOF(f)
            Get #f, , b
            If b < 1 Then Print "No files have been gorged on by this program.  FEED ME SOME!!": Beep: Beep: End
            Print b; "files to puke up!"
            CurrentPos = LOF(f) + 1
            AmountAte = b
            For i&& = 1 To AmountAte
                CurrentPos = CurrentPos - 256
                Get #f, CurrentPos, SACfile
                file$ = LTrim$(RTrim$(SACfile))
                Print file$; " barfed up!"
                CurrentPos = CurrentPos - 8
                Get #f, CurrentPos, l
                CurrentPos = CurrentPos - l
                g = FreeFile
                Seek #f, CurrentPos
                Open file$ For Binary As #g
                For j&& = 1 To l
                    Get #f, , b
                    Put #g, , b
                Next
                b = 0
                Put #g, , b
                Close #g
            Next
        Case "-CLEAN UP"
            'clean up the drive of all the puke
            Open SAC_FileName For Binary As #f
            Seek #f, LOF(f)
            Get #f, , b
            If b < 1 Then Print "No files have been gorged on by this program.  FEED ME SOME!!": Beep: Beep: End
            Print b; "puked up files to clean up!"
            CurrentPos = LOF(f) + 1
            AmountAte = b
            For i&& = 1 To AmountAte
                CurrentPos = CurrentPos - 256
                Get #f, CurrentPos, SACfile
                file$ = LTrim$(RTrim$(SACfile))
                Print file$; " cleaned up off the dinner table!"
                CurrentPos = CurrentPos - 8
                Get #f, CurrentPos, l
                CurrentPos = CurrentPos - l
                Kill file$
            Next
        Case Else
            If Left$(t$, 8) = "-GOBBLE " Then
                file$ = Right$(t$, Len(t$) - 8)
                If _FileExists(file$) Then
                    Print "Eatting "; file$
                    'eat stuff
                    Open SAC_FileName For Binary As #f
                    l(0) = LOF(f)
                    Seek #f, l(0)
                    Get #f, , b
                    AmountEat = b
                    g = FreeFile
                    Open file$ For Binary As #g
                    l(1) = LOF(g)
                    For i&& = 1 To l(1)
                        Get #g, , b
                        Put #f, , b
                    Next
                    Close #g
                    Put #f, , l(1)
                    SACfile = file$
                    Put #f, , SACfile
                    b = AmountEat + 1
                    Put #f, , b
                    Print file$, " was tasty!"
                Else
                    'Do nothing as the file doesn't exist.
                    Print "WARNING: "; file$; " does not exist!"
                    Beep: Beep
                End If
            End If
    End Select
    Close #f
End Sub


Steve's Anorexic Code is an utility which eats resource files, stuffs them onto your existing EXE, and then barfs them back up on call.  Want to pack a dozen files into one and ship them all together?  This can do that!  Compile your EXE, and then feed SAC that EXE and resource files, and get one nice and fat file all packaged up together.  When you need those resources, just -barf them back up on demand!  

What's not to love about it?  Just read the comments for ease of usage.  Big Grin

Print this item

  Changing Compile Options
Posted by: bplus - 01-07-2023, 04:09 PM - Forum: Repo Discussion - Replies (9)

When I changed compile options in QB64 pe 3.4.1 I lost all my recent files!

Was this fixed?

It looks like I have latest release according to this site bottom link for QB64pe

Print this item

  Keypad Entry
Posted by: eoredson - 01-07-2023, 05:33 AM - Forum: Help Me! - Replies (17)

I am working on a project that requires keypad entry.

The problem is that QB64 does not trap them!?

Here is my code:

Code: (Select All)
Rem Keypad-5 = 76
Rem Shift-Keypad-5 = 53
Rem Ctrl-Keypad-5 = 143
Do
  X$ = InKey$
  If Len(X$) Then
      If X$ = Chr$(27) Then End
      If Len(X$) = 2 Then
        X = Asc(Right$(X$, 1))
        Select Case X
            Case 76
              Print "keypad-5"
            Case 53
              Print "shift-keypad-5"
            Case 143
              Print "ctrl-keypad-5"
        End Select
      End If
  End If
Loop
End

Print this item

  better error trapping?
Posted by: madscijr - 01-06-2023, 06:57 PM - Forum: General Discussion - Replies (15)

With http/s capability coming, QB64PE is getting a major feature set. 
With that out of the way, I was thinking that another big feature for an upcoming release would be try/catch functionality. Even basic "on error resume next", like in classic VB/VBA, would be an improvement, or full try/catch like every other modern language. 
Thoughts?

Print this item

Question <solved> QB64 without its IDE GUI ?
Posted by: Fifi - 01-06-2023, 06:32 PM - Forum: General Discussion - Replies (28)

Hello all,

First of all receive my best wishes for this new year 2023.

Some time ago, I had seen somewhere (I think here) a topic with the title "QB64 without GUI" as project.

Can anyone direct me to this topic?

Moreover, is the QB64PE code sufficiently well documented to quickly and easily remove all the code necessary for the IDE, leaving only the translation in C++, the compilation part and the error messages (and maybe the line numbers concerned) as return in the event of a compilation error?

The goal of such an operation being to produce the smallest possible executable for an embedded system.

The first target would be on a framework of Linux system but I guess that could also be used on OS/X and maybe Windows on tiny computer such as the Pi platform.

Thanks in advance for any suggestions on this subject.

Happy new year 2023.

Print this item

Lightbulb People in SCREEN 0
Posted by: mnrvovrfc - 01-06-2023, 02:29 PM - Forum: Programs - No Replies

This is a silly program that could make a good screensaver LOL. I wrote something like this for one of my Tandy1000's many years back with QuickBASIC. Technology has gone such that it's amazing this program could run many times as fast on 64-bit, while being more bloated than a 16-bit program, and with single-core CPU barely capable of multimedia.

Code: (Select All)
''by mnrvovrfc 06-Jan-2023
OPTION _EXPLICIT
CONST NUMPEOPLE = 80
'fields:
'x, y = position of "person"
'xd, yd = direction is changed when the "person" reaches an edge of the screen
'c = color
'h = open or filled face
'k = count
'l = length of fixed path taken by the "person"
TYPE peoplette
    AS INTEGER x, y, xd, yd, c, k, l, h
END TYPE
DIM p(1 TO NUMPEOPLE) AS peoplette
DIM AS INTEGER i, j, k, kl, u, v, x, y, ox, oy, wd, ht, kc
DIM a$, found AS _BYTE

RANDOMIZE TIMER

'no two "persons" may have the same path but could look alike LOL
'kc = to repeat one direction a "person" takes up to four times
'kl = the number of times the "person" could change direction
DIM check$(1 TO NUMPEOPLE)
FOR i = 1 TO NUMPEOPLE
    kl = INT(RND * 10 + 5)
    kc = INT(RND * 4 + 1)
    k = kl
    a$ = ""
    DO WHILE k > 0
        DO
            x = INT(RND * 3) - 1
            y = INT(RND * 3) - 1
        LOOP WHILE x = 0 AND y = 0
        a$ = a$ + repeat$(STR$(x) + STR$(y), kc)
        k = k - 1
    LOOP
    IF i > 1 THEN
        found = 0
        FOR j = 1 TO i - 1
            IF a$ = check$(j) THEN found = 1: EXIT FOR
        NEXT
        IF found THEN _CONTINUE
    END IF
    check$(i) = a$
    p(i).l = kl
    p(i).k = 0
    p(i).c = INT(RND * 14 + 1)
    p(i).h = INT(RND * 2 + 1)
    p(i).xd = 1
    p(i).yd = 1
NEXT

'spread the people all over the screen
wd = _WIDTH
ht = _HEIGHT
u = wd * ht
u = u \ NUMPEOPLE
v = u \ 2
FOR i = 1 TO NUMPEOPLE
    p(i).x = (v MOD 80) + 1
    p(i).y = (v \ 80) + 1
    v = v + u
NEXT

'main loop
DO
    'change the following line to taste, to make it run faster
    _LIMIT 10
    FOR i = 1 TO NUMPEOPLE
        p(i).k = p(i).k + 1
        IF p(i).k > p(i).l THEN p(i).k = 1
        ox = p(i).x
        oy = p(i).y
        p(i).x = p(i).x + VAL(MID$(check$(i), p(i).k * 4 - 3, 2)) * p(i).xd
        p(i).y = p(i).y + VAL(MID$(check$(i), p(i).k * 4 - 1, 2)) * p(i).yd
        '"persons" aren't allowed to go off the screen nor run into each other
        IF p(i).x < 1 OR p(i).x > wd OR p(i).y < 1 OR p(i).y > ht THEN
            IF p(i).x < 1 OR p(i).x > wd THEN
                p(i).xd = p(i).xd * (-1)
            ELSE
                p(i).yd = p(i).yd * (-1)
            END IF
            p(i).x = ox: p(i).y = oy
        ELSEIF SCREEN(p(i).y, p(i).x) <> 32 THEN
            p(i).x = ox: p(i).y = oy
        END IF
    NEXT
    CLS
    FOR i = 1 TO NUMPEOPLE
        LOCATE p(i).y, p(i).x
        COLOR p(i).c
        PRINT CHR$(p(i).h);
    NEXT
    _DISPLAY
    'press [ESC] to leave program
LOOP UNTIL _KEYDOWN(27)
SYSTEM


FUNCTION repeat$ (astr AS STRING, numtimes AS INTEGER)
    DIM sret AS STRING, i AS INTEGER
    IF numtimes < 2 THEN repeat$ = astr: EXIT FUNCTION
    FOR i = 1 TO numtimes
        sret = sret + astr
    NEXT
    repeat$ = sret
END FUNCTION

Print this item

  The L-BASIC compiler
Posted by: luke - 01-06-2023, 01:16 PM - Forum: Works in Progress - Replies (20)

For some time now I have been working on a BASIC compiler which I've called L-BASIC. In many ways it's still rather primitive and in early stages, but it's reached the point where it can compile simple programs to executable format so I thought I'd make a thread for it.

Although all the source is available here on github and it's mostly written in QB64, it's rather complicated to build. If you'd like to try it, there's a prebuilt download-and-run version for 64 bit windows here: https://github.com/flukiluke/L-BASIC/rel...-x86_64.7z

You'll need to run it from a command prompt: "lbasic.exe test.bas" to compile test.bas, then run "test.exe" assuming you got no errors.

Some notes and warnings:
- Very poor support for most commands. All programs are console programs, you have a primitive PRINT but no input.
- DO, WHILE, IF, ELSE, FOR should work. ELSEIF, SELECT and EXIT don't.
- No GOTO or GOSUB, but SUB and FUNCTION can create subs/functions, and you can call them. Recursion works.
- Data types are INTEGER, LONG, INTEGER64 (no underscore), SINGLE, DOUBLE, QUAD, STRING. No _UNSIGNED. The usual suffixes %, & etc. are available.
- Basic string support: concatenation (a$ + b$), LEFT$, RIGHT$, MID$, CHR$
- All numeric operators are available and should work with proper precedence. This includes bitwise (AND, OR, XOR, NOT, IMP, EQV), relational (<, >, <=, >=, =, <>), arithmetic (+, -, *, /, \, MOD, ^).

Some programs that work:

Code: (Select All)
'Recursive factorial

'Functions can come before the main program
function fact(n)
  if n = 1 then fact = 1 else fact = n * fact(n-1)
end function

for i = 1 to 10 step 2
  print "fact("; i; ") = "; fact(i)
next i

Code: (Select All)
text$ = "hello" + " " + "world"
for i = 1 to len(text) 'Notice you can leave off the $ on text
  print left(text, i) 'And the $ is optional on left too
next i

Print this item

  BAM App Personalizer (a GUI to personalize BAM programs)
Posted by: CharlieJV - 01-06-2023, 03:48 AM - Forum: QBJS, BAM, and Other BASICs - No Replies

This first "personalizer" is for the Auto Biaxial Symmetry Graphing program I created recently.

It allows changing various settings and seeing the results on the fly.

If you find something you really like, you can export that personalized program (and the BASIC interpreter) to a small HTML file, which you can deploy/share as you like for running when you want.

Give it as spin:  https://basicanywheremachine.neocities.o...rsonalizer


I rather like this easy way to let a non-programmer (or a programmer who wants to quickly try different settings) adjust some things to their liking without needing to mess with code.



Attached Files Thumbnail(s)
   
Print this item

  Compare Images
Posted by: SMcNeill - 01-04-2023, 09:42 PM - Forum: SMcNeill - No Replies

Code: (Select All)
'int memcmp(const void *str1, const void *str2, size_t n)

Declare CustomType Library
    Function memcmp% (ByVal s1%&, Byval s2%&, Byval n As _Offset)
End Declare



Randomize Timer

Screen _NewImage(1280, 720, 32)

'let's make this an unique and pretty image!
For i = 1 To 100
    Line (Rnd * _Width, Rnd * _Height)-(Rnd * width, Rnd * _Height), &HFF000000 + Rnd * &HFFFFFF, BF
Next

image2 = _CopyImage(0) 'identical copies for testing
image3 = _CopyImage(0) 'identical copy...  BUT
_Dest image3
PSet (Rnd * _Width, Rnd * _Height), &HFF000000 + Rnd * &HFFFFFF 'We've just tweaked it so that there's no way in hell it's the same as the other two now!
_Dest 0 'image3 is EXACTLY one pixel different from the other two.  Can we detect that?
image4 = _CopyImage(0) 'an identical copy once again, because 0 will change once we print the resul


result1 = CompareImages(0, image2)
result2 = CompareImages(0, image3)
result3 = CompareImages(image2, image3)

Print "Current Screen and Image 1 Compare:  "; result1
Print "Current Screen and Image 2 Compare:  "; result2
Print "Image1 and Image 2 Compare        :  "; result3

Print
Print "Press <ANY KEY> for a speed test!"
Sleep

t# = Timer
Limit = 1000
For i = 1 To Limit
    result = CompareImages(image2, image3)
    result = CompareImages(image2, image4)
Next
Print
Print Using "####.####### seconds to do"; Timer - t#;
Print Limit * 2; "comparisons."


Function CompareImages (handle1 As Long, handle2 As Long)
    Static m(1) As _MEM
    m(0) = _MemImage(handle1): m(1) = _MemImage(handle2)
    If m(0).SIZE <> m(1).SIZE Then Exit Function 'not identical
    If m(0).ELEMENTSIZE <> m(1).ELEMENTSIZE Then Exit Function 'not identical
    If memcmp(m(0).OFFSET, m(1).OFFSET, m(0).SIZE) = 0 Then x = -1 Else x = 0
    CompareImages = x
End Function


Copied from deep inside another topic and shared here for ease of search and reference.  Smile

Print this item