Show Posts

This section allows you to view all posts made by this member. Note that you can only see posts made in areas you currently have access to.

Messages - SpriggsySpriggs

Pages: [1] 2 3 ... 77

Programs / Re: Finger Painting in QBJS

« on: April 10, 2022, 03:39:16 pm »

Awesome, dbox! Exciting stuff! I like how it loads instantly to the running program.

QB64 Discussion / Re: programmatically choose file details Windows Explorer displays for a given path?

« on: March 31, 2022, 07:53:51 pm »

Chances are, this would take a registry approach. I have a library for interfacing with the registry. I just wouldn't know which keys to mess with.

Programs / Re: Evolving RI (Robot Intelligence) for a room vacuum

« on: February 28, 2022, 09:35:14 pm »

bump n' go cars 2.0

QB64 Discussion / Re: Windows Notification sample

« on: February 28, 2022, 03:10:27 pm »

Are you running the code for 64 bit? If so, it most likely won't work. Most, if not all, of the Wiki samples are written specifically for 32 bit. That isn't to say it isn't possible to use in 64 bit. It would just take work. If I remember, I'll look at it and see if I can convert it for you

Programs / Re: Spotify API with OAuth2 (WIP) Windows Only

« on: February 24, 2022, 11:08:12 pm »

@Pete I'm intentionally ignoring errors in this iteration while it is still in this phase of testing. Sometimes the API doesn't respond as fast as QB64 would like and would cause it to have invalid handles. It seems better to just ignore and keep working. It's been rather stable so far but I won't keep it with the errors turned off like that when I get closer to the final product. I do trap whether or not authentication was successful, however.

Programs / Spotify API with OAuth2 (WIP) Windows Only

« on: February 24, 2022, 10:43:58 pm »

I'm currently working on a project for the Spotify API. The project is still in its infancy. Right now, you can see the album art, song info, and playback timestamp in real-time. This program will eventually have buttons and a trackbar to control playback. I'll track the progress for the project here. The main reason why I wanted to do this project was because I had never been able to do OAuth2 before in QB64. I had no idea how to do it. The most I had done with online API was just simple GETs and POSTs. Now I have figured out the proper way to do OAuth2 and authorize a QB64 program for more advanced API like this Spotify API. I accomplished the OAuth2 authorization using a slightly edited version of Luke's HTTP server code. Obviously, you will need a Spotify account in order to use this program. It is also designed to run while you are playing music on Spotify. You can play Spotify from anywhere and this will track it. You don't have to use your computer to play the music.

Here is a short video showing how it works:

Code: QB64 $NOPREFIX: [Select]

Option Explicit
$NoPrefix
'$Console:Only
 
On Error GoTo errorhandler
 
Const INTERNET_OPEN_TYPE_DIRECT = 1
 
Const INTERNET_DEFAULT_HTTP_PORT = 80
Const INTERNET_DEFAULT_HTTPS_PORT = 443
 
Const INTERNET_SERVICE_HTTP = 3
 
Const INTERNET_FLAG_SECURE = &H00800000
Const INTERNET_FLAG_RELOAD = &H80000000
 
Const HTTP_QUERY_CONTENT_LENGTH = 5
 
Const TRUE = 1
Const FALSE = 0
 
Const CLIENT_ID = "43b28a744c8947babd5766c3674e0a13"
Const CLIENT_SECRET = "965f8e02e48a48ad9063e89bf5b0995f"
Const REDIRECT_URI = "http://localhost:8888/"
 
Const SW_SHOWNORMAL = 1
 
Declare Dynamic Library "Wininet"
    Function InternetOpen%& Alias "InternetOpenA" (ByVal lpszAgent As Offset, Byval dwAccessType As Unsigned Long, Byval lpszProxy As Offset, Byval lpszProxyBypass As Offset, Byval dwFlags As Unsigned Long)
    Function InternetConnect%& Alias "InternetConnectA" (ByVal hInternet As Offset, Byval lpszServerName As Offset, Byval nServerPort As Unsigned Long, Byval lpszUserName As Offset, Byval lpszPassword As Offset, Byval dwService As Unsigned Long, Byval dwFlags As Unsigned Long, Byval dwContext As Unsigned Long)
    Function HttpOpenRequest%& Alias "HttpOpenRequestA" (ByVal hConnect As Offset, Byval lpszVerb As Offset, Byval lpszObjectName As Offset, Byval lpszVersion As Offset, Byval lpszReferer As Offset, Byval lplpszAcceptTypes As Offset, Byval dwFlags As Unsigned Long, Byval dwContext As Unsigned Offset)
    Function HttpSendRequest& Alias "HttpSendRequestA" (ByVal hRequest As Offset, Byval lpszHeaders As Offset, Byval dwHeadersLength As Unsigned Long, Byval lpOptional As Offset, Byval dwOptionalLength As Unsigned Long)
    Function HttpQueryInfo& Alias "HttpQueryInfoA" (ByVal hRequest As Offset, Byval dwInfoLevel As Unsigned Long, Byval lpBuffer As Offset, Byval lpdwBufferLength As Offset, Byval lpdwIndex As Offset)
    Sub InternetReadFile (ByVal hFile As Offset, Byval lpBuffer As Offset, Byval dwNumberOfBytesToRead As Unsigned Long, Byval lpdwNumberOfBytesRead As Offset)
    Sub InternetCloseHandle (ByVal hInternet As Offset)
End Declare
 
'$Include:'httpserv.BI'
 
$ExeIcon:'Spotify_icon.ico'
Icon
 
Dim Shared As String code, refreshtoken
 
Login
If code <> "" Then
    Screen NewImage(640, 640, 32)
    'Print code
    'ReDim As Long albumart(1 To 3)
    'ReDim As String albumarturl(0)
    Dim As Long albumart
    Dim As String albumartstring, oldart, oldsong
    Dim As String token
    Dim As String playbackstate
    Dim As String playing
    Dim As Long songlength, position, cseconds, cminutes, chours, dseconds, dminutes, dhours
    token = GetToken
    'Print token
    'Print "refresh_token:"; refreshtoken
    Do
 
        'Dim As String current: current = SpotifyAPI("https://api.spotify.com/v1/me/player/currently-playing?market=US", token)
        playbackstate = SpotifyAPI("https://api.spotify.com/v1/me/player?market=US", token)
        albumartstring = GetKey(playbackstate, "url")
        'albumart(1) = OnlineImage(albumarturl(1))
        'albumart(2) = OnlineImage(albumarturl(2))
        'albumart(3) = OnlineImage(albumarturl(3))
        If GetKey2(playbackstate, "is_playing") = "true" Then playing = "Playing" Else playing = "Paused"
        ReDim As String names(0)
        GetAllKey playbackstate, "name", names()
        If oldart <> albumartstring Or oldsong <> names((UBound(names))) Then
            token = GetRefreshedToken
            FreeImage albumart
            oldart = albumartstring
            oldsong = names((UBound(names)))
            albumart = OnlineImage(albumartstring)
            Title "Playing - " + names(UBound(names)) + " by " + names(2)
            songlength = Val(GetKey(playbackstate, "duration_ms"))
            dseconds = Int(songlength \ 1000) Mod 60
            dminutes = Int((songlength \ (1000 * 60)) Mod 60)
            dhours = Int((songlength \ (1000 * 60 * 60)) Mod 24)
        End If
        Cls
        PutImage , albumart, 0
        Print "Artist: "; names(2)
        Print "Album : "; names(3)
        Print "Song  : "; names((UBound(names)))
        Print playing
        position = Val(GetKey(playbackstate, "progress_ms"))
        cseconds = Int(position \ 1000) Mod 60
        cminutes = Int((position \ (1000 * 60)) Mod 60)
        chours = Int((position \ (1000 * 60 * 60)) Mod 24)
        If chours < 10 Then
            Print "0"; LTrim$(Str$(chours)); ":";
        Else
            Print LTrim$(Str$(chours)); ":";
        End If
        If cminutes < 10 Then
            Print "0"; LTrim$(Str$(cminutes)); ":";
        Else
            Print LTrim$(Str$(cminutes)); ":";
        End If
        If cseconds < 10 Then
            Print "0"; LTrim$(Str$(cseconds)); "/";
        Else
            Print LTrim$(Str$(cseconds)); "/";
        End If
        If dhours < 10 Then
            Print "0"; LTrim$(Str$(dhours)); ":";
        Else
            Print LTrim$(Str$(dhours)); ":";
        End If
        If dminutes < 10 Then
            Print "0"; LTrim$(Str$(dminutes)); ":";
        Else
            Print LTrim$(Str$(dminutes)); ":";
        End If
        If dseconds < 10 Then
            Print "0"; LTrim$(Str$(dseconds))
        Else
            Print LTrim$(Str$(dseconds))
        End If
 
        Display
        Limit 60
    Loop
End If
 
errorhandler:
Resume Next
 
Sub Login ()
    Declare Dynamic Library "Shell32"
        Sub ShellExecute Alias "ShellExecuteA" (ByVal hwnd As Offset, lpOperation As String, lpFile As String, Byval lpParameters As Offset, Byval lpDirectory As Offset, Byval nShowCmd As Long)
    End Declare
    Dim As String URL: URL = "https://accounts.spotify.com/authorize?response_type=code&client_id=" + CLIENT_ID + "&scope=user-modify-playback-state%20user-read-playback-state%20user-read-currently-playing%20user-read-recently-played&state=cAzgzTDzXnVYqbAM&show_dialog=true&redirect_uri=" + REDIRECT_URI
    ShellExecute 0, "open" + Chr$(0), URL + Chr$(0), 0, 0, SW_SHOWNORMAL
    OAuth2ServerStart
End Sub
 
Function GetKey2$ (JSON As String, jkey As String)
    Dim As String outj
    outj = Mid$(JSON, InStr(JSON, Chr$(34) + jkey + Chr$(34) + " : ") + Len(Chr$(34) + jkey + Chr$(34) + " : "))
    If Mid$(outj, 1, 1) = Chr$(34) Then outj = Mid$(outj, 2)
    If Mid$(outj, Len(outj), 1) = Chr$(34) Then outj = Mid$(outj, Len(outj) - 1)
    outj = Mid$(outj, 1, Len(outj) - 2)
    GetKey2 = outj
End Function
 
Function GetRefreshedToken$ ()
    Dim As String URL: URL = "https://accounts.spotify.com/api/token"
    Dim As String server, apipath
    server = Mid$(URL, InStr(URL, "/") + 2)
    server = Mid$(server, 1, InStr(server, "/") - 1)
    apipath = Mid$(URL, InStr(URL, server) + Len(server)) + Chr$(0)
    server = server + Chr$(0)
    Dim As Offset hInternet: hInternet = InternetOpen(0, INTERNET_OPEN_TYPE_DIRECT, 0, 0, 0)
    If hInternet = 0 Then
        Exit Function
    End If
    Dim As Offset hConnect: hConnect = InternetConnect(hInternet, Offset(server), INTERNET_DEFAULT_HTTPS_PORT, 0, 0, INTERNET_SERVICE_HTTP, 0, 0)
    If hConnect = 0 Then
        InternetCloseHandle hInternet
        Exit Function
    End If
    Dim As String sessiontype, accepttypes
    sessiontype = "POST" + Chr$(0)
    accepttypes = "application/json" + Chr$(0)
    Dim As Offset hRequest: hRequest = HttpOpenRequest(hConnect, Offset(sessiontype), Offset(apipath), 0, 0, Offset(accepttypes), INTERNET_FLAG_RELOAD Or INTERNET_FLAG_SECURE, 0)
    If hRequest = 0 Then
        InternetCloseHandle hConnect
        InternetCloseHandle hInternet
        Exit Function
    End If
    Dim As String opt: opt = "grant_type=refresh_token&refresh_token=" + refreshtoken
    Dim As String headers: headers = "Authorization: Basic " + encodeBase64(CLIENT_ID + ":" + CLIENT_SECRET) + Chr$(13) + Chr$(10) + "Content-Type: application/x-www-form-urlencoded" + Chr$(0)
    If HttpSendRequest(hRequest, Offset(headers), -1, Offset(opt), Len(opt)) <> TRUE Then
        InternetCloseHandle hRequest
        InternetCloseHandle hConnect
        InternetCloseHandle hInternet
        Exit Function
    End If
    Dim As String queryinfo: queryinfo = Space$(1024)
    Dim As Unsigned Long querylen: querylen = Len(queryinfo) - 1
 
    If HttpQueryInfo(hRequest, HTTP_QUERY_CONTENT_LENGTH, Offset(queryinfo), Offset(querylen), 0) <> TRUE Then
        InternetCloseHandle hRequest
        InternetCloseHandle hConnect
        InternetCloseHandle hInternet
        Exit Function
    End If
 
    Dim As String szBuffer: szBuffer = Space$(4097)
    Dim As String response
    Dim As Unsigned Long dwRead
    Do
        InternetReadFile hRequest, Offset(szBuffer), Len(szBuffer) - 1, Offset(dwRead)
        If dwRead > 0 Then response = response + Mid$(szBuffer, 1, dwRead)
    Loop While dwRead
    InternetCloseHandle hRequest
    InternetCloseHandle hConnect
    InternetCloseHandle hInternet
    'refreshtoken = GetKey(response, "refresh_token")
    GetRefreshedToken = GetKey(response, "access_token")
End Function
 
Function GetToken$ ()
    Dim As String URL: URL = "https://accounts.spotify.com/api/token"
    Dim As String server, apipath
    server = Mid$(URL, InStr(URL, "/") + 2)
    server = Mid$(server, 1, InStr(server, "/") - 1)
    apipath = Mid$(URL, InStr(URL, server) + Len(server)) + Chr$(0)
    server = server + Chr$(0)
    Dim As Offset hInternet: hInternet = InternetOpen(0, INTERNET_OPEN_TYPE_DIRECT, 0, 0, 0)
    If hInternet = 0 Then
        Exit Function
    End If
    Dim As Offset hConnect: hConnect = InternetConnect(hInternet, Offset(server), INTERNET_DEFAULT_HTTPS_PORT, 0, 0, INTERNET_SERVICE_HTTP, 0, 0)
    If hConnect = 0 Then
        InternetCloseHandle hInternet
        Exit Function
    End If
    Dim As String sessiontype, accepttypes
    sessiontype = "POST" + Chr$(0)
    accepttypes = "application/json" + Chr$(0)
    Dim As Offset hRequest: hRequest = HttpOpenRequest(hConnect, Offset(sessiontype), Offset(apipath), 0, 0, Offset(accepttypes), INTERNET_FLAG_RELOAD Or INTERNET_FLAG_SECURE, 0)
    If hRequest = 0 Then
        InternetCloseHandle hConnect
        InternetCloseHandle hInternet
        Exit Function
    End If
    Dim As String opt: opt = "grant_type=authorization_code&code=" + code + "&redirect_uri=http://localhost:8888/"
    Dim As String headers: headers = "Authorization: Basic " + encodeBase64(CLIENT_ID + ":" + CLIENT_SECRET) + Chr$(13) + Chr$(10) + "Content-Type: application/x-www-form-urlencoded" + Chr$(0)
    If HttpSendRequest(hRequest, Offset(headers), -1, Offset(opt), Len(opt)) <> TRUE Then
        InternetCloseHandle hRequest
        InternetCloseHandle hConnect
        InternetCloseHandle hInternet
        Exit Function
    End If
    Dim As String queryinfo: queryinfo = Space$(1024)
    Dim As Unsigned Long querylen: querylen = Len(queryinfo) - 1
 
    If HttpQueryInfo(hRequest, HTTP_QUERY_CONTENT_LENGTH, Offset(queryinfo), Offset(querylen), 0) <> TRUE Then
        InternetCloseHandle hRequest
        InternetCloseHandle hConnect
        InternetCloseHandle hInternet
        Exit Function
    End If
 
    Dim As String szBuffer: szBuffer = Space$(4097)
    Dim As String response
    Dim As Unsigned Long dwRead
    Do
        InternetReadFile hRequest, Offset(szBuffer), Len(szBuffer) - 1, Offset(dwRead)
        If dwRead > 0 Then response = response + Mid$(szBuffer, 1, dwRead)
    Loop While dwRead
    InternetCloseHandle hRequest
    InternetCloseHandle hConnect
    InternetCloseHandle hInternet
    refreshtoken = GetKey(response, "refresh_token")
    GetToken = GetKey(response, "access_token")
End Function
 
Function SpotifyAPI$ (URL As String, token As String)
    Dim As String server, apipath
    server = Mid$(URL, InStr(URL, "/") + 2)
    server = Mid$(server, 1, InStr(server, "/") - 1)
    apipath = Mid$(URL, InStr(URL, server) + Len(server)) + Chr$(0)
    server = server + Chr$(0)
    Dim As Offset hInternet: hInternet = InternetOpen(0, INTERNET_OPEN_TYPE_DIRECT, 0, 0, 0)
    If hInternet = 0 Then
        Exit Function
    End If
    Dim As Offset hConnect: hConnect = InternetConnect(hInternet, Offset(server), INTERNET_DEFAULT_HTTPS_PORT, 0, 0, INTERNET_SERVICE_HTTP, 0, 0)
    If hConnect = 0 Then
        InternetCloseHandle hInternet
        Exit Function
    End If
    Dim As String sessiontype, accepttypes
    sessiontype = "GET" + Chr$(0)
    accepttypes = "application/json" + Chr$(0)
    Dim As Offset hRequest: hRequest = HttpOpenRequest(hConnect, Offset(sessiontype), Offset(apipath), 0, 0, Offset(accepttypes), INTERNET_FLAG_RELOAD Or INTERNET_FLAG_SECURE, 0)
    If hRequest = 0 Then
        InternetCloseHandle hConnect
        InternetCloseHandle hInternet
        Exit Function
    End If
    Dim As String headers: headers = "Authorization: Bearer " + token + Chr$(0)
    If HttpSendRequest(hRequest, Offset(headers), -1, 0, 0) <> TRUE Then
        InternetCloseHandle hRequest
        InternetCloseHandle hConnect
        InternetCloseHandle hInternet
        Exit Function
    End If
    Dim As String queryinfo: queryinfo = Space$(1024)
    Dim As Unsigned Long querylen: querylen = Len(queryinfo) - 1
 
    If HttpQueryInfo(hRequest, HTTP_QUERY_CONTENT_LENGTH, Offset(queryinfo), Offset(querylen), 0) <> TRUE Then
        InternetCloseHandle hRequest
        InternetCloseHandle hConnect
        InternetCloseHandle hInternet
        Exit Function
    End If
 
    Dim As String szBuffer: szBuffer = Space$(4097)
    Dim As String response
    Dim As Unsigned Long dwRead
    Do
        InternetReadFile hRequest, Offset(szBuffer), Len(szBuffer) - 1, Offset(dwRead)
        If dwRead > 0 Then response = response + Mid$(szBuffer, 1, dwRead)
    Loop While dwRead
    InternetCloseHandle hRequest
    InternetCloseHandle hConnect
    InternetCloseHandle hInternet
    SpotifyAPI = response
End Function
 
Function GetKey$ (JSON As String, keyname As String)
    Dim jkey As String
    jkey = JSON
    If InStr(jkey, Chr$(34) + keyname + Chr$(34)) Then
        jkey = Mid$(jkey, InStr(jkey, Chr$(34) + keyname + Chr$(34)) + Len(keyname))
        jkey = Mid$(jkey, InStr(jkey, ":") + 2)
        jkey = String.Replace(jkey, "\" + Chr$(34), "'")
        If Mid$(jkey, 1, 1) = Chr$(34) Then
            jkey = Mid$(jkey, 2)
        End If
        jkey = Mid$(jkey, 1, InStr(jkey, Chr$(34)) - 1)
        If Right$(jkey, 1) = "," Then
            jkey = Mid$(jkey, 1, Len(jkey) - 1)
        End If
    Else
        GetKey = ""
    End If
    GetKey = jkey
End Function
 
Sub GetAllKey (JSON As String, keyname As String, ParseKey() As String)
    Dim unchangejson As String
    Dim jkey As String
    Dim x
    unchangejson = JSON
    Do
        If InStr(unchangejson, Chr$(34) + keyname + Chr$(34)) Then
            x = x + 1
            ReDim _Preserve ParseKey(x) As String
            unchangejson = Mid$(unchangejson, InStr(unchangejson, Chr$(34) + keyname + Chr$(34)) + Len(keyname))
            jkey = unchangejson
            jkey = Mid$(jkey, InStr(jkey, ":") + 2)
            jkey = String.Replace(jkey, "\" + Chr$(34), "'")
            If Mid$(jkey, 1, 1) = Chr$(34) Then
                jkey = Mid$(jkey, 2)
            End If
            jkey = Mid$(jkey, 1, InStr(jkey, Chr$(34)) - 1)
            If Right$(jkey, 1) = "," Then
                jkey = Mid$(jkey, 1, Len(jkey) - 1)
            End If
            ParseKey(x) = jkey
        End If
    Loop Until InStr(unchangejson, Chr$(34) + keyname + Chr$(34)) = 0
End Sub
 
Function String.Replace$ (a As String, b As String, c As String)
    Dim j
    Dim r
    Dim r$
    j = InStr(a, b)
    If j > 0 Then
        r$ = Left$(a, j - 1) + c + String.Replace(Right$(a, Len(a) - j + 1 - Len(b)), b, c)
    Else
        r$ = a
    End If
    String.Replace = r$
End Function
 
Function encodeBase64$ (encode As String)
    Declare Dynamic Library "Crypt32"
        Function CryptBinaryToString& Alias "CryptBinaryToStringA" (ByVal pbBinary As Offset, Byval cbBinary As Unsigned Long, Byval dwFlags As Unsigned Long, Byval pszString As Offset, Byval pcchString As Offset)
    End Declare
    Const CRYPT_STRING_NOCRLF = &H40000000
    Const CRYPT_STRING_BASE64 = &H00000001
    Dim As String encoded
    Dim As Unsigned Long lenEncoded
    If CryptBinaryToString(Offset(encode), Len(encode), CRYPT_STRING_BASE64 Or CRYPT_STRING_NOCRLF, 0, Offset(lenEncoded)) <> FALSE Then
        encoded = Space$(lenEncoded)
    Else
        encodeBase64 = ""
        Exit Function
    End If
    If CryptBinaryToString(Offset(encode), Len(encode), CRYPT_STRING_BASE64 Or CRYPT_STRING_NOCRLF, Offset(encoded), Offset(lenEncoded)) <> FALSE Then
        encodeBase64 = Mid$(encoded, 1, lenEncoded)
    Else
        encodeBase64 = ""
    End If
End Function
 
Sub OAuth2ServerStart
    Dim i
    Dim num_active_connections
    Dim server_handle
    server_handle = _OpenHost("TCP/IP:" + LTrim$(Str$(PORT)))
    Do
        If num_active_connections < MAX_CONNECTIONS Then
            Dim new_connection
            new_connection = _OpenConnection(server_handle)
            If new_connection Then
                num_active_connections = num_active_connections + 1
                For i = 1 To MAX_CONNECTIONS
                    If Connections(i).handle = 0 Then
                        Dim empty_connection As connection_t
                        Connections(i) = empty_connection
                        Connections(i).handle = new_connection
                        Exit For
                    End If
                Next i
            End If
        End If
 
        For i = 1 To MAX_CONNECTIONS
            If Connections(i).handle Then
                Dim buf$
                Get #Connections(i).handle, , buf$
                If buf$ <> "" Then
                    Connections(i).read_buf = Connections(i).read_buf + buf$
                    process_request i
                    http_error_complete:
                End If
            End If
        Next i
        _Limit 240
    Loop Until InStr(code, "code=") Or InStr(code, "error=")
    If InStr(code, "code=") Then
        code = Mid$(code, Len("?/code=") + 1)
        code = Mid$(code, 1, InStr(code, "&state") - 1)
    Else
        code = ""
    End If
End Sub
 
'$Include:'httpserv.BM'
Function OnlineImage& (URL As String)
    Declare CustomType Library
        Function GetTempFileName~& (ByVal lpPathName As Offset, Byval lpPrefixString As Offset, Byval uUnique As Unsigned Long, Byval lpTempFileName As Offset)
        Function GetTempPath~& (ByVal nBufferLength As Unsigned Long, Byval lpBuffer As Offset)
    End Declare
    Dim getpath As Long
    Dim getfile As _Unsigned Long
 
    Dim path As String
    path = Space$(260 + 1)
    getpath = GetTempPath(Len(path), _Offset(path))
 
    path = _Trim$(path)
 
    Dim file As String
    Dim prefix As String
    Dim unique As _Unsigned Integer
    Randomize Timer
    unique = Int(Rnd * 999) + 1
    prefix = "spr" + Chr$(0)
    Dim tempfile As String
    tempfile = Space$(260 + 1)
 
    getfile = GetTempFileName(_Offset(path), _Offset(prefix), unique, _Offset(tempfile))
 
    tempfile = _Trim$(tempfile)
 
    URL = Mid$(URL, InStr(URL, "https://") + 8)
    Dim location As String
    location = Mid$(URL, InStr(URL, "/")) + Chr$(0)
    URL = Mid$(URL, 1, InStr(URL, "/") - 1) + Chr$(0)
    Dim As _Offset hsession, httpsession, httprequest
    hsession = InternetOpen(0, INTERNET_OPEN_TYPE_DIRECT, 0, 0, 0)
 
    httpsession = InternetConnect(hsession, _Offset(URL), INTERNET_DEFAULT_HTTPS_PORT, 0, 0, INTERNET_SERVICE_HTTP, 0, 0)
 
    Dim sessiontype As String
    sessiontype = "GET" + Chr$(0)
    httprequest = HttpOpenRequest(httpsession, _Offset(sessiontype), _Offset(location), 0, 0, 0, INTERNET_FLAG_RELOAD Or INTERNET_FLAG_SECURE, 0)
 
    Dim sendrequest As Long
    sendrequest = HttpSendRequest(httprequest, 0, 0, 0, 0)
    Dim szBuffer As String
    szBuffer = Space$(2048)
    Dim dwRead As _Unsigned Long
    Dim picfile As String
    Open tempfile For Binary As #1
    Do
        InternetReadFile httprequest, _Offset(szBuffer), Len(szBuffer), _Offset(dwRead)
        If dwRead > 0 Then picfile = picfile + Mid$(szBuffer, 1, dwRead)
    Loop While dwRead
    Put #1, , picfile
    Close #1
    InternetCloseHandle hsession
    OnlineImage = _LoadImage(tempfile, 32)
    Kill tempfile
End Function

Programs / Re: Rosie Bot

« on: February 24, 2022, 02:01:11 pm »

Speaking of text to speech, I wonder if you can access the new natural voices in Windows 11 through the command line. The new voices sound really good

Programs / Re: Draw any curve using only circles

« on: February 23, 2022, 06:37:14 pm »

I wish I understood math more. This is impressive stuff, Bill!

Programs / Re: Split Versus Tokenize

« on: February 01, 2022, 02:49:57 pm »

You're intentionally misinterpreting what I'm saying but that's ok. If you prefer to remain ignorant then by all means, please do.

Programs / Re: Split Versus Tokenize

« on: February 01, 2022, 01:37:21 pm »

The reason you weren't preserving blank lines is because you are using tokenize incorrectly. You should pass it either CHR$(13) or CHR$(10) (can't remember which). If you pass both, it'll split by both. It can take a list of delimiters.

Programs / Re: Quick Directory Files Listing for Windows Only

« on: February 01, 2022, 03:09:17 am »

But if we're going to stick to using dir commands, I think my way of splitting a string into an array is slightly better:

Code: QB64: [Select]

Option _Explicit
$Console:Only
 
Dim comm As String
comm = pipecom_lite("DIR *.* /a:-d /b /o:-gen")
 
ReDim As String filelist(0 To 0)
tokenize comm, Chr$(10), filelist()
Dim As _Integer64 i
For i = 0 To UBound(filelist) - 1
    Print i + 1, filelist(i)
Next
Sleep
 
Function pointerToString$ (pointer As _Offset)
    Declare CustomType Library
        Function strlen%& (ByVal ptr As _Unsigned _Offset)
    End Declare
    Dim As _Offset length: length = strlen(pointer)
    If length Then
        Dim As _MEM pString: pString = _Mem(pointer, length)
        Dim As String ret: ret = Space$(length)
        _MemGet pString, pString.OFFSET, ret
        _MemFree pString
    End If
    pointerToString = ret
End Function
 
Sub tokenize (toTokenize As String, delimiters As String, StorageArray() As String)
    Declare CustomType Library
        Function strtok%& (ByVal str As _Offset, delimiters As String)
    End Declare
    Dim As _Offset tokenized
    Dim As String tokCopy: tokCopy = toTokenize + Chr$(0)
    Dim As String delCopy: delCopy = delimiters + Chr$(0)
    Dim As _Unsigned Long lowerbound: lowerbound = LBound(StorageArray)
    Dim As _Unsigned Long i: i = lowerbound
    tokenized = strtok(_Offset(tokCopy), delCopy)
    While tokenized <> 0
        ReDim _Preserve StorageArray(lowerbound To UBound(StorageArray) + 1)
        StorageArray(i) = pointerToString(tokenized)
        tokenized = strtok(0, delCopy)
        i = i + 1
    Wend
    ReDim _Preserve StorageArray(UBound(StorageArray) - 1)
End Sub
 
$If PIPECOM = UNDEFINED Then
    $Let PIPECOM = TRUE
    Function pipecom& (cmd As String, stdout As String, stderr As String)
        stdout = "": stderr = ""
        $If WIN Then
            Type SECURITY_ATTRIBUTES
                As _Unsigned Long nLength
                $If 64BIT Then
                    As String * 4 padding
                $End If
                As _Offset lpSecurityDescriptor
                As Long bInheritHandle
                $If 64BIT Then
                    As String * 4 padding2
                $End If
            End Type
 
            Type STARTUPINFO
                As Long cb
                $If 64BIT Then
                    As String * 4 padding
                $End If
                As _Offset lpReserved, lpDesktop, lpTitle
                As _Unsigned Long dwX, dwY, dwXSize, dwYSize, dwXCountChars, dwYCountChars, dwFillAttribute, dwFlags
                As _Unsigned Integer wShowWindow, cbReserved2
                $If 64BIT Then
                    As String * 4 padding2
                $End If
                As _Offset lpReserved2, hStdInput, hStdOutput, hStdError
            End Type
 
            Type PROCESS_INFORMATION
                As _Offset hProcess, hThread
                As _Unsigned Long dwProcessId
                $If 64BIT Then
                    As String * 4 padding
                $End If
            End Type
 
            Const STARTF_USESTDHANDLES = &H00000100
            Const CREATE_NO_WINDOW = &H8000000
 
            Const INFINITE = 4294967295
            Const WAIT_FAILED = &HFFFFFFFF
 
            Declare CustomType Library
                Function CreatePipe& (ByVal hReadPipe As _Offset, Byval hWritePipe As _Offset, Byval lpPipeAttributes As _Offset, Byval nSize As _Unsigned Long)
                Function CreateProcess& (ByVal lpApplicationName As _Offset, Byval lpCommandLine As _Offset, Byval lpProcessAttributes As _Offset, Byval lpThreadAttributes As _Offset, Byval bInheritHandles As Long, Byval dwCreationFlags As _Unsigned Long, Byval lpEnvironment As _Offset, Byval lpCurrentDirectory As _Offset, Byval lpStartupInfo As _Offset, Byval lpProcessInformation As _Offset)
                Function GetExitCodeProcess& (ByVal hProcess As _Offset, Byval lpExitCode As _Offset)
                Sub HandleClose Alias "CloseHandle" (ByVal hObject As _Offset)
                Function ReadFile& (ByVal hFile As _Offset, Byval lpBuffer As _Offset, Byval nNumberOfBytesToRead As _Unsigned Long, Byval lpNumberOfBytesRead As _Offset, Byval lpOverlapped As _Offset)
                Function WaitForSingleObject~& (ByVal hHandle As _Offset, Byval dwMilliseconds As _Unsigned Long)
            End Declare
 
            Dim As Long ok: ok = 1
            Dim As _Offset hStdOutPipeRead, hStdOutPipeWrite, hStdReadPipeError, hStdOutPipeError
            Dim As SECURITY_ATTRIBUTES sa: sa.nLength = Len(sa): sa.lpSecurityDescriptor = 0: sa.bInheritHandle = 1
 
            If CreatePipe(_Offset(hStdOutPipeRead), _Offset(hStdOutPipeWrite), _Offset(sa), 0) = 0 Then
                pipecom = -1
                Exit Function
            End If
 
            If CreatePipe(_Offset(hStdReadPipeError), _Offset(hStdOutPipeError), _Offset(sa), 0) = 0 Then
                pipecom = -1
                Exit Function
            End If
 
            Dim As STARTUPINFO si
            si.cb = Len(si)
            si.dwFlags = STARTF_USESTDHANDLES
            si.hStdError = hStdOutPipeError
            si.hStdOutput = hStdOutPipeWrite
            si.hStdInput = 0
            Dim As PROCESS_INFORMATION procinfo
            Dim As _Offset lpApplicationName
            Dim As String lpCommandLine: lpCommandLine = "cmd /c " + cmd + Chr$(0)
            Dim As _Offset lpProcessAttributes, lpThreadAttributes
            Dim As Long bInheritHandles: bInheritHandles = 1
            Dim As _Unsigned Long dwCreationFlags: dwCreationFlags = CREATE_NO_WINDOW
            Dim As _Offset lpEnvironment, lpCurrentDirectory
            ok = CreateProcess(lpApplicationName, _Offset(lpCommandLine), lpProcessAttributes, lpThreadAttributes, bInheritHandles, dwCreationFlags, lpEnvironment, lpCurrentDirectory, _Offset(si), _Offset(procinfo))
 
            If ok = 0 Then
                pipecom = -1
                Exit Function
            End If
 
            HandleClose hStdOutPipeWrite
            HandleClose hStdOutPipeError
 
            Dim As String buf: buf = Space$(4096 + 1)
            Dim As _Unsigned Long dwRead
            While ReadFile(hStdOutPipeRead, _Offset(buf), 4096, _Offset(dwRead), 0) <> 0 And dwRead > 0
                buf = Mid$(buf, 1, dwRead)
                GoSub RemoveChr13
                stdout = stdout + buf
                buf = Space$(4096 + 1)
            Wend
 
            While ReadFile(hStdReadPipeError, _Offset(buf), 4096, _Offset(dwRead), 0) <> 0 And dwRead > 0
                buf = Mid$(buf, 1, dwRead)
                GoSub RemoveChr13
                stderr = stderr + buf
                buf = Space$(4096 + 1)
            Wend
 
            Dim As Long exit_code, ex_stat
            If WaitForSingleObject(procinfo.hProcess, INFINITE) <> WAIT_FAILED Then
                If GetExitCodeProcess(procinfo.hProcess, _Offset(exit_code)) Then
                    ex_stat = 1
                End If
            End If
 
            HandleClose hStdOutPipeRead
            HandleClose hStdReadPipeError
            If ex_stat = 1 Then
                pipecom = exit_code
            Else
                pipecom = -1
            End If
 
            Exit Function
 
            RemoveChr13:
            Dim As Long j
            j = InStr(buf, Chr$(13))
            Do While j
                buf = Left$(buf, j - 1) + Mid$(buf, j + 1)
                j = InStr(buf, Chr$(13))
            Loop
            Return
        $Else
            Declare CustomType Library
            Function popen%& (cmd As String, readtype As String)
            Function feof& (ByVal stream As _Offset)
            Function fgets$ (str As String, Byval n As Long, Byval stream As _Offset)
            Function pclose& (ByVal stream As _Offset)
            End Declare
 
            Declare Library
            Function WEXITSTATUS& (ByVal stat_val As Long)
            End Declare
 
            Dim As _Offset stream
 
            Dim buffer As String * 4096
            If _FileExists("pipestderr") Then
            Kill "pipestderr"
            End If
            stream = popen(cmd + " 2>pipestderr" + Chr$(0), "r")
            If stream Then
            While feof(stream) = 0
            If fgets(buffer, 4096, stream) <> "" And feof(stream) = 0 Then
            stdout = stdout + Mid$(buffer, 1, InStr(buffer, Chr$(0)) - 1)
            End If
            Wend
            Dim As Long status, exit_code
            status = pclose(stream)
            exit_code = WEXITSTATUS(status)
            If _FileExists("pipestderr") Then
            Dim As Integer errfile
            errfile = FreeFile
            Open "pipestderr" For Binary As #errfile
            If LOF(errfile) > 0 Then
            stderr = Space$(LOF(errfile))
            Get #errfile, , stderr
            End If
            Close #errfile
            Kill "pipestderr"
            End If
            pipecom = exit_code
            Else
            pipecom = -1
            End If
        $End If
    End Function
 
    Function pipecom_lite$ (cmd As String)
        Dim As Long a
        Dim As String stdout, stderr
        a = pipecom(cmd, stdout, stderr)
        If stderr <> "" Then
            pipecom_lite = stderr
        Else
            pipecom_lite = stdout
        End If
    End Function
$End If
 

Programs / Re: Quick Directory Files Listing for Windows Only

« on: February 01, 2022, 02:47:08 am »

Since we're doing Windows only:

Code: QB64: [Select]

Option Explicit
$NoPrefix
$Console:Only
 
Const MAX_PATH = 260
 
Type FILETIME
    As Unsigned Long dwLowDateTime, dwHighDateTime
End Type
 
Type WIN32_FIND_DATA
    As Unsigned Long dwFileAttributes
    As FILETIME ftCreationTime, ftLastAccessTime, ftLastWriteTime
    As Unsigned Long nFileSizeHigh, nFileSizeLow, dwReserved0, dwReserved1
    As String * Max_path cFileName
    As String * 14 cAlternateFileName
    As Unsigned Long dwFileType, dwCreatorType
    As Unsigned Integer wFinderFlags
End Type
 
Declare CustomType Library
    Function FindFirstFile%& (ByVal lpFileName As Offset, Byval lpFindFileData As Offset)
    Function FindNextFile& (ByVal hFindFile As Offset, Byval lpFindFileData As Offset)
End Declare
 
Dim As String start: start = CWD$ + "\*.bas" + Chr$(0)
Dim As Offset lpFileName: lpFileName = Offset(start)
Dim As WIN32_FIND_DATA find
 
ReDim As String * MAX_PATH filelist(0 To 0)
 
Dim As Offset hFind: hFind = FindFirstFile(lpFileName, Offset(find))
 
If hFind Then
    Dim As Unsigned Integer64 filesize: filesize = SHL(find.nFileSizeHigh, 32) Or find.nFileSizeLow
    filelist(0) = find.cFileName
    Print filelist(0), filesize; "bytes"
    While FindNextFile(hFind, Offset(find))
        filesize = SHL(find.nFileSizeHigh, 32) Or find.nFileSizeLow
        ReDim Preserve As String * 260 filelist(UBound(filelist) + 1)
        filelist(UBound(filelist)) = find.cFileName
        Print filelist(UBound(filelist)), filesize; "bytes"
    Wend
    Print UBound(filelist); "files"
End If

Programs / Re: Quick Directory Files Listing for Windows Only

« on: January 31, 2022, 04:35:10 pm »

@bplus That would be incorrect. It's been compatible with all operating systems since release. You might be thinking of a different issue where there was a null character throwing off results. That issue has since been resolved. However, the code you wrote here wasn't designed for Linux so even if my code wasn't compatible with Linux, it has no need to be mentioned here.

Programs / Re: Quick Directory Files Listing for Windows Only

« on: January 31, 2022, 03:36:20 pm »

This is basically the same code as what's on the Wiki. I'd change this to use pipecom so you don't use temp files at all.

QB64 Discussion / Re: is there a way to get the name of a function to call from a variable or data?

« on: January 26, 2022, 11:54:09 am »

There's another way of doing this that's slightly more intuitive. I'll see if I can find my code for it

Pages: [1] 2 3 ... 77

News:

Show Posts

Messages - SpriggsySpriggs

Programs / Re: Finger Painting in QBJS

QB64 Discussion / Re: programmatically choose file details Windows Explorer displays for a given path?

Programs / Re: Evolving RI (Robot Intelligence) for a room vacuum

QB64 Discussion / Re: Windows Notification sample

Programs / Re: Spotify API with OAuth2 (WIP) Windows Only

Programs / Spotify API with OAuth2 (WIP) Windows Only

Programs / Re: Rosie Bot

Programs / Re: Draw any curve using only circles

Programs / Re: Split Versus Tokenize

Programs / Re: Split Versus Tokenize

Programs / Re: Quick Directory Files Listing for Windows Only

Programs / Re: Quick Directory Files Listing for Windows Only

Programs / Re: Quick Directory Files Listing for Windows Only

Programs / Re: Quick Directory Files Listing for Windows Only

QB64 Discussion / Re: is there a way to get the name of a function to call from a variable or data?