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

Username/Email:
  

Password
  





Search Forums

(Advanced Search)

Forum Statistics
» Members: 326
» Latest member: hafsahomar
» Forum threads: 1,758
» Forum posts: 17,919

Full Statistics

Latest Threads
MBA Assignment Help in Du...
Forum: General Discussion
Last Post: hafsahomar
06-11-2025, 07:05 AM
» Replies: 0
» Views: 11
лучшие песни медляки слуш...
Forum: Petr
Last Post: WillieTop
06-08-2025, 02:21 AM
» Replies: 0
» Views: 25
пинк слушать онлайн беспл...
Forum: SMcNeill
Last Post: WillieTop
06-08-2025, 02:20 AM
» Replies: 0
» Views: 22
скачать музыку российскую...
Forum: madscijr
Last Post: WillieTop
06-08-2025, 02:18 AM
» Replies: 0
» Views: 23
нежная музыка mp3 скачать
Forum: Keybone
Last Post: WillieTop
06-08-2025, 02:17 AM
» Replies: 0
» Views: 21
лучшая песня слушать онла...
Forum: bplus
Last Post: WillieTop
06-08-2025, 02:16 AM
» Replies: 0
» Views: 25
пикник слушать онлайн луч...
Forum: Spriggsy
Last Post: WillieTop
06-08-2025, 02:15 AM
» Replies: 0
» Views: 22
какая сейчас популярная м...
Forum: RhoSigma
Last Post: WillieTop
06-08-2025, 02:14 AM
» Replies: 0
» Views: 18
хит лета 2019 музыка на т...
Forum: Christmas Code
Last Post: WillieTop
06-08-2025, 02:12 AM
» Replies: 0
» Views: 26
бесплатная музыка mp3 рег...
Forum: Works in Progress
Last Post: WillieTop
06-08-2025, 02:11 AM
» Replies: 0
» Views: 17

 
  suggestion: change to _MEMFREE
Posted by: OldMoses - 12-11-2022, 12:43 PM - Forum: General Discussion - Replies (5)

While working with _MEM blocks and freeing them, it occurred to me that perhaps it would be a useful alteration to have _MEMFREE work similar to the new DIM syntax, where one can:

DIM AS INTEGER a, b, c, etc.

Where instead of the required syntax following:

_MEMFREE m
_MEMFREE m2
_MEMFREE m3

One could do:

_MEMFREE m, m2, m3

Would there be any interest in such a change, or would that be too difficult of an implementation?

Print this item

  Chat with Me -- HOST
Posted by: SMcNeill - 12-11-2022, 12:30 PM - Forum: General Discussion - Replies (61)

Now, as I mentioned in the topic Come chat with me! (qb64phoenix.com), I told you guys I was going to share the HOST part of the program which we were all using to play around and chat with yesterday -- and try to highlight the steps necessary to get it to run properly for everyone.

First, let's start with the code.  We'll begin with the HOST version of my Mini Messenger (qb64phoenix.com):

Code: (Select All)
DIM SHARED Users(1 TO 1000) ' array to hold other client info
DIM SHARED NumClients
DIM SHARED out$


PRINT "[Steve's Mini Messenger]"
host = _OPENHOST("TCP/IP:7319") ' no host found, so begin new host
IF host THEN
    PRINT "[Beginning new host chat session!]"
    NumClients = 0
    client = _OPENCLIENT("TCP/IP:7319:localhost")
    IF client = 0 THEN PRINT "ERROR: could not attach host's personal client to host!"
    INPUT "Enter your name:", myname$
    'PRINT #client, myname$ + " connected!"
    PRINT "[Chat session active!]"
ELSE
    PRINT "ERROR: Could not begin new host!"
END IF ' host


DO ' host main loop
    newclient = _OPENCONNECTION(host) ' receive any new connection
    IF newclient THEN
        NumClients = NumClients + 1
        Users(NumClients) = newclient
        PRINT "Welcome to Steve's Mini Messenger!"
    END IF
    FOR i = 1 TO NumClients
        GetMessage Users(i) 'check all clients for a message
        IF out$ <> "" THEN
            l = LEN(out$)
            FOR j = 1 TO NumClients ' distribute incoming messages to all clients
                PUT #Users(j), , l
                PUT #Users(j), , out$
            NEXT
        END IF
    NEXT i

    SendMessage myname$, mymessage$, client
    _LIMIT 30
LOOP


SUB GetMessage (client) ' get & display any new message
    GET #client, , l
    IF l > 0 THEN
        out$ = SPACE$(l)
        GET #client, , out$
        VIEW PRINT 1 TO 20
        LOCATE 20, 1
        PRINT out$
        VIEW PRINT 1 TO 24
    ELSE
        out$ = ""
    END IF
END SUB

SUB SendMessage (myname$, mymessage$, client) ' simple input handler
    k$ = INKEY$
    IF LEN(k$) THEN
        IF k$ = CHR$(8) AND LEN(mymessage$) <> 0 THEN
            mymessage$ = LEFT$(mymessage$, LEN(mymessage$) - 1)
        ELSE
            IF LEN(k$) = 1 AND ASC(k$) >= 32 THEN mymessage$ = mymessage$ + k$
        END IF
    END IF
    VIEW PRINT 1 TO 24
    LOCATE 22, 1: PRINT SPACE$(80); ' erase previous message displayed
    LOCATE 22, 1: PRINT myname$ + ": "; mymessage$;
    IF k$ = CHR$(13) THEN ' [Enter] sends the message
        IF mymessage$ = "" THEN SYSTEM ' [Enter] with no message ends program
        mymessage$ = myname$ + ":" + mymessage$
        l = LEN(mymessage$)
        PUT #client, , l
        PUT #client, , mymessage$
        mymessage$ = ""
    END IF
    IF k$ = CHR$(27) THEN SYSTEM ' [Esc] key ends program
END SUB[color=#cccccc][font=Monaco, Consolas, Courier, monospace][/font][/color]

Now, I tried to keep this as simple as I possibly could -- without any bells or whistles to complicate the viewing and understanding of the basic process we're using here -- so don't think this is anything fancy at all.  All this basically does is show how to set up a host connection, accept users trying to connect to that connection, and then transfer information back and forth between the two.

It's a demo to showcase the very bare bones of the TCP/IP stuff, and nothing more, so keep that in mind as we go along and talk about things.  Wink

First change needed to swap this over from LOCALHOST to world wide web hosting involves...   dum dum de dum....   Opening a  browser tab and going to What Is My IP? Shows Your Public IP Address - IPv4 - IPv6.  If you're using a VPN or such to protect your IP, you may be able to get by with using it, or you may not.   That all depends on your VPN's safety protocols.  If it just forwards anything that comes its way back your way, you're fine.  If it wants you to open ports and such as that and only forward certain things, then you're screwed unless you jump through their hoops and allow the transfer.  

My advice here:  Use your actual web address.  172.83.131.239 happens to be my permanent little home on the web.  From time to time, I tend to host my own website, and I need a static IP so I can always connect to it when it's up and going.  Most folks have a dynamic IP, which is assigned to them randomly every time they connect to the internet (it costs extra $$ each month for a static IP), so you'll need to update your chat program with the current IP with each reboot of your computer.

Once you've gotten your IP address, you can now go into the code above and make the drastic change from local to www connections:

Code: (Select All)
    client = _OpenClient("TCP/IP:7319:localhost")

Change the line above to where it now has your IP address, rather than "localhost".

Code: (Select All)
    client = _OpenClient("TCP/IP:7319:172.83.131.239")

^That's what it'll look like for me.  For you, the same, except with a different IP address in there.  Wink

And that's basically the ONLY TCP/IP requirement that QB64-PE makes you have to change to make it work and communicate across the net!



And chances are, if some of you try to make that work, it's not going to work for you.  In fact, I'd bet against it.  Sad

WHY??

First is the TCP/IP:7319...   What the heck is that 7319, and why is it in there?  

It's one of the multitude of ports which our modern PCs have available for us to use to communicate with things.  How was 7319 chosen?  That was all just Steve, picking an unused port on my PC, and deciding, "I'm ah gonna use dis one!"  Most of the time, our modern routers tend to lock down port access for most people and things.  You have one or two ports open for common stuff (like http and https transfers), but the rest of those ports are locked for security purposes.  

Since there's a zillion different routers, and a zillion different ways they're configured, with a zillion different sets of software to interact with them, *I CAN'T HELP YOU WITH YOUR ROUTER SETTINGS.*  You'll have to Google, dig out the manual that came packaged when you bought the router, or call your ISP and ask them to help.  At the end of the day though, you're NOT going to be able to share communications unless you're sharing on a port that's opened and allows it.  <--This part, unfortunately, you're on your own to puzzle out.  All I can say is "Open your router settings, choose a port you like that's not currently in use, and open it -- however you do that on your router."

Once you've got an open port, and if it's not 7319 like I chose for it to be, then you'd need to change your program to work on the port you've chosen.

Code: (Select All)
    client = _OpenClient("TCP/IP:####:172.83.131.239")

Try that, and it MAY work for you.  Once again, however, I'd be willing to bet against it.  Sad

Once more, go into your router settings, and this time look for PORT FORWARDING.  Most of us have multiple devices set up for the internet.  Our phones are connected, as is our pc, our ipad, our tv, all our damn smart lightbulbs...  You probably need to do a little more specific directing with port forwarding to tell your router where you want to send that open port information to.

Once again, I'm sorry, but I can't really help much with this step as every router has it's own software and way of interacting with you.


[Image: image.png]

Click on the image above, if you want, and it'll show my router's port forwarding setup.  The first three and where I host my own private server from time to time (ports 80 and 443 and http and https traffic, while 3306 is where my SQL Database likes to communicate back and forth when it's up and running).  The last entry in that list, however, is the one of interest for you guys -- Laptop Forwarding on port 7319, and which is going to 10.243.1.77...

That 10.242.1.77 is my laptop's local address on my network.  By setting up port forwarding like this, communications on port 7319 are now routed directly to it, allowing it to communicate with the rest of the world.

Once you've set up the open port, and forwarded it to your machine which is going to run the compiled EXE, chances are you're good to go!!  Your firewall might pop up a question "Do you really want to allow this", but you can feel free to tell it to pisser off.  You've got to let the information travel back and forth to your PC, or else you'll never be able to communicate on an open port like this with the outside world.  




So you run it...  And it works!!  YAAAAAAYYYY!!!

You go to bed, get up the next morning, notice that Windows did an update on you, and it now no longer works.   WTF?!!  (I can just hear some of you cussing already!  No worries -- no judgement.  I've been there as well!!)

Two important things to keep in mind:

1) If you don't have a permanent STATIC IP address (you'll know if you do because you asked for it specifically from your ISP and are paying extra each month for it), then your IP address is dynamically allocated for you.  You'll need to get the new address, swap it into your program, and try it again.

2) And if number one doesn't fix the issue, problem number two is... dum dum de dum... once again dynamic addresses.  That last step that we did, with the port forwarding...  Remember it?  You forwarded your data to a specific local IP address...   If you don't have that configured as a static address (set up manually instead of automatic), then it may not be the same as it was before either.  You may have to go back and change your port forwarding address once again so it works as you'd expect.

Print this item

  Playing with the mouse
Posted by: NasaCow - 12-11-2022, 07:59 AM - Forum: Help Me! - Replies (13)

I am running this program to play with the mouse, just playing with things to understand it before trying to imbed it into something else.


Code: (Select All)
$NOPREFIX

CONST FALSE = 0, TRUE = NOT FALSE

TYPE MouseType
    EndX AS INTEGER
    EndY AS INTEGER
    StartX AS INTEGER
    StartY AS INTEGER
    LButDown AS INTEGER
    RButDown AS INTEGER
    OldLBut AS INTEGER
    OldRBut AS INTEGER
END TYPE

SCREEN NEWIMAGE(1280, 720, 32)

DIM AS MouseType Mouse
DIM AS INTEGER highlight(500000)
DIM AS BIT Active

Mouse.OldLBut = --1
Active = FALSE

LINE (500, 200)-(600, 300), RGB(0, 0, 255), BF
DO
    'LIMIT 120
    DO WHILE MOUSEINPUT
    LOOP

    Mouse.StartX = MOUSEX
    Mouse.StartY = MOUSEY
    Mouse.LButDown = MOUSEBUTTON(1)

    IF Mouse.StartX >= 500 AND Mouse.StartX <= 600 AND Mouse.StartY >= 200 AND Mouse.StartY <= 300 AND NOT Active THEN
        GET (500, 200)-(600, 300), highlight()
        PUT (500, 200), highlight(), PRESET
        Active = TRUE
    ELSEIF Active EQV Mouse.StartX < 500 OR Mouse.StartX > 600 OR Mouse.StartY < 200 OR Mouse.StartY > 300 THEN
        GET (500, 200)-(600, 300), highlight()
        PUT (500, 200), highlight(), PRESET
        Active = FALSE
    END IF

    IF Mouse.LButDown AND NOT Mouse.OldLBut THEN
        LOCATE 1, 1
        PRINT Mouse.StartX, Mouse.StartY, Mouse.LButDown
    END IF

    Mouse.OldLBut = Mouse.LButDown

LOOP UNTIL INKEY$ = CHR$(27)



and it is working as expected with a box highlighting and not but I don't understand why this if statement needs EQV:

Code: (Select All)
    ELSEIF Active EQV Mouse.StartX < 500 OR Mouse.StartX > 600 OR Mouse.StartY < 200 OR Mouse.StartY > 300 THEN
        GET (500, 200)-(600, 300), highlight()
        PUT (500, 200), highlight(), PRESET
        Active = FALSE
    END IF
 
than the one I was trying to work with at first:


Code: (Select All)
    ELSEIF Active AND Mouse.StartX < 500 OR Mouse.StartX > 600 OR Mouse.StartY < 200 OR Mouse.StartY > 300 THEN
        GET (500, 200)-(600, 300), highlight()
        PUT (500, 200), highlight(), PRESET
        Active = FALSE
    END IF

My belief that If (false and True or True or True or True) should return a false with false and true.... condition. 


Never used EQV before but the table on the wiki implies both should return false. Maybe someone can educate me where my logic has gone wrong? Many thanks  Shy

Print this item

  DAY 030: _CONTROLCHR
Posted by: Pete - 12-11-2022, 02:13 AM - Forum: Keyword of the Day! - Replies (5)

Ever want to be able to see the ASCII characters that do things like eject the printer paper, CHR$(12)? Well with the keyword _CONTROLCHR OFF, you can! And if you act now, because we can't do this all day, we'll throw in _CONTROLCHR$ ON at no extra charge. Just pay separate shipping and handling.

SYNTAX _CONTROLCHR {OFF|ON}

Code: (Select All)
WIDTH 127, 20
_FONT 16
_KEYCLEAR
msg$ = "ASCII CHaracter Chart"
LOCATE 1, _WIDTH \ 2 - LEN(msg$) \ 2
PRINT msg$;
c = 1
_CONTROLCHR OFF
FOR i = 0 TO 255 ' There are 256 ASCII characters.
    i$ = LTRIM$(STR$(i))
    FOR j = 1 TO 2
        IF LEN(i$) < 3 THEN i$ = "0" + i$
    NEXT
    IF i AND i MOD (_HEIGHT - 4) = 0 THEN c = c + 8: LOCATE 3, c
    LOCATE i MOD (_HEIGHT - 4) + 3, c + 1: PRINT i$; " "; CHR$(i);
NEXT
SLEEP

_CONTROLCHR ON
_DELAY .5
FOR i = 1 TO _HEIGHT
    PRINT CHR$(13);
    _DELAY .2
NEXT

So now we have some nice symbols we can print to the screen for our text programs, which without this KEYWORD, would be used for the following...

Code: (Select All)
CTRL + A = CHR$(1)   ?  StartHeader (SOH)    CTRL + B = CHR$(2)   ?  StartText         (STX)
CTRL + C = CHR$(3)   ?  EndText     (ETX)    CTRL + D = CHR$(4)   ?  EndOfTransmit     (EOT)
CTRL + E = CHR$(5)   ?  Enquiry     (ENQ)    CTRL + F = CHR$(6)   ?  Acknowledge       (ACK)
CTRL + G = CHR$(7)   •  Bell        (BEL)    CTRL + H = CHR$(8)   ?  [Backspace]       (BSP)
CTRL + I = CHR$(9)   ?  Horiz.Tab   [Tab]    CTRL + J = CHR$(10)  ?  LineFeed(printer) (LF)
CTRL + K = CHR$(11)  ?  Vert. Tab   (VT)     CTRL + L = CHR$(12)  ?  FormFeed(printer) (FF)
CTRL + M = CHR$(13)  ?  [Enter]     (CR)     CTRL + N = CHR$(14)  ?  ShiftOut          (SO)
CTRL + O = CHR$(15)  ¤  ShiftIn     (SI)     CTRL + P = CHR$(16)  ?  DataLinkEscape    (DLE)
CTRL + Q = CHR$(17)  ?  DevControl1 (DC1)    CTRL + R = CHR$(18)  ?  DeviceControl2    (DC2)
CTRL + S = CHR$(19)  ?  DevControl3 (DC3)    CTRL + T = CHR$(20)  ¶  DeviceControl4    (DC4)
CTRL + U = CHR$(21)  §  NegativeACK (NAK)    CTRL + V = CHR$(22)  ?  Synchronous Idle  (SYN)
CTRL + W = CHR$(23)  ?  EndTXBlock  (ETB)    CTRL + X = CHR$(24)  ?  Cancel            (CAN)
CTRL + Y = CHR$(25)  ?  EndMedium   (EM)     CTRL + Z = CHR$(26)  ?  End Of File(SUB)  (EOF)

Note that PRINT CHR$(7) used t sound a BEEP in QuickBasic and older QB64 versions, but not any longer. I wonder who the dev was who decided to get the BEEP out of QB64?

Pete

Print this item

  A little DIR test
Posted by: BDS107 - 12-10-2022, 05:52 PM - Forum: Help Me! - Replies (4)

I would like to perform a test.
I would like to know if the output of the directory is the same for every language? Also what happens with date/time? And is the distance to the file name the same per language? I use Windows 10 (BE-NL) system. And what about Linux and iOS?

Code: (Select All)
dir *.* /A-D-H-S-L-R /n /ON /4 /l


What is your result? I have the following (excerpt):


Code: (Select All)
26/11/2022  21:10            2.433 filename1.ext
28/11/2022  11:50            3.467 filename2.ext
28/11/2022  16:09            3.522 filename3.ext

So 10 characters for the date
2 spaces in between
5 characters for the date (maybe there will be more due to AM/PM)?
Then the size of the file.
From position 37 the file name.
In other words, can we use fixed values for MID$ ???
Maybe you van upload an excerpt to this post?

Print this item

  Come chat with me!
Posted by: SMcNeill - 12-10-2022, 12:06 PM - Forum: General Discussion - Replies (6)

Code: (Select All)
Dim Shared out$


Print "[Steve's Mini Messenger]"
client = _OpenClient("TCP/IP:7319:172.83.131.239") ' Attempt to connect to local host as a client
Print "[connected to " + _ConnectionAddress(client) + "]"

Input "Enter your name: ", myname$
out$ = myname$ + " connected!"
l = Len(out$)
Put #client, , l
Put #client, , out$
Do
    GetMessage client
    SendMessage myname$, mymessage$, client ' display current input on screen
    _Limit 30
Loop

'.................... END OF MAIN PROGRAM ................


Sub GetMessage (client) ' get & display any new message
    Get #client, , l
    If l > 0 Then
        _Delay .25
        out$ = Space$(l)
        Get #client, , out$
        View Print 1 To 20
        Locate 20, 1
        Print out$
        View Print 1 To 24
    Else
        out$ = ""
    End If
End Sub

Sub SendMessage (myname$, mymessage$, client) ' simple input handler
    k$ = InKey$
    If Len(k$) Then
        If k$ = Chr$(8) And Len(mymessage$) <> 0 Then
            mymessage$ = Left$(mymessage$, Len(mymessage$) - 1)
        Else
            If Len(k$) = 1 And Asc(k$) >= 32 Then mymessage$ = mymessage$ + k$
        End If
    End If
    View Print 1 To 24
    Locate 22, 1: Print Space$(80); ' erase previous message displayed
    Locate 22, 1: Print myname$ + ": "; mymessage$;
    If k$ = Chr$(13) Then ' [Enter] sends the message
        If mymessage$ = "" Then System ' [Enter] with no message ends program
        mymessage$ = myname$ + ":" + mymessage$
        l = Len(mymessage$)
        Put #client, , l
        Put #client, , mymessage$
        _Delay .25
        mymessage$ = ""
    End If
    If k$ = Chr$(27) Then System ' [Esc] key ends program
End Sub


There's been several folks who have been chatting and asking about TCP/IP communications between computers here lately, so I thought I'd showcase how it's done once again.

Above is a very simple client, which remotes out from your PC (you may have to open your firewall for it, or disable a few "protect yourself from yourself" settings, depending on your system), and which then connects to my laptop by which we can then chat happily with each other.

Feel free to hang around in the little chat all day with us, if you're able.  I'm going to keep the host up and going until after midnight EST for everyone, but that certainly doesn't mean I'm going to sit and hover over my laptop that whole time to always be available to instantly say, "HEY!  I SEE YOU!  CAN YOU HEAR ME NOW??"

The more folks who pop in and hang around, the more folks who can chatter with each other and welcome someone new into the channel, so they can be certain that the program is working and communicating in both directions for them.  

If all this works, without folks having too hard an issue running with it, I'll post the host and client both sometime tomorrow and then try and walk everyone through all the steps I went through to get it to play nicely with my router, firewall, and all.  Wink

Print this item

  DAY 029: _EXIT
Posted by: Pete - 12-10-2022, 05:41 AM - Forum: Keyword of the Day! - Replies (8)

Not to be confused with _BREXIT, which was a useful keyword to get the hell out of the E.U., _EXIT is a useful keyword to get you out of trouble if you mistakenly click the "X" symbol before parts of your app have completed, like writing to a very large file.

SYNTAX:  var% = _EXIT

Values are as follows...

Code: (Select All)
' "x"......... 1
' Alt + F4.....1
' Ctrl + Break 2
DO
    a% = _EXIT
    PRINT a%
    _LIMIT 1
    IF INKEY$ = CHR$(27) THEN END
LOOP

_EXIT covers all exit routines, which is why I put that INKEY Esc to end line in the code; otherwise, you'd have to shut it down with Task manager.

So, what's it good for? Well, let's say your cat walks into the room, jumps on your mouse and sits its kitty-butt down on the left mouse button. Well wouldn't you know it, the mouse pointer is positioned on the "x" and the program is running a pi algorithm that has been going on for days! Well, before you think about getting rid of your cat, and getting a life, try _EXIT in your program instead; here's how...

Code: (Select All)
DO
    FOR i = 1 TO 10
        ON _EXIT GOSUB pete ' Pauses this count routine when the "x" is clicked.
        PRINT i
        _DELAY .5
    NEXT
LOOP UNTIL LEN(INKEY$) ' If you press a key, it will end after it prints "10".
END

pete:
LINE INPUT "Are you sure you want to quit? Y/N: "; ans$
IF LCASE$(ans$) = "y" THEN SYSTEM
RETURN


So you might ask, hey Pete, why'd you put the _EXIT command in the FOR LOOP, instead of the DO LOOP? And I'd reply, so the user doesn't think the "x" close program function is broken.

Now let's try it in the DO LOOP, and see what happens...

Code: (Select All)
DO
    ON _EXIT GOSUB pete ' Pauses this count routine after count "10".
    FOR i = 1 TO 10
          PRINT i
        _DELAY .5
    NEXT
LOOP UNTIL LEN(INKEY$) ' If you press a key, it will end after it prints "10".
END

pete:
LINE INPUT "Are you sure you want to quit? Y/N: "; ans$
IF LCASE$(ans$) = "y" THEN SYSTEM
RETURN

So we click "x" after it prints 2 or 3, whatever... and it keeps counting. Go ahead, click the hell out of "x", it won't matter. It isn't going to move to the sub-routine until it finishes the FOR LOOP.

Now you could do worse, and put it outside the DO LOOP. This disables the "x" quit function, but keeps the click in memory. That's a problem as our program is supposed to "END" with the screen still up and a, "Press any key to continue." message at the bottom. Oops, that click in memory kills the window!

So knowing what effect you want and where to place the _EXIT command is important. For instance, let's say it was imperative we get that FOR LOOP to complete before we quit. I'd say code a warning message something like this...

Code: (Select All)
DO
    stopexit = -1
    FOR i = 1 TO 10
        ON _EXIT GOSUB pete
        PRINT i
        _DELAY .5
    NEXT
    IF stopexit = 0 THEN END
    PRINT "You have 10 seconds to exit before the next loop begins..."
    stopexit = 0
    z1 = TIMER
    DO: ON _EXIT GOSUB pete: LOOP UNTIL ABS(TIMER - z1) >= 10
LOOP UNTIL LEN(INKEY$) ' If you press a key, it will end after it prints "10".
END

pete:
SELECT CASE stopexit
    CASE -1
        PRINT: PRINT "Okay, the program will end after it prints to 10.": PRINT: _DELAY 3
        stopexit = 0
    CASE 0
        SYSTEM ' But Yogi, won't exiting before returning cause a stack space leak? I don't give a **** Booboo.
END SELECT
RETURN

So in review, _EXIT returns 1 for "x" in the window or in the task bar projection, 1 for Alt + F4, and 2 for Ctrl + Break. Where you place it determines the behavior, either immediate or delayed action, and be sure to use a key routine or sub-routine to bail yourself out so you don't have to resort to Task manager to suspend the program window.

<--- Pete _EXIT stage left...

Print this item

  Simple Drive Display
Posted by: eoredson - 12-10-2022, 04:43 AM - Forum: Utilities - Replies (27)

Hi,

I wrote this simple drive display function which is not that large.

It works in QB64 and uses library function GetDrivetype.

My question was:

  Id there a equivalent QB45/71 function to return drive type
  such as [cdrom] or [removable]??

Thanks, Erik.



Attached Files
.zip   DRIVEX.ZIP (Size: 151.81 KB / Downloads: 43)
.zip   DRIVEX2.ZIP (Size: 195.62 KB / Downloads: 31)
Print this item

  picture to Mosaic pictures
Posted by: MasterGy - 12-09-2022, 08:27 PM - Forum: MasterGy - Replies (3)

You must have seen a picture that is made up of many small pictures.
The program is simple. Just give him a single image at the beginning of the source code! (boss_pic$)
To create such a picture, you need a lot of pictures so that you can work with as many different shades as possible.
Specify where the program should search for images. A drive or folder.

The program will scan your computer and look for image files. Unfortunately, I think this will only work under Windows, because a 'CMD' command generates a list of found images.
After that, the program examines the color shades of all found images and stores them. Peace of mind! The program does not make any changes to any files! You don't put any garbage anywhere!

It took 5,000 pictures in 2 minutes, but I mostly have small pictures on my computer.

After the examination, he creates the mosaic image.
You only check the images once! You don't have to wait every time you start the program. It performs a new test if we change the search location for the images (file_search$) or change the aspect ratio of the mosaic images (ratio_y_start).

The higher the quality of the finished image, the more images the program can work with.

after running the program, the image is automatically saved as "saved.bmp".

during the examination, you select images that are close in shade to another existing image. This prevents the repetition of images.

use the available images proportionately during the work. that's why it randomly creates the mosaics so that there are no more identical images next to each other




Code: (Select All)
'mosaic-picture (MasterGy2022)

'----------------------------------- S E T T I N G S

boss_pic$ = "image1.jpg" 'big picture ! this image will appear large

ratio_resx = 25 'output pictures width number of mosaic
ratio_y_start = 1 / 4 * 3 'mosaic aspect ratio width = 1 ,Height = 1*this
file_search$ = "d:" 'where can I find image files?  exapmle:    a drive "d:"  or directory "d:\pictures"

work_sx = 1200 'output picture width size
cheat_alpha = 100 'color foil alpha value to 1 mosaic
cheat_original = 30 'adding an original image transparent film to the finished work   alpha


'--------------------------------------------------------------------------------------------------------------------------------------------------------------------



If _FileExists(boss_pic$) = 0 Then Print "boss-picture not found !": End
file_ready$ = "pics_ready.dat"

monx = 800
mony = 600

mon = _NewImage(monx, mony, 32)
Screen mon
_Dest mon

If _FileExists(file_ready$) = 0 Then GoSub files_exam



boss_pic = _LoadImage(boss_pic$, 32)


work_sy = Int(work_sx / _Width(boss_pic) * _Height(boss_pic))



mosx = Int(work_sx / ratio_resx)

Open file_ready$ For Input As 1: Line Input #1, temp$: Input #1, ratio_y: If ratio_y <> ratio_y_start Or temp$ <> file_search$ Then Close 1: Kill file_ready$: Run



Close 1

ratio_resy = Int(work_sy / (mosx * ratio_y))
mosy = Int(work_sy / ratio_resy)



read_pic = _NewImage(work_sx, work_sy, 32): _Dest read_pic: _Source boss_pic: _PutImage
work_pic = _NewImage(work_sx, work_sy, 32)
_FullScreen _SquarePixels: Screen work_pic: _Dest work_pic



'database load

Open file_ready$ For Input As 1
Line Input #1, temp$
Input #1, ratio_y
Input #1, pic_c
us = Int((ratio_resx * ratio_resy) / pic_c) + 1
Dim pics$(pic_c - 1), pic_dat(pic_c - 1, 5)
For t = 0 To pic_c - 1
    Line Input #1, pics$(t)
    Input #1, pic_dat(t, 0), pic_dat(t, 1), pic_dat(t, 2)
    pic_dat(t, 3) = us
Next t





'fill mosaic
Dim rmap(ratio_resx - 1, ratio_resy - 1)

sum_mosaic = ratio_resx * ratio_resy
_Source read_pic
_Dest work_pic 'mon
_PutImage

temp = _NewImage(1, 1, 32): _Dest temp: Cls , _RGB32(0, 0, 0, 200)
_Source temp
_Dest work_pic
_PutImage
_FreeImage temp

Do: sum = sum + 1
    Do
        mx = Int(ratio_resx * Rnd)
        my = Int(ratio_resy * Rnd)
    Loop While rmap(mx, my)
    rmap(mx, my) = 1
    x1 = mx * mosx: x2 = x1 + mosx
    y1 = my * mosy: y2 = y1 + mosy

    'paste picture

    _Source read_pic

    ReDim c(3)
    For tx = x1 To x2
        For ty = y1 To y2
            c&& = Point(tx, ty)
            c(0) = _Red32(c&&) + c(0)
            c(1) = _Green32(c&&) + c(1)
            c(2) = _Blue32(c&&) + c(2)
            c(3) = c(3) + 1
    Next ty, tx

    For t = 0 To 2: c(t) = c(t) / c(3): Next t

    min = 9999999999999
    For t = 0 To pic_c - 1: If pic_dat(t, 3) <= 0 Then _Continue
        dis = (pic_dat(t, 0) - c(0)) ^ 2 + (pic_dat(t, 1) - c(1)) ^ 2 + (pic_dat(t, 2) - c(2)) ^ 2
        If dis < min Then min = dis: ok = t
    Next t

    temp = _LoadImage(pics$(ok), 32)
    'Print #5, pics$(ok), ok
    _Source temp
    _Dest work_pic
    area ax1, ay1, ax2, ay2, temp, ratio_y
    _PutImage (x1, y1)-(x2, y2), , , (ax1, ay1)-(ax2, ay2)
    _FreeImage temp

    'shadow
    temp = _NewImage(1, 1, 32): _Dest temp: Cls , _RGB32(c(0), c(1), c(2), cheat_alpha)
    _Source temp
    _Dest work_pic
    _PutImage (x1, y1)-(x2, y2)
    _Source work_pic
    _FreeImage temp


    pic_dat(ok, 3) = pic_dat(ok, 3) - 1

Loop Until sum_mosaic = sum




'add original picture shadow
_Dest read_pic
_SetAlpha cheat_original
_Dest work_pic
_Source read_pic
_PutImage

'saving
SaveImage work_pic, "saved.bmp"


End














End
'files exam ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
files_exam:
ratio_y = ratio_y_start
Locate 1, 1: Print "Waiting ! I will search for the image files in the specified locations ...few minutes"
Shell _Hide "dir /b /s /a:-s " + file_search$ + "\*.bmp " + file_search$ + "\*.jpg " + file_search$ + "\*.jpeg" + " >file_stat.dat"



Open "file_stat.dat" For Input As 1: Do: Line Input #1, s$: pic_c = pic_c + 1: Loop Until EOF(1): Close 1
Locate 3, 1: Print pic_c; " can be used pictures find"



Open "file_stat.dat" For Input As 1
Open "temp.dat" For Output As 2

ex_pic_size = 200
ex_pic = _NewImage(ex_pic_size, ex_pic_size * ratio_y, 32)

For t = 0 To pic_c - 1
    _Dest mon
    Locate 5, 1: Print "Examine the color depth of the image files ..."; Int(1000 / (pic_c - 1) * t) / 10; "% ready   ("; pic_c; "/"; (t + 1); ")"
    Line Input #1, s$

    Locate 6, 1: Print s$ + Space$(40)
    '    End

    If _FileExists(s$) And Mid$(s$, Len(file_search$) + 2, 1) <> "$" Then

        x = _LoadImage(s$, 32)

        If x Then
            hiba = 0
            On Error GoTo error1
            _Source x
            On Error GoTo 0
            If hiba = 0 Then

                _Dest ex_pic
                area ax1, ay1, ax2, ay2, x, ratio_y

                _PutImage , , , (ax1, ay1)-(ax2, ay2)
                _Dest mon
                psize = monx / 3
                _Source ex_pic
                _PutImage (0, Int(mony / 2))-(psize, Int(mony / 2 + psize * ratio_y))


                '                Screen ex_pic
                ReDim c(3)
                For tx = 0 To ex_pic_size - 1
                    For ty = 0 To ex_pic_size - 1
                        c&& = Point(tx, ty)
                        c(0) = _Red32(c&&) + c(0)
                        c(1) = _Green32(c&&) + c(1)
                        c(2) = _Blue32(c&&) + c(2)
                        c(3) = c(3) + 1
                Next ty, tx

                Print #2, s$
                Print #2, Int(c(0) / c(3)), Int(c(1) / c(3)), Int(c(2) / c(3)): cnt = cnt + 1
                _FreeImage x
            End If
        End If
    End If

Next t
Close 1, 2


Open "temp.dat" For Input As 1

ReDim pics$(cnt - 1), pic_dat(cnt - 1, 5)
For t = 0 To cnt - 1
    Line Input #1, pics$(t)
    Input #1, pic_dat(t, 0), pic_dat(t, 1), pic_dat(t, 2)
Next t
Close 1



For t = 0 To cnt - 2: Locate 8, 1: Print "subtraction of identical shades :"; Int(1000 / (pic_c - 1) * t) / 10; "%"
    For t2 = t + 1 To cnt - 1
        pic_dat(t2, 4) = (pic_dat(t, 0) = pic_dat(t2, 0) And pic_dat(t, 1) = pic_dat(t2, 1) And pic_dat(t, 2) = pic_dat(t2, 2)) Or pic_dat(t2, 4)
    Next t2
Next t


For t = 0 To cnt - 1: present = present + Abs(pic_dat(t, 4) = 0): Next t
Locate 9, 1: Print "substractions :"; cnt - present; " pictures"

Open file_ready$ For Output As 1
Print #1, file_search$
Print #1, ratio_y
Print #1, present
For t = 0 To cnt - 1: If pic_dat(t, 4) Then _Continue
    Print #1, pics$(t)
    Print #1, pic_dat(t, 0), pic_dat(t, 1), pic_dat(t, 2)
Next t
Close 1






_FreeImage ex_pic
On Error GoTo 0
Kill "file_stat.dat"
Kill "temp.dat"
Sleep 2
Run





error1: hiba = 1: Resume Next

Sub SaveImage (image As Long, filename As String)
    bytesperpixel& = _PixelSize(image&)
    If bytesperpixel& = 0 Then Print "Text modes unsupported!": End
    If bytesperpixel& = 1 Then bpp& = 8 Else bpp& = 24
    x& = _Width(image&)
    y& = _Height(image&)
    b$ = "BM????QB64????" + MKL$(40) + MKL$(x&) + MKL$(y&) + MKI$(1) + MKI$(bpp&) + MKL$(0) + "????" + String$(16, 0) 'partial BMP header info(???? to be filled later)
    If bytesperpixel& = 1 Then
        For c& = 0 To 255 ' read BGR color settings from JPG image + 1 byte spacer(CHR$(0))
            cv& = _PaletteColor(c&, image&) ' color attribute to read.
            b$ = b$ + Chr$(_Blue32(cv&)) + Chr$(_Green32(cv&)) + Chr$(_Red32(cv&)) + Chr$(0) 'spacer byte
        Next
    End If
    Mid$(b$, 11, 4) = MKL$(Len(b$)) ' image pixel data offset(BMP header)
    lastsource& = _Source
    _Source image&
    If ((x& * 3) Mod 4) Then padder$ = String$(4 - ((x& * 3) Mod 4), 0)
    For py& = y& - 1 To 0 Step -1 ' read JPG image pixel color data
        r$ = ""
        For px& = 0 To x& - 1
            c& = Point(px&, py&) 'POINT 32 bit values are large LONG values
            If bytesperpixel& = 1 Then r$ = r$ + Chr$(c&) Else r$ = r$ + Left$(MKL$(c&), 3)
        Next px&
        d$ = d$ + r$ + padder$
    Next py&
    _Source lastsource&
    Mid$(b$, 35, 4) = MKL$(Len(d$)) ' image size(BMP header)
    b$ = b$ + d$ ' total file data bytes to create file
    Mid$(b$, 3, 4) = MKL$(Len(b$)) ' size of data file(BMP header)
    If LCase$(Right$(filename$, 4)) <> ".bmp" Then ext$ = ".bmp"
    f& = FreeFile
    Open filename$ + ext$ For Output As #f&: Close #f& ' erases an existing file
    Open filename$ + ext$ For Binary As #f&
    Put #f&, , b$
    Close #f&
End Sub


Sub area (ax1, ay1, ax2, ay2, pic, ratio_y)

    x = _Width(pic)
    y = _Width(pic) * ratio_y

    If y > _Height(pic) Then
        y = _Height(pic)
        x = _Height(pic) / ratio_y
    End If

    ax1 = (_Width(pic) - x) / 2
    ax2 = ax1 + x
    ay1 = 0 '(_Height(pic) - y) / 2
    ay2 = ay1 + y



End Sub

Print this item

  CHALLENGE: Find a Way to Activate a Window
Posted by: Pete - 12-09-2022, 05:29 PM - Forum: General Discussion - Replies (9)

There's a catch... Of course virtual, not manual and it has to work in Linux and MacOS.

Okay, so in Windows we can use a WinAPI trick to min/restore a Window, which will "Activate" the window. Activate means it is not just in focus, it is also ready to use. With QB64, we can do a _SCREENCLICK to virtually activate it, just as if we clicked it! Oops, problem here is _SCREENCLICK, and other keywords like _SCREENPRINT, etc., are not supported in LInux and MacOC.

So the challenge is to replace the _SCREENCLICK line with something else (number of lines doesn't matter) that will have the same effect to activate the window.

So to try, you need to...

1) Copy and run the first and then the second snippet, in that order. They'll use the CLIPBOARD to message between the two windows. 

2) Adjust the windows on your desktop so they don't overlap.

3) Click the first program window to initially activate it.

4) Input a test message (Type and press Enter).

5) Notice the second window "Self-Activates" and displays the message received.

6) Input a reply.

7) The first window self-activates, displays the reply, and you are ready to input another message. It's like a ping-pong effect!

So the challenge is to sub out _SCREENCLICK with any line of code or sub-routine that will work in Linux / Mac OS to do the same effect, "activate" the window so we don't have to click on it.

This challenge is based on a much more polished chat app / messenger in this thread: https://staging.qb64phoenix.com/showthre...n=lastpost

If you solve it, you be the hero of the Linux/Mac community, literally billions upon billions of brain cells will thank you.

Program one, the host...

Code: (Select All)
WIDTH 50, 25
DO
    _CLIPBOARD$ = ""
    LINE INPUT "Message: "; msg$: PRINT
    _CLIPBOARD$ = msg$: msg$ = ""
    _DELAY 2
    DO
        _LIMIT 5
    LOOP UNTIL LEN(_CLIPBOARD$)
    '----------------------------------------------------------------------------------------------------
    ' Challenge: Replace line below with something that Linux/Mac can use to activate the window."
    _SCREENCLICK _SCREENX + 60, _SCREENY + 10
    '----------------------------------------------------------------------------------------------------
    msg$ = _CLIPBOARD$
    PRINT "Reply: "; msg$: PRINT
    _DELAY 1
LOOP

Program 2, the client...
Code: (Select All)
WIDTH 50, 25
DO
    DO
        _LIMIT 5
    LOOP UNTIL LEN(_CLIPBOARD$)
    '----------------------------------------------------------------------------------------------------
    ' Challenge: Replace line below with something that Linux/Mac can use to activate the window."
    _SCREENCLICK _SCREENX + 60, _SCREENY + 10
    '----------------------------------------------------------------------------------------------------
    msg$ = _CLIPBOARD$
    PRINT "Reply: "; msg$: PRINT
    _CLIPBOARD$ = ""
    LINE INPUT "Message: "; msg$
    _CLIPBOARD$ = msg$
    _DELAY 2
    _CLIPBOARD$ = "": msg$ = ""
LOOP

Print this item