Announcement

Collapse
No announcement yet.

ISBN book info lookup - reviving an old project

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • ISBN book info lookup - reviving an old project

    This project allowed me to scan a book's ISBN barcode, grab it as text, construct a query string, connect to the ISBNdb.com database with the query, and retrieve and parse the returned data.
    As a minimum, I intended to create a list of scanned books, and hoped to eventually create an actual database.

    The scanner was capable of either "S&R" mode (Scan and Retrieve = scan one barcode, query, retrieve one record), or "C&R" mode (Collect and Retrieve = scan many barcodes, then upload as a batch, and retrieve a full data set.). As LIFE intervened and threw some curves, the project never got beyond the initial "proof of concept". I was able to get got the S&R working (do queries one-at-a-time), but the project languished and I never got C&R working.

    I developed the code in December of 2010 by modifying the PB Serial Communications example with Jose Roca includes. I was running either WinXP or Win7, and using an IBS-800 barcode scanner and data collector on a virtual COM port. And, at that time, ISBNdb.com allowed a registered user to submit a query via the calling URL.

    Now I once again have a need to inventory a library of specialized books. However, I now have a NADAMOO BUR3146 wireless 2D scanner that will work wired, or via Bluetooth OR COM port, and can do both S&R and C&R modes. (Given that around 2010 the IBS-800 cost hundreds of dollars, I'm amazed that I got this new scanner for about $40!) I'm still on the learning curve with the new scanner, so don't know a lot about using the different interfaces.

    OK, so just running my old program, I find that ISBNdb.com now rejects my old URL access/query, and says their requests must be HTML forms... OK, so I have a lot of reading to do, and then decide if I need to use their API...

    I've searched the PB forum for anyone with ISBNdb.com experience and found none. So I'm planning on "blogging" my progress in this thread, in case it might be of help or interest to others.

    HOWEVER, because there are SO MANY MORE OTHER PROJECTS to do when you're semi-retired, I will not be blazing through this in a few days. (I couldn't do that even when I was programming full-time!). So progress will be slow, but steady.

    Since I have lost touch with what's "correct" in Win10, you will see, I'm sure, lots of "old school" code, and not very clever at that. But I will get it to work on my machine, and will try to address any questions you may have.

    So, anyone interested in watching this project?

    Best regards,
    -John


    PROBLEM: Wwhen I try to paste the code into this message using the CODE tags, it destroys all formatting indentations. How to prevent this?

    As soon as I have a fix for that, I'll post the old code...
    -jhm

  • #2

    PROBLEM: When I try to paste the code into this message using the CODE tags, it destroys all formatting indentations. How to prevent this?
    https://forum.powerbasic.com/forum/a...ion-formatting
    Rod
    I want not 'not', not Knot, not Knott, not Nott, not knot, not naught, not nought, but aught.

    Comment


    • #3
      Originally posted by John Montenigro View Post

      So, anyone interested in watching this project?

      Best regards,
      -John


      PROBLEM: Wwhen I try to paste the code into this message using the CODE tags, it destroys all formatting indentations. How to prevent this?
      I'll be interested.

      If you put the CODE tags in your original source and copy/paste the whole block, the indentation is preserved.

      If you comment those lines, you can leave them there all the time.

      '
      Code:
      #COMPILE EXE
      #DIM ALL
      FUNCTION PBMAIN() AS LONG
           ? "This source code has commented out CODE tags on the first and last line"
           ' Note the single quotes at the start and end of the forum code block
           ' they precede the CODE tags in the source code to comment them out
      END FUNCTION
      '
      Click image for larger version

Name:	codetags.jpg
Views:	98
Size:	25.0 KB
ID:	806608

      Comment


      • #4
        Thanks for those tips!

        I'm already attempting to test updated code, so I'll post what I've got over the weekend.

        Thanks,
        -John

        Comment


        • #5
          Update:
          At https://isbndb.com/apidocs/v2, there are code samples in PHP, C#, Python, Java, and JS, but not VB.

          My initial options were:
          1. use HTTP functions from Jose Roca Include files
          2. use SocketTools10
          3. download someone else's application.

          Option 1: I just don't have the depth of knowledge in the HTTP connection arena, and I've been having trouble translating from the other languages. And although a CHM file exists for the JR include file, it is lacking any entries for the HTTP function, so unless I put in another 5 days of experimenting, I'm SOL on that option.

          Option 2: I bought a license for SocketTools awhile ago, but just as I needed to be getting more into the tech details, my life has been moving me in other directions. I just can't put in the time to learn how to make the connections, even though this toolbox looks more than robust enough to get the job done.

          Option 3: For $40US, I have downloaded, configured, and tested a ready-made book collection manager program, and have found it to have more capability than I could ever dream of creating on my own.

          My biggest constraint is time - I have already fallen behind on the main tasks I have to accomplish because I thought I could quickly update my old code. After spending 5 days in a constant state of digging deeper and deeper and making no progress, I have called it quits. I'm leaving the rabbit-hole.

          This leaves me unsatisfied as a programmer, because I would have liked to solve this particular problem, but it liberates me to finish the task of having a database of all the books in the family libraries.

          Such is the terrible trade-off of a hobbyist programmer in a not-so-hobbyist world. Sigh...

          And for the sake of any skeptics, I'll post the code from 2010, just so you can see the state of experimentation that I never got past... Ummmh, be warned: it is ugly!
          You'll need to comment out my jmLogFile,INC file and any calls to the LogEntry function, but that's really no impact.

          So, I'm off and running again. This week I'll be scanning 3,000 books and keeping family folks happy, rather than coding. Fooey!
          It's like I'm moving into a world where the most technical thinking is the crossword puzzle!

          But don't you worry, I fully expect to come back to PB and the forums someday... To riff on an old saw: "I'll be back --- you'll be sorry!"

          Best regards to all,
          -John

          Code:
          [FONT=Courier New]'BookInfo.bas    by jhm
          'Book project - scan the barcode or accept keyed ISBN(s); get related info from the web
          '------------------------------------------------------------------------------
          '2 options:
          '- S&R mode: "Scan and Retrieve"    - immediately after the scan, verify with retrieved data
          '- C&R mode: "Collect and Retrieve" - collect the scans, and later retrieve the data as a batch
          '              Accepts a series of scans, a keyed-in entry or a list, or a filespec (for a listfile)
          '-------------------
          'First step: demonstrate S&R
          '-------------------
          'For S&R, set the IBS-800 to NON-PORTABLE mode. RS232 settings must be: ... (ADD THESE!)
          'This app:
          '- listens to COMx
          '- accepts a single ISBN
          '- processes the entry:
          '   - creates the appropriate query to ISBNdb.com (single)
          '      - uses my account key
          '      - provides the ISBN
          '      - specifies the data desired
          '   - submits the query
          '   - waits for and accepts the data returned (formatted as HTML)
          '   - CHECKS the returned HTML data for errors, proper format/info
          '   - parses the HTML, and
          '   - displays and
          '   - creates/stores the record for the desired database (.csv, .xls, .txt, ???)
          '
          'here is a typical result:
          '  <?xml version="1.0" encoding="UTF-8"?>
          '<ISBNdb server_time="2005-02-25T23:03:41">
          ' <BookList total_results="1" page_size="10" page_number="1" shown_results="1">
          '  <BookData book_id="somebook" isbn="0123456789">
          '   <Title>Interesting Book</Title>
          '   <TitleLong>Interesting Book: Read it or else..</TitleLong>
          '   <AuthorsText>John Doe</AuthorsText>
          '   <PublisherText>Acme Publishing</PublisherText>
          '  </BookData>
          ' </BookList>
          '</ISBNdb>
          '------------------------------------------------------------------------------
          '------------------------------------------------------------------------------
          
          '------------------------------------------------------------------------------
          '  jhm mods to PBWin's Serial Communications Example
          '------------------------------------------------------------------------------
          #Compile Exe "c:\tools\BookInfo.exe"
          #Dim All
          %USEMACROS = 1
          #Include "Win32API.inc"
          
          'MUST use the JR Include files:
          #Include "httprequest.inc"
          #Include "ole2utils.inc"
          
          'Now, for my includes:
          #Include Once "jmLogFile.inc"
          
          $ComPort            = "COM1"                    'technically, we should find the right one, or allow user to select...
          $AppTitle           = "Book Info"
          $IdStr              = "2BWL9B92"                'I'd like to obfuscate this...  access_key=
          
          %IDD_MAIN           = 100
          %IDC_LISTBOX1       = 101
          %IDC_EDIT1          = 102
          %IDC_SEND           = 103
          %IDC_SENDFILE       = 104
          %IDC_RECEIVEFILE    = 105
          %IDC_QUIT           = 106
          %IDC_ECHO           = 107
          %IDC_IMMED_RETRVL   = 108
          %IDC_RESULTS        = 109
          %IDC_ChangeCommPort = 110
          %IDC_TestInetConnect = 111
          %lblCOM_INDICATOR    = 201
          %lblRESULTS_LOG      = 202
          
          %POSITIVE      = 1001
          %NEGATIVE      = 1002
          
          Global gCommBuf         As Long     ' file number of comm device
          Global gOutBuf          As Long     ' file number of output file
          Global gFlagUpdating    As Long     ' flag to avoid conflicts when updating
          Global gFlagCloseThread As Long     ' flag to tell thread to shut down
          Global gLogFile As String           ' logfile for jhm's own purposes...
          Global gAky As String               ' my ISBNdb access key, encoded via sep utility and copied here
          'global gCommPortSelection as long  ' the port we'll be using
          Global gDirection       As Long     ' when changing Ports, says whether we're incrementing or decrementing
          
          Macro mCOM(n) = "COM" & Trim$(Str$(n))
          
          
          Sub AddLine (ByVal hWnd As Dword, ByVal nID As Long, SendText As Asciiz)
          'add a line to the specified ListBox
          
             Local ListCount As Long
          
             ' find the current listbox count
             Control Send hWnd, nID, %LB_GETCOUNT, 0, 0 To ListCount
          
             ' update the listbox
             Control Send hWnd, nID, %LB_ADDSTRING, 0, VarPtr(SendText)
          
             ' scroll the new item into view
             Control Send hWnd, nID, %LB_SETCURSEL, ListCount, 0
          End Sub
          
          Function StartComms (ByVal CommPort As Long) As Long
             Local cp, dummy As String
          
          ' When opening ports above COM9, Windows requires the port name to be specified using the following syntax:
          'COMM OPEN "\\.\COM15" AS #hComm
             If CommPort < 1 Then Exit Function
             If CommPort <= 9 Then
                cp = mCOM(CommPort)
             Else
                cp = "\\.\" & mCOM(CommPort)
             End If
             'Comm Open $COMPORT As #gCommBuf       '$COMPORT should not be a constant, but a user selection   *******
          ''   Comm Open CommPort As #gCommBuf       '$COMPORT should not be a constant, but a user selection   *******
          '   Comm Open mCOM(CommPort) As #gCommBuf       '$COMPORT should not be a constant, but a user selection   *******
             Comm Open cp As #gCommBuf       '$COMPORT should not be a constant, but a user selection   *******
             If ErrClear Then Exit Function       ' Exit if port cannot be opened
          
          
          'how to test that there's really a device ready to work on the other side of the port?
          
          
             Comm Set #gCommBuf, Baud     = 9600     ' 9600 baud
             Comm Set #gCommBuf, Byte     = 8        ' 8 bits
             Comm Set #gCommBuf, Parity   = %False   ' No parity
             Comm Set #gCommBuf, Stop     = 0        ' 1 stop bit
             Comm Set #gCommBuf, TxBuffer = 4096     ' 4k transmit buffer
             Comm Set #gCommBuf, RxBuffer = 4096     ' 4k receive buffer
          
             ' Issue a CR/LF and flush the receive buffer
             Comm Print #gCommBuf, $Nul
             Sleep 2000
             If Comm(#gCommBuf, RxQue) Then
                Comm Recv #gCommBuf, Comm(#gCommBuf, RxQue), dummy
             End If
             Function = %TRUE
          End Function
          
          Sub EndComms ()
             Local dummy As String
          
             ' Flush the RX buffer & close the port
             Sleep 1000
             If Comm(#gCommBuf, RxQue) Then
                Comm Recv #gCommBuf, Comm(#gCommBuf, RxQue), dummy
             End If
             Comm Close #gCommBuf
          End Sub
          
          Function ReceiveData (ByVal hWnd As Long) As Long
             'in this case, our incoming param is the handle of the parent dialog...
             '...which enables us to write directly to its controls
          
             Local sBuffer, sBigBuffer, dummy As String
             Local ncBytesInBuffer As Long
          
             Local i, Result As Long, ThisLine, DataRec As String  'jhm additions
          
             While IsFalse gFlagCloseThread
          
                ' Check the RX buffer
                ncBytesInBuffer = Comm(#gCommBuf, RxQue)
          
                ' Abort this iteration if sending
                If IsFalse ncBytesInBuffer Or gFlagUpdating Then
                   Sleep 100
                   Iterate Loop
                End If
          
                ' Read incoming characters.
                Comm Recv #gCommBuf, ncBytesInBuffer, sBuffer
                sBigBuffer = sBigBuffer & sBuffer
          
                ' If Receive mode is on, write raw data to the file
                If gOutBuf Then Print #gOutBuf, sBuffer;
          
                ' Strip out LF characters                      'jhm: Why? LB is line-oriented; this prevents sloppy display ???
                Replace $Lf With "" In sBigBuffer
          
                ' Process only complete lines of text terminated by carriage returns
                While InStr(sBigBuffer, $Cr)
                   ' Display the data
                   'AddLine hWnd, %IDC_LISTBOX1, "==> " + Extract$(sBigBuffer, $Cr)
                   ThisLine = Extract$(sBigBuffer, $Cr)
                   AddLine hWnd, %IDC_LISTBOX1, "==> " & ThisLine
          
                   ' Remove the "displayed" line from the buffer
                   sBigBuffer = StrDelete$(sBigBuffer, 1, Len(Extract$(sBigBuffer, $Cr)) + 1)
                Wend
          
                If Len(ThisLine) < 10 Then Iterate  'let's ignore spurious RS232 signals, like on startup...
                dummy = ClearGetAndShow(hWnd, ThisLine)                                             'ZCZC  RESTRUCTURE THIS!!!!
          
             Wend
             Function = %TRUE
          End Function
          
          
          Function ClearGetAndShow(ByVal hWnd As Long, ByVal Txt As String) As String
          
             Local DataRec As String, Result As Long
          
             'HERE's where to go out and check!!!     change from ThisLine to a better name!
             ' Check the IMMED_RETRVL mode state                                  ' why not use: CONTROL GET CHECK ???
             Control Send hWnd, %IDC_IMMED_RETRVL, %BM_GETCHECK, 0, 0 To Result
             If Result = %BST_CHECKED Then   ' go get the info and display it
                Control Set Text hWnd, %IDC_RESULTS, ""
          
          '      If Len(ThisLine) < 10 Then Iterate  'let's ignore spurious RS232 signals, like on startup...
          
                DataRec = QueryAndRetrieve(Txt)
          'ZCZC: need to parse into a more human-recognizable and readable format... need a tag-remover procedure
          
                'during testing, capture return values to a file for comparisions...
                Replace $Lf With $CrLf In DataRec
                'Call LogEntry (String$(25, "-") & $CrLf & Chr$(34) & DataRec & Chr$(34) & $CrLf & $CrLf, "", gLogFile)  'write logfile entry
          '      gLogFile = EXE.Path$ & ThisLine & ".html"
          '      Call LogEntry (DataRec, "", gLogFile)  'write logfile
          
                Replace $Lf With $CrLf In DataRec   'odd that this works - doesn't it create CRCRLF?
                Control Set Text hWnd, %IDC_RESULTS, Txt & $CrLf & DataRec
             End If
             Function = DataRec
          End Function
          
          
          CallBack Function TestInetConnect_Callback () As Long
             Local TestISBN, dummy As String
          
             Control Get Text CbHndl, %IDC_EDIT1 To TestISBN
             'we could display a message box... OR:
             If TestISBN = "" Then
                Control Get Text CbHndl, %IDC_RESULTS To TestISBN    'see if user put anything into the other control
                If TestISBN = "" Or Verify(TestISBN, "0123456789") > 0 Then
                   TestISBN = "1575213966"      'SAMS XML in 21 Days
                End If
             End If
             dummy = ClearGetAndShow(CbHndl, TestISBN)
          End Function
          
          
          CallBack Function Dialog_Callback () As Long
             If CbMsg = %WM_InitDialog Then
                ' Set focus to the edit control
                Control Set Focus CbHndl, %IDC_EDIT1
          
                ' Set the SELECTION range to highlight the initial entry
                Control Send CbHndl, %IDC_EDIT1, %EM_SETSEL, 0, -1
          
                ' Return 0 to stop the dialog box engine setting focus
                Function = %FALSE
             End If
          End Function
          
          CallBack Function Send_Callback () As Long
             Local SendText As Asciiz * 1024
             Local Result As Long
             Local hListBox As Dword
          
             ' Obtain the text to send from the edit control
             Control Get Text CbHndl, %IDC_EDIT1 To SendText
          
             ' Set the update flag
             gFlagUpdating = %TRUE
          
             ' Send the line to the comm port
             Comm Print #gCommBuf, SendText
          
             ' Check the Echo mode state
             Control Send CbHndl, %IDC_ECHO, %BM_GETCHECK, 0, 0 To Result
             If Result <> %BST_CHECKED Then
                ' Add the echo to the listbox
                AddLine CbHndl, %IDC_LISTBOX1, "<== " & SendText
             End If
          
             ' Set the SELECTION range for the edit control so the next keypress "clears" the control
             Control Send CbHndl, %IDC_EDIT1, %EM_SETSEL, 0, -1
          
             ' Restore the keyboard focus to the edit control
             Control Set Focus CbHndl, %IDC_EDIT1
          
             ' Release the update flag
             gFlagUpdating = %FALSE
          
             Function = %TRUE
          End Function
          
          CallBack Function SendFile_Callback() As Long                                 ' need to see what this can do!!
             Local SendFileName As String
             Local nReadFile As Long
             Local FileLen As Long
             Local Chunk As Long
             Local i As Long
             Local sBuffer As String
          
             SendFileName = InputBox$("Name of disk file to transmit? ", $AppTitle, "")
             If IsFalse Len(SendFileName) Or IsFalse Len(Dir$(SendFileName)) Then
                Exit Function
             End If
          
             AddLine CbHndl, %IDC_LISTBOX1, "Wait... Sending " & SendFileName
             Dialog DoEvents
          
             ' send the file
             nReadFile = FreeFile
             Open SendFileName For Binary As #nReadFile  ' Open as binary
             FileLen = Lof(nReadFile)                    ' File length
             Chunk   = Comm(#gCommBuf, TxBuffer) \ 2        ' 1/2 * TXBUFFER
          
             For i = 1 To FileLen \ Chunk
                Get$ #nReadFile, Chunk, sBuffer           ' Read a chunk
                Comm Send #gCommBuf, sBuffer                 ' and send it
                Sleep 0
             Next i
          
             If FileLen Mod Chunk <> 0 Then              ' More to send?
                Get$ #nReadFile, FileLen Mod Chunk, sBuffer
                Comm Send #gCommBuf, sBuffer
             End If
          
             Close #nReadFile
          
             AddLine CbHndl, %IDC_LISTBOX1, "Transmission complete!"
          End Function
          
          CallBack Function ReceiveFile_Callback () As Long
          'seems to me: all this really does is manage the file; RECEIVE is already being done in the separate "listen-thread"
          
             Local sReceiveFileName As String
             Local sBuffer As String
          
             ' First check if file is already open
             If gOutBuf Then
                Close #gOutBuf                        'close the file
                AddLine CbHndl, %IDC_LISTBOX1, "Finished writing file!"
          
                ' Update the button label
                sBuffer = "&Receive File"
                Control Send CbHndl, %IDC_RECEIVEFILE, %WM_SETTEXT, 0, StrPtr(sBuffer)
          
                gOutBuf = 0
                Exit Function
             End If
          
             ' Create a new file
             sReceiveFileName = InputBox$("Output file name?", $AppTitle, "")
             If IsFalse Len(sReceiveFileName) Then Exit Function
          
             gOutBuf = FreeFile
          
             Open sReceiveFileName For Append As #gOutBuf
             If ErrClear Then
                ' Error opening the file
                gOutBuf = 0
             Else
                ' Update the dialog
                AddLine CbHndl, %IDC_LISTBOX1, "Receiving data stream to " & sReceiveFileName
                sBuffer = "Stop &Receive"
                Control Send CbHndl, %IDC_RECEIVEFILE, %WM_SETTEXT, 0, StrPtr(sBuffer)
             End If
          End Function
          
          CallBack Function Quit_Callback () As Long
             ' Kill the dialog and let PBMAIN() continue
             Dialog End CbHndl, 0
          End Function
          
          '------------------------------------------------------------------------------
          ' find all COM ports
          ' let user select which COM to use
          ' after selection, close what was open previously and open the new
          '------------------------------------------------------------------------------
          CallBack Function ChangeCommPort_Callback () As Long
             ' let user change to a different VALID port...
          
             'gCommPortSelection = 'should we just be using the existing Global: gCommBuf
             If gDirection = %POSITIVE Then           ' for q&d testing, just cycle up and down from 1 to 10....
                gCommBuf = gCommBuf + 1
                If gCommBuf > 9 Then
                   gDirection = %NEGATIVE
                End If
             Else
                gCommBuf = gCommBuf - 1
                If gCommBuf <= 1 Then
                   gDirection = %POSITIVE
                End If
             End If
          
             'reset the labels:
             Control Set Text CbHndl, %lblCOM_INDICATOR, "Transmission &log for " & mCOM(gCommBuf)
             Control Set Text CbHndl, %lblRESULTS_LOG, "Results log for " & mCOM(gCommBuf)
          
          
          
             ' Return 0 to stop the dialog box engine setting focus
             Function = %FALSE
          End Function
          
          Function Unmx(ByVal ctxt As String) As String    'decrypt an encrypted literal ("un-mix")
             Function = ctxt 'until such time as we have unmix code for on-the-fly use...
             'function = ptxt
          End Function
          
          '------------------------------------------------------------------------------
          ' moved here from devtests in: "GetHTTP from JR.bas"
          '------------------------------------------------------------------------------
          Function QueryAndRetrieve(ByVal ISBN As String) As String
          'creates an HTTP connection, a query, submits the query, and retrieves the response
             Local pWHttp As IWinHttpRequest
             Local strQuery, strResponseHeaders, strResponseText, strResponseBody, strResponseStream As String
             Local iSucceeded As Integer
          
             ' Creates an instance of the HTTP service
             pWHttp = NewCom "WinHttp.WinHttpRequest.5.1"
             If IsNothing(pWHttp) Then Exit Function
          
             Try
                ' Opens an HTTP connection to an HTTP resource
                strQuery = "http://isbndb.com/api/books.xml?access_key=" & Unmx(gAky)& "&index1=isbn&value1=" & ISBN
                pWHttp.Open UCode$("GET"), UCode$(strQuery)
                ' Sends an HTTP request to the HTTP server
                pWHttp.Send
                ' Wait for response with a timeout of 5 seconds
                iSucceeded = pWHttp.WaitForResponse(5)                         'how to tell if error?   iSucceeded value...???
          'msgbox str$(iSucceeded) ,, "iSucceeded"  'on a failure, this doesn't display...
                ' Get the response headers
          '      strResponseHeaders = pWHttp.GetAllResponseHeaders
          '      MsgBox ACode$(strResponseHeaders)
          
                ' Get the other headers
                strResponseText = pWHttp.ResponseText       ' THIS returns what I want!!!
                'MsgBox ACode$(strResponseText)
                Function = ACode$(strResponseText)
                'strResponseBody = pWHttp.ResponseBody       'haven't seen this return anything yet
                'MsgBox VARIANT$(strResponseBody)
                'strResponseStream = pWHttp.ResponseStream     'haven't seen this return anything yet
                'MsgBox VARIANT$(strResponseStream)
             Catch
                OleShowErrorInfo ObjResult    'what does this look like?
             End Try
          End Function
          '------------------------------------------------------------------------------
          
          '------------------------------------------------------------------------------
          '------------------------------------------------------------------------------
          '------------------------------------------------------------------------------
          Function PBMain () As Long
          
             #Register None
          
             Local hDlg        As Dword
             Local Result      As Long
             Local hThread     As Long
             Dim Txt(1 To 1) As String
          
             Local i As Long, StartMsg, ISBN(), DataRec As String
             Dim ISBN(1 To 100)          ' I was thinking about C&R mode...
          
             gAky = "2BWL9B92"   ' until such time as we have an encrypted string from external utility (ref CHKSEC)...
          
             'establish logfile's filename (and make initial entry?)
             'gLogFile = exe.Path$ & exe.Name$ & ".log"    'this conflict with the compiler's logfile name...
          '   gLogFile = exe.Path$ & "Retrieved ISBN Data.log"
          '   Call LogEntry ($CrLf & string$(25, "=") & $CrLf & date$ & " " & TIME$ & $CrLf & String$(25, "=") & $CrLf , "", gLogFile)  'write logfile entry
          
             'Set the default COM port...
          '   gCommPortSelection = 1     'why not just directly set:  gCommBuf               ?????????????????
             gCommBuf = 1
          
             ' Initialize the port ready for the session
          '   If IsFalse StartComms(gCommPortSelection) Then
             If IsFalse StartComms(gCommBuf) Then
                MsgBox "Failed to start communications!",, $AppTitle
                Exit Function
             End If
          
             'How to tell if there's nothing **connected to** the port?  no modem, no data collector...
             '
          
             Txt(1) = "This listbox shows the transmission I/O stream..."
          
             'Display this message when user checks IMMED_RETRVL
             StartMsg = "Turn on the IBS-800, select NON-PORTABLE, and enter Y."
          
             Dialog New 0, $AppTitle,,, 640, 203, %WS_Popup Or %WS_Visible Or %WS_ClipChildren Or %WS_Caption Or %WS_SysMenu Or %WS_MinimizeBox, 0 To hDlg
          
          '   Control Add Label,    hDlg, -1, "Transmission &log for " & $ComPort, 9, 5, 100, 10, 0
             Control Add Label,    hDlg, %lblCOM_INDICATOR, "Transmission &log for " & mCOM(gCommBuf), 9, 5, 100, 10, 0
          
             Control Add ListBox,  hDlg, %IDC_LISTBOX1, Txt(), 9, 15, 313, 133, _
                                   %WS_Border Or %LBS_WantKeyboardInput _
                                   Or %LBS_DisableNoScroll Or %WS_VScroll Or %WS_Group _
                                   Or %WS_TabStop Or %LBS_NoIntegralHeight
          
             Control Add Label,    hDlg, -1, "Te&xt to send", 9, 151, 100, 10, 0
          
             Control Add TextBox,  hDlg, %IDC_EDIT1, "ATZ", 9, 161, 257, 12, _
                                   %ES_AutoHScroll Or %ES_NoHideSel Or %WS_Border _
                                   Or %WS_Group Or %WS_TabStop
          
             Control Add Button,   hDlg, %IDC_SEND, "Send &Text", 273, 160, 50, 14, _
                                   %WS_Group Or %WS_TabStop Or %BS_DefPushButton _
                                   Call Send_Callback
          
             Control Add Button,   hDlg, %IDC_SENDFILE, "&Send File", 9, 182, 50, 14, _
                                   %WS_Group Or %WS_TabStop Call SendFile_Callback
          
             Control Add Button,   hDlg, %IDC_RECEIVEFILE, "&Receive File", _
                                   62, 182, 50, 14, %WS_Group Or %WS_TabStop _
                                   Call ReceiveFile_Callback
          
             Control Add Button,   hDlg, %IDC_QUIT, "&Quit", 273, 182, 50, 14, _
                                   %WS_Group Or %WS_TabStop Call Quit_Callback
          
             Control Add CheckBox, hDlg, %IDC_ECHO, "Disable Local &Echo", _
                                   241, 5, 80, 10, _
                                   %WS_Group Or %WS_TabStop Or %BS_AutoCheckbox _
                                   Or %BS_LeftText Or %BS_Right
          'jhm additions:
          '   Control Add Label,    hDlg, -1, "Results log for " & $ComPort, 334, 5, 100, 10, 0
             Control Add Label,    hDlg, %lblRESULTS_LOG, "Results log for " & mCOM(gCommBuf), 334, 5, 100, 10, 0
          
             Control Add TextBox,  hDlg, %IDC_RESULTS, StartMsg, 334, 15, 292, 133, _
                                   %ES_AutoVScroll Or %WS_VScroll Or %ES_MultiLine Or %WS_TabStop
          
             Control Add CheckBox, hDlg, %IDC_IMMED_RETRVL, "Perform Immediate Retrieval", _
                                   505, 5, 120, 10, _
                                   %WS_Group Or %WS_TabStop Or %BS_AutoCheckbox _
                                   Or %BS_LeftText Or %BS_Right
          
             Control Set Check hDlg, %IDC_IMMED_RETRVL, 1
          
             Control Add Button,   hDlg, %IDC_TestInetConnect, "TestInetConnect", 420, 182, 65, 14, _
                                   %WS_Group Or %WS_TabStop Call TestInetConnect_Callback
          
             Control Add Button,   hDlg, %IDC_ChangeCommPort, "Change Port", 500, 182, 50, 14, _
                                   %WS_Group Or %WS_TabStop Call ChangeCommPort_Callback
          
             ' Erase our arrays to free memory no longer required
             ReDim Txt()
          
             'set ChangePort direction
             gDirection = %POSITIVE
          
             ' Create a "listen" thread to monitor input from the modem
             Thread Create ReceiveData(hDlg) To hThread
             ' this kicks off a thread that listens to the COMx port until the Dlg is closed (gFlagCloseThread gets set to TRUE)
          
             ' Start the dialog box & run until DIALOG END is executed.
             Dialog Show Modal hDlg, Call Dialog_Callback To Result
          
             ' close down our "listen" thread
             gFlagCloseThread = %TRUE
             Do
                Thread Close hThread To Result
                Sleep 0
             Loop Until IsTrue Result
          
             ' Flush & close the comm port and close the Receive file if open
             EndComms
          
             If gOutBuf Then Close #gOutBuf
          
             'jhm: do we need to worry about closing the logfile? or does it do that itself?
          
          End Function
          '------------------------------------------------------------------------------
          '------------------------------------------------------------------------------
          '------------------------------------------------------------------------------[/FONT]

          Comment


          • #6
            John,

            the code below should work for the ISBNdb API v2
            they no longer offer the info for free, you will need to register to get a new Authorization key. they are now 38 characters long

            Added:
            you call it, GetJSONfromWEB ("https://api2.isbndb.com/book/1575213966", $sYourKey)


            '
            Code:
            '-----------------------------------------------
            ' GetJSONfromWEB
            ' Get JSON from a WEB URL of ISBNdb
            '
            #INCLUDE ONCE "httprequest.inc"
            #INCLUDE ONCE "ole2utils.inc"
            '-----------------------------------------------
            FUNCTION GetJSONfromWEB (sFullURL AS STRING, sYourKey AS STRING) AS STRING
               LOCAL pWHttp AS IWinHttpRequest
               LOCAL buffer AS STRING
               LOCAL iSucceeded AS INTEGER
            
                sFullURL = TRIM$(sFullURL)      ' just in case remove leading and trailling spaces
               ' Creates an instance of the HTTP service
               pWHttp = NEWCOM "WinHttp.WinHttpRequest.5.1"
            
               IF ISNOTHING(pWHttp) THEN EXIT FUNCTION
               TRY
                  ' Opens an HTTP connection to an HTTP resource
                  pWHttp.Open "GET", sFullURL
                  pWHttp.setRequestHeader "Content-Type", "application/json"   ' this is needed for API V2
                  pWHttp.setRequestHeader "Authorization", sYourKey            ' this also the new KEy is 38 characters long
                  ' Sends an HTTP request to the HTTP server
                  pWHttp.Send
                  ' Wait for response with a timeout of 5 seconds
                  iSucceeded = pWHttp.WaitForResponse(5)
                     buffer = pWHttp.Responsetext
               CATCH
                  OleShowErrorInfo OBJRESULT
               END TRY
            FUNCTION = buffer
            END FUNCTION
            '-----------------------------------------------
            ' GetJSONfromWEB                            End
            '-----------------------------------------------
            '
            Sample Returned data:

            {"book":{"publisher":"Sams","language":"en_US","overview":"In just 21 days, you'll have all the skills you need to create XML documents and applications. With this complete tutorial, you'll master the basics and then move on to more advanced features and concepts. Learn how XML and HTML are used together. Give structure to the data and content on your Web site. Master all of the features of XML including XML Objects. Learn how to effectively use the latest XML editors and parsers. Get expert tips from a leading authority on implementing XML in the corporate environment.","image":"https://images.isbndb.com/covers/39/65/9781575213965.jpg","title_long":"Sams Teach Yourself XML in 21 Days","edition":"1","dimensions":"Height: 9.25 Inches, Length: 7.5 Inches, Weight: 1015 Grams, Width: 1.5 Inches","pages":580,"date_published":"1999-04-13T00:00:01Z","authors":["North, Simon"],"title":"Sams Teach Yourself XML in 21 Days","isbn13":"9781575213965","msrp":"29.99","binding":"Paperback","isbn":"1575213966"}}
            Last edited by Rod Macia; Today, 02:27 AM. Reason: Added more info

            Comment


            • #7
              if you don't want to pay for an ISBNdb plan you can use openlibrary.org
              you essentially query by using https://openlibrary.org/isbn/1575213966.json

              And some Test code.
              '
              Code:
              #COMPILE EXE
              #COMPILER PBWIN 10
              #DIM ALL
              
              %Unicode = 1
              #INCLUDE "win32api.inc"
              
              ENUM a SINGULAR
               IDC_ListView = 501
               IDC_GRAPHIC1
               IDC_TEXTBOX1
               LBL_TEXTBOX1
               LBL_TEXTBOX2
              END ENUM
              
              FUNCTION PBMAIN () AS LONG
              LOCAL hDlg AS DWORD
              
              
              
                 DIALOG DEFAULT FONT "Tahoma", 12, 1
                 DIALOG NEW PIXELS, 0, "ISBN Test",100,100,1700,800,%WS_OVERLAPPEDWINDOW TO hDlg
                 CONTROL ADD LABEL, hDlg, %LBL_TEXTBOX1, "ISBN10 or ISBN13:", 10, 5, 140, 28
                 CONTROL ADD TEXTBOX, hDlg, %IDC_TEXTBOX1, "", 155, 5, 164, 28, %WS_CHILD _
                      OR %WS_VISIBLE OR %WS_TABSTOP OR %ES_LEFT OR %ES_MULTILINE OR _
                      %ES_AUTOHSCROLL OR %ES_AUTOVSCROLL OR %ES_NOHIDESEL OR _
                      %ES_WANTRETURN, %WS_EX_CLIENTEDGE OR %WS_EX_LEFT OR _
                      %WS_EX_LTRREADING OR %WS_EX_RIGHTSCROLLBAR
                 CONTROL ADD LABEL, hDlg, %LBL_TEXTBOX2, "", 324, 5, 550, 28
                 CONTROL ADD GRAPHIC, hDlg, %IDC_GRAPHIC1, "", 1400, 40, 280, 385, %SS_SUNKEN
                 CONTROL ADD LISTVIEW, hDlg, %IDC_ListView, "", 10,40,1380,750
                 LISTVIEW INSERT COLUMN hDlg, %IDC_ListView, 1, "Rec", 50,0                     ' Columns for basic 1 level
                 LISTVIEW INSERT COLUMN hDlg, %IDC_ListView, 2, "Name", 100,0
                 LISTVIEW INSERT COLUMN hDlg, %IDC_ListView, 3, "Value", 450,0
                 LISTVIEW SET STYLEXX hDlg, %IDC_ListView, %LVS_EX_GRIDLINES OR %LVS_EX_FULLROWSELECT
                 DIALOG SHOW MODAL hDlg CALL DlgProc
              
              END FUNCTION
              
              FUNCTION UpdateListView(hDlg AS DWORD, sData AS STRING) AS LONG
              LOCAL lCount1,  lNumObj, lTemp, lTemp2, lRec, hLV, idv, ColCount, lCoverFlag AS LONG
              LOCAL sTemp AS STRING
              LOCAL stImageData AS STRING
              LOCAL hBitmap AS DWORD
              LOCAL lgPixelW, lgPixelH AS LONG
              DIM aObjects() AS STRING
              
              IF LEFT$(sData,1) <> "{" THEN sData = "{Not Found}"
              lNumObj = JSONParser (sData, aObjects(),0) ' Feed it the JSON File or "Object String" and an empty un-DIMed array
                                                         ' "Object String" - Whatever is between {} Inclusivelly or file containing multiple Objects separated be ","
                                                         ' lResult = -1 error, positive value = number of Rows
              '? format$(lNumObj)
              sTemp = sData & $CRLF & $CRLF
              IF lNumObj > 0 THEN
                    lTemp2 = 3
                    lRec = -1
                    FOR lCount1 = 1 TO lNumObj                                                  'Populate a List view with the JSON Data
                     LISTVIEW INSERT ITEM hDlg, %IDC_ListView, lCount1, 0, ""
                     sTemp + = aObjects(lCount1) & $CRLF      'debug rem out when done
                       lTemp = VAL(PARSE$(aObjects(lCount1), $ESC ,2)) + 3
                         IF lTemp > lTemp2 THEN                                                 'extra level detected
                           lTemp2 = lTemp
                           LISTVIEW INSERT COLUMN hDlg, %IDC_ListView, lTemp2 -1, "", 100,0     'insert a column
                         END IF
                      IF lRec <> VAL(PARSE$(aObjects(lCount1), $ESC ,1)) THEN                                   'Rec Column
                        LISTVIEW SET TEXT hDlg, %IDC_ListView, lCount1, 1, PARSE$(aObjects(lCount1), $ESC ,1)   'only first line of record should have it.
                        lRec = VAL(PARSE$(aObjects(lCount1), $ESC ,1))
                      END IF
                      ColCount = VAL(PARSE$(aObjects(lCount1), $ESC ,2))
                      LISTVIEW SET TEXT hDlg, %IDC_ListView, lCount1, 2+ VAL(PARSE$(aObjects(lCount1), $ESC ,2)), PARSE$(aObjects(lCount1), $ESC ,4)     'Name in proper level column
                      IF PARSE$(aObjects(lCount1), $ESC ,3) ="9"  THEN                                                            'its a number
                        LISTVIEW SET TEXT hDlg, %IDC_ListView, lCount1, lTemp2, PARSE$(aObjects(lCount1), $ESC ,5)                'Value in proper level column no $DQ
                      ELSEIF PARSE$(aObjects(lCount1), $ESC ,5) <>"" THEN
                        LISTVIEW SET TEXT hDlg, %IDC_ListView, lCount1, lTemp2, $DQ + PARSE$(aObjects(lCount1), $ESC ,5)  + $DQ   'Value in proper level column  with $DQ if not empty
                      END IF
                      IF VAL(PARSE$(aObjects(lCount1), $ESC ,2)) = 0 THEN  lCoverFlag = 0
                      IF aObjects(lCount1) = "0" & $ESC & "0" & $ESC & "A" & $ESC & "covers" THEN    ' Get Covers
                          'Type: O = Object, A = Array, B = Bolean, N = Null, 9 = Number, S = String
                          '? "object 0, Level 0, Type A (array), Name = covers"
                          lCoverFlag = 1
                      END IF
                      IF VAL(PARSE$(aObjects(lCount1), $ESC ,2)) = 1 AND lCoverFlag = 1 THEN
                           stImageData = GetImagefromWEB ("https://covers.openlibrary.org/b/id/"& PARSE$(aObjects(lCount1), $ESC ,5) & "-M.jpg")
                           lgPixelW = 0 : lgPixelH = 0  'use default size
                           hBitmap = ImageToBitmap(stImageData, lgPixelW, lgPixelH)
                             IF hBitmap = 0 THEN
                                 MSGBOX "Function failed"
                               ELSE
                                 GRAPHIC ATTACH hDlg, %IDC_GRAPHIC1
                                 GRAPHIC COPY hBitmap, 0
                             END IF
                      END IF
                    NEXT lCount1
                    CLIPBOARD SET TEXT sTemp
                       LISTVIEW GET HEADERID hDlg, %IDC_ListView TO hLV, idv                   'Now that Listview is populated
                       HEADER GET COUNT hLV, idv TO ColCount
                       FOR lCount1 = 1 TO ColCount
                         LISTVIEW FIT CONTENT hDlg, %IDC_ListView, lCount1                     'Make the Columns Fit Content
                       NEXT lcount1
              ELSE
                MSGBOX "Error = " + FORMAT$(lNumObj) + $CRLF + $CRLF + "0 = no objects, -1 = No Data, -2 = contains $ESC", %MB_ICONERROR, "Error in Data"
              END IF
              END FUNCTION
              
              CALLBACK FUNCTION DlgProc() AS LONG
                LOCAL sTemp AS STRING
                LOCAL lRow, lCol, hLV, idv, ColCount AS LONG, lpLvCd AS NMLVCUSTOMDRAW PTR
                LOCAL StringVar, StringVar2, sData AS STRING
                LOCAL lResult AS LONG
                  SELECT CASE CB.MSG
                    CASE %WM_INITDIALOG
              
                    CASE %WM_COMMAND
                          ' Process control notifications
                          SELECT CASE AS LONG CB.CTL
                              CASE %IDC_TEXTBOX1
              
                                       ' Highlight text when it gets focus
                                       IF CB.CTLMSG = %EN_SETFOCUS THEN
                                          CONTROL POST CB.HNDL, %IDC_TEXTBOX1, %EM_SETSEL, 0, -1
                                       END IF
              
                                       IF CB.CTLMSG=%EN_CHANGE THEN
                                            CONTROL SEND CB.HNDL, %IDC_TEXTBOX1, %EM_GETLINECOUNT,0,0 TO lResult
                                       END IF
                              IF lResult>1 THEN
                                  CONTROL GET TEXT CB.HNDL, %IDC_TEXTBOX1 TO StringVar
                                  REPLACE $CRLF WITH "" IN StringVar
                                  IF LEN(StringVar) > 0 THEN
                                      LISTVIEW RESET CB.HNDL, %IDC_ListView
                                      GRAPHIC ATTACH CB.HNDL, %IDC_GRAPHIC1
                                      GRAPHIC CLEAR
                                      '? StringVar + $CRLF &"(" & ISBN_Valid(StringVar)  & ")"
                                      IF  LEN(ISBN_Valid(StringVar)) > 0 THEN
                                        sTemp = "https://openlibrary.org/isbn/" &  ISBN_Valid(StringVar)  & ".json"
                                        CONTROL SET COLOR CB.HNDL, %LBL_TEXTBOX2, %RGB_GREEN, -1
                                        CONTROL SET TEXT CB.HNDL, %LBL_TEXTBOX2, sTemp
                                        sData = GetJSONfromWEB (sTemp)
                                        '? sData
                                        UpdateListView (CB.HNDL,sData)
                                        CONTROL SET TEXT CB.HNDL, %IDC_TEXTBOX1, ""
                                      ELSE
                                        CONTROL SET COLOR CB.HNDL, %LBL_TEXTBOX2, %RGB_RED, -1
                                        CONTROL SET TEXT CB.HNDL, %LBL_TEXTBOX2, " Invalid ISBN " & StringVar
                                      END IF
                                  END IF
                              END IF
                          END SELECT
              
                     CASE %WM_NOTIFY                                                        ' listview text color in cell
                       SELECT CASE CB.NMID
                          CASE %IDC_ListView
                             SELECT CASE CB.NMCODE
                                CASE %NM_CUSTOMDRAW
                                   lpLvCd = CB.LPARAM
                                   SELECT CASE @lplvcd.nmcd.dwDrawStage
                                      CASE %CDDS_PREPAINT, %CDDS_ITEMPREPAINT
                                         FUNCTION = %CDRF_NOTIFYSUBITEMDRAW
                                      CASE %CDDS_ITEMPREPAINT OR %CDDS_SUBITEM
                                         lRow = @lpLvCd.nmcd.dwItemSpec + 1         '1-based result
                                         lCol = @lpLvCd.iSubItem + 1                '1-based result
                                         LISTVIEW GET TEXT CB.HNDL, %IDC_ListView, lRow, lCol TO sTemp
                                         LISTVIEW GET HEADERID CB.HNDL, %IDC_ListView TO hLV, idv
                                         HEADER GET COUNT hLV, idv TO ColCount
                                         IF ((LEN(sTemp) = 1 AND VAL(sTemp)=0) OR (VAL(sTemp) <> 0)) AND lCol = ColCount THEN      ' value col -> magenta for numbers
                                           @lpLvCd.clrText = %MAGENTA
                                         ELSE
                                           IF lCol = ColCount THEN @lpLvCd.clrText = %BLUE ELSE @lpLvCd.clrText = %BLACK           ' blue rest,  other col -> black
                                         END IF
              
                                         FUNCTION = %CDRF_NEWFONT
                                   END SELECT
                             END SELECT
                       END SELECT
                  END SELECT
              END FUNCTION
              
              
              '-----------------------------------------------
              ' ISBN_Valid
              ' Validate an ISBN
              '
              ' Usage     ISBN_Validate (sISBN)
              ' returnes valid ISBN 13 or ISBN 10, or empty if invalid
              ' Info:
              ' ISBN10 - 10 numeric last digit can be 0-9 and X (last digit can be X)
              '          the check digit is evalued based on MOD(11)
              ' ISBN13 - 13 numeric last digit can be 0-9
              '          the check digit is evalued based on MOD(10)
              '-----------------------------------------------
              FUNCTION ISBN_Valid(BYVAL sISBN AS STRING) AS STRING
               LOCAL X AS LONG
               LOCAL Sum AS LONG
               LOCAL sTemp AS STRING
                  sISBN = RETAIN$(UCASE$(sISBN), ANY "0123456789X")
                  IF  (LEN(sISBN)= 10 AND TALLY(LEFT$(sISBN,-1),"X")= 0) THEN    ' If ISBN10 only last can be X
                      sTemp = RIGHT$(sISBN,1)                                  ' get current check digit
                      sISBN = LEFT$(sISBN,9)                                   ' (drops last, ISBN10 check digit)
                      FOR X = 10 TO 2 STEP -1
                        Sum = Sum + X * VAL(MID$(sISBN, 11 - X, 1))          ' compute check digit and compaire below
                      NEXT
                      IF IIF$(((11-(Sum MOD 11)) MOD 11) < 10,DEC$((11-(Sum MOD 11)) MOD 11),"X") = sTemp THEN FUNCTION = sISBN & sTemp
                  END IF
                  IF  (LEN(sISBN)= 13 AND TALLY(sISBN,"X")= 0)  THEN             ' If ISBN13 no X alowed
                      sTemp = RIGHT$(sISBN,1)                                    ' get current check digit
                      sISBN = LEFT$(sISBN,12)                                    ' (drops last, ISBN13 check digit)
                      FOR X = 13 TO 2 STEP -1
                        Sum = Sum + IIF(X MOD 2, 1,3) * VAL(MID$(sISBN, 14 - X, 1)) ' compute check digit and compaire below
                      NEXT
                      IF IIF$((Sum MOD 10) = 0, DEC$((Sum MOD 10)), DEC$(10-(Sum MOD 10))) = sTemp THEN FUNCTION = sISBN & sTemp
                  END IF
              END FUNCTION
              '-----------------------------------------------
              ' ISBN_Valid                                End
              '-----------------------------------------------
              
              
              '-----------------------------------------------
              ' FILE_Load
              ' Load a complete file into a String Var
              '
              ' Usage     FILE_Load (sFileName)
              '-----------------------------------------------
              FUNCTION FILE_Load(BYVAL sFileName AS STRING) AS STRING
                  LOCAL hFile   AS LONG
                  LOCAL sBuffer AS STRING
                  IF ISFILE(sFileName) THEN   ' if file exists proceed
                    hFile = FREEFILE
                    OPEN sFileName FOR BINARY ACCESS READ AS hFile
                    GET$ hFile, LOF(hFile), sBuffer
                    CLOSE hFile
                    FUNCTION = sBuffer
                  END IF
              END FUNCTION
              '-----------------------------------------------
              ' FILE_Load                               End
              '-----------------------------------------------
              
              '-----------------------------------------------
              ' GetJSONfromWEB
              ' Get JSON from a WEB URL of a JSON source
              '
              ' Usage     GetJSONfromWEB (sFullURL)
              #INCLUDE ONCE "httprequest.inc"
              #INCLUDE ONCE "ole2utils.inc"
              '-----------------------------------------------
              FUNCTION GetJSONfromWEB (sFullURL AS STRING) AS STRING
                 LOCAL pWHttp AS IWinHttpRequest
                 LOCAL buffer AS STRING
                 LOCAL iSucceeded AS INTEGER
              
                  sFullURL = TRIM$(sFullURL)      ' just in case remove leading and trailling spaces
                 ' Creates an instance of the HTTP service
                 pWHttp = NEWCOM "WinHttp.WinHttpRequest.5.1"
              
                 IF ISNOTHING(pWHttp) THEN EXIT FUNCTION
                 TRY
                    ' Opens an HTTP connection to an HTTP resource
                    pWHttp.Open "GET", sFullURL
                    ' Sends an HTTP request to the HTTP server
                    pWHttp.Send
                    ' Wait for response with a timeout of 5 seconds
                    iSucceeded = pWHttp.WaitForResponse(5)
                       buffer = pWHttp.Responsetext
                 CATCH
                    OleShowErrorInfo OBJRESULT
                 END TRY
              FUNCTION = buffer
              END FUNCTION
              '-----------------------------------------------
              ' GetJSONfromWEB                            End
              '-----------------------------------------------
              
              '-----------------------------------------------
              ' GetImagefromWEB
              ' Get Image from a WEB URL of a JSON source
              '
              ' Usage     GetJSONfromWEB (sFullURL)
              #INCLUDE ONCE "httprequest.inc"
              #INCLUDE ONCE "ole2utils.inc"
              '-----------------------------------------------
              FUNCTION GetImagefromWEB (sFullURL AS STRING) AS STRING
                 LOCAL pWHttp AS IWinHttpRequest
                 LOCAL vSTream AS VARIANT
                 LOCAL pIStream AS IStream
                 LOCAL Buffer AS STRING * 8192
                 LOCAL strBuffer AS STRING
                 LOCAL cbRead AS DWORD
                 LOCAL iSucceeded AS INTEGER
                 LOCAL wsHeaders, wTemp1 AS WSTRING
                  sFullURL = TRIM$(sFullURL)      ' just in case remove leading and trailling spaces
                 ' Creates an instance of the HTTP service
                 pWHttp = NEWCOM "WinHttp.WinHttpRequest.5.1"
              
                 IF ISNOTHING(pWHttp) THEN EXIT FUNCTION
                 TRY
                    ' Opens an HTTP connection to an HTTP resource
                    pWHttp.Open "GET", sFullURL
                    ' Sends an HTTP request to the HTTP server
                    pWHttp.Send
                    ' Wait for response with a timeout of 5 seconds
                    iSucceeded = pWHttp.WaitForResponse(5)
                       wsHeaders = pWHttp.GetAllResponseHeaders
                    ' Get the response as a stream
                    vStream = pWHttp.ResponseStream                        ' now we get the file and save it
                    IF VARIANTVT(vStream) = %VT_UNKNOWN THEN
                       pIStream = vStream
                       vStream = EMPTY
                       ' Read the stream in chunks
                       DO
                          pIStream.Read VARPTR(buffer), SIZEOF(buffer), cbRead
                          IF cbRead = 0 THEN EXIT DO
                          IF cbRead < SIZEOF(buffer) THEN
                             strBuffer = strBuffer & LEFT$(buffer, cbRead)
                          ELSE
                             strBuffer = strBuffer & buffer
                          END IF
                       LOOP
                       pIStream = NOTHING
                       IF LEN(strBuffer) THEN
                          FUNCTION = strBuffer
                       ELSE
                          MSGBOX "Buffer is empty"
                       END IF
                    END IF
                 CATCH
                    OleShowErrorInfo OBJRESULT
                 END TRY
              END FUNCTION
              '-----------------------------------------------
              ' GetImagefromWEB                            End
              '-----------------------------------------------
              
              
              '-----------------------------------------------
              ' JSONParser
              ' Parse JSON Data into an Array
              ' JSON is composed of Object(s) between {}
              '   Members pair - "name":value
              '   value can be - String, Number, array[], Object{}, True, False, Null
              '
              ' Usage     JSONParser (sData, aJSONArray())
              ' Usage     JSONParser (sData, aJSONArray(), ArrayDimType)
              ' ArrayDimType   0 = 1D,  not 0 = 2D
              ' return Result = 0 no objects, -1 No Data, -2 invalid content sData, positive value = number lines
              '-----------------------------------------------
              FUNCTION JSONParser (sData AS STRING, BYREF aJSONParsed() AS STRING, OPTIONAL BYVAL ArrayDimType AS LONG) AS LONG
              DIM aObjects() AS STRING
              LOCAL lCount1, lCount2, lNumObj, lNumMemb  AS LONG
              
              LOCAL JSONParsed AS ILINKLISTCOLLECTION
              LET JSONParsed = CLASS "LinkListCollection"
              
              IF LEN (sData) < 2 THEN FUNCTION = - 1  : EXIT FUNCTION
              IF TALLY(sData, $ESC) <> 0 THEN FUNCTION = - 2  : EXIT FUNCTION      ' $ESC present in String, function will not work
              
              lNumObj = JSONObjectsEnum (sData, aObjects())    ' Get all the objects in same level
              
              IF lNumObj > 0 THEN
                FOR lCount2 = 1 TO lNumObj
                 sData = aObjects(lCount2)
                 lNumMemb = JSONMembers (sData, aJSONParsed()) ' Get the members, Arrays, and Sub elements also. This is first call so lvl 0
                    FOR lCount1 = 1 TO lNumMemb
                       JSONParsed.add(FORMAT$(lCount2 -1 ) + $ESC + aJSONParsed(lCount1) AS WSTRING)
                    NEXT lCount1
                NEXT lCount2
              
                IF ArrayDimType = 0 THEN                                                  ' 0, Array Dim Type Default Choice
                  REDIM aJSONParsed(1 TO JSONParsed.Count)                                  ' one dimention
                  FOR lCount1 = 1 TO JSONParsed.Count                                       'Transfer our list to a 1D array
                    aJSONParsed(lCount1) = VARIANT$(JSONParsed.item(lCount1))             ' string = 0[esc]0[esc]T[esc]name[esc]value    ' ie: parse$ (string, $ESC, 4)  to get name
                  NEXT lCount1                                                              '          obj   lvl  VarType VarName  Value   ' ie: parse$ (string, $ESC, 5)  to get value
              
                ELSE                                                                      ' not 0,  Array Dim Type
                  REDIM aJSONParsed(1 TO JSONParsed.Count, 1 TO 5)
                  FOR lCount1 = 1 TO JSONParsed.Count                                               'Transfer our list to an 2D array
                   aJSONParsed(lCount1, 1) = PARSE$(VARIANT$(JSONParsed.item(lCount1)), $ESC, 1) 'Object #  0 to #x
                   aJSONParsed(lCount1, 2) = PARSE$(VARIANT$(JSONParsed.item(lCount1)), $ESC, 2) 'Level #   0 to #x
                   aJSONParsed(lCount1, 3) = PARSE$(VARIANT$(JSONParsed.item(lCount1)), $ESC, 3) 'Original Var type S=String, 9=Number, O=Object, A=Array, B=Bolean, N=Null
                   aJSONParsed(lCount1, 4) = PARSE$(VARIANT$(JSONParsed.item(lCount1)), $ESC, 4) 'Name
                   aJSONParsed(lCount1, 5) = PARSE$(VARIANT$(JSONParsed.item(lCount1)), $ESC, 5) 'Value
                  NEXT lCount1
                END IF
              
                  FUNCTION = JSONParsed.Count
              END IF
              END FUNCTION
              
              '-----------------------------------------------
              ' JSONArrays
              ' Enumerate and extract JSON Array into an Array
              '
              ' Usage     JSONArrays (sData, aJSONArray())
              ' Usage     JSONArrays (sData, aJSONArray(), lLevel)
              ' lLevel = used in recurstion
              ' return Result = 0 no objects, -1 No Data, -2 invalid content sData, positive value = number lines
              '-----------------------------------------------
              FUNCTION JSONArrays (sData AS STRING, BYREF aJSONArray() AS STRING, OPTIONAL BYVAL lLevel AS LONG) AS LONG
              LOCAL sOne, sValue, sType AS STRING
              LOCAL lCount1, lCount2, lLeftBrace, lLCount, DQpair, lDQLeft, lDQRight AS LONG
              LOCAL lResult, lArrayIndex AS LONG
              
              LOCAL JSONArray AS ILINKLISTCOLLECTION
              LET JSONArray = CLASS "LinkListCollection"
              
              IF LEN (sData) < 2 THEN FUNCTION = - 1  : EXIT FUNCTION
              IF TALLY(sData, $ESC) <> 0 THEN FUNCTION = - 2  : EXIT FUNCTION      ' $ESC present in String, function will not work
              
              lLCount = 0
              lLeftBrace = 0
              DQpair = 0
              lArrayIndex = 0
              
              FOR lCount1 = 1 TO LEN(sData)
                sOne = MID$(sData, lCount1, 1)
              
                IF sOne = "[" THEN lLCount += 1                     'Keep track of []  Arrays
                IF sOne = "]" THEN lLCount -= 1                     '
                IF sOne = "{" THEN lLeftBrace += 1                  'Keep track of {}  Objects
                IF sOne = "}" THEN lLeftBrace -= 1                  '
                IF lLeftBrace = 0 AND(lLCount = 1 OR lCount1 = LEN(sData)) THEN     'if not inside a {}, and but inside an []
                  IF sOne = $DQ THEN                                                'Keep track of double quote pairs
                    DQpair = 1 - DQpair                                             'if DQpair = 0 and you have a Delimiter its end of string.
                  END IF
              
                  IF DQPair = 1 AND sOne = $DQ THEN lDQLeft = lCount1
                  IF DQPair = 0 AND(sOne = "," OR lCount1 = LEN(sData)) THEN            '"," End of Member / Value
              
                    lDQLeft = lDQRight + 2
                    lDQRight = lCount1
              
                    sValue = TRIM$(MID$(sData, lDQLeft TO lDQRight - 1))
                    IF RIGHT$(sValue,1) = "}" AND LEFT$(sValue,1) <> "{" THEN sValue = TRIM$(MID$(sData, lDQLeft - 1 TO lDQRight-1))
              
                    sType = ""
                    'Type: O = Object, A = Array, B = Bolean, N = Null, 9 = Number, S = String
                    IF LEFT$(sValue, 1) = "{" THEN sType = "O"                                  'Object
                    IF LEFT$(sValue, 1) = "[" THEN sType = "A"                                  'Array
                    IF UCASE$(sValue) = "TRUE" OR UCASE$(sValue) = "False" THEN sType = "B"     'Bolean
                    IF UCASE$(sValue) = "NULL" THEN sType = "N"                                 'Null
                    IF VERIFY(sValue, "0123456789.,+-Ee") = 0 AND ((LEN(sValue) = 1 AND VAL(sValue)=0) OR VAL(sValue) <> 0)  THEN sType = "9"  'Number
                    IF LEFT$(sValue, 1) = $DQ THEN
                      sType = "S"                                                               'String
                      REPLACE "\" + $DQ WITH $DQ IN sValue                                   ' convert the \values to their single value
                      REPLACE "\\" WITH "\" IN sValue                                        ' all these are inside "" strings
                      REPLACE "\/" WITH "/" IN sValue
                      REPLACE "\t" WITH $TAB IN sValue
                      REPLACE "\r" WITH $CR IN sValue
                      REPLACE "\n" WITH $LF IN sValue
                      REPLACE "\f" WITH $FF IN sValue
                      REPLACE "\b" WITH $BS IN sValue
                      sValue = TRIM$(sValue,$DQ)                                            'Remove leading and Trailling " from string value
                    END IF
              
                       IF sType = "A" THEN                                                      'Array inside an Array
                        JSONArray.add((FORMAT$(lLevel) + $ESC + sType + $ESC + FORMAT$(lArrayIndex)) AS WSTRING)
                        lArrayIndex += 1
                        lResult = JSONArrays (sValue, aJSONArray(), lLevel + 1)                  'Process Array inside Array
                        IF lResult > 0 THEN                                                      'Items were found
                          FOR lCount2 = 1 TO lResult
                          JSONArray.add((aJSONArray(lCount2)) AS WSTRING)                        'add them to our list
                          NEXT lCount2
                        END IF
                       ELSEIF sType = "O" THEN                                                   ' Objects inside of Array
                        JSONArray.add((FORMAT$(lLevel) + $ESC + sType + $ESC + FORMAT$(lArrayIndex)) AS WSTRING)
                        lArrayIndex += 1
                        lResult = JSONMembers (sValue, aJSONArray(), lLevel + 1)                 'Process Object inside Array
                        IF lResult > 0 THEN                                                      'Items were found
                          FOR lCount2 = 1 TO lResult
                          JSONArray.add((aJSONArray(lCount2)) AS WSTRING)                        'add them to our list
                          NEXT lCount2
                        END IF
                       ELSE                                                                      ' Strings, Number, Boloean, Null
                        JSONArray.add((FORMAT$(lLevel) + $ESC + sType + $ESC + FORMAT$(lArrayIndex) + $ESC + sValue) AS WSTRING)
                        lArrayIndex += 1
                       END IF
                  END IF
                END IF
              NEXT lCount1
              REDIM aJSONArray(1 TO JSONArray.Count)
              FOR lCount1 = 1 TO JSONArray.Count                                       'Transfer our list to our array
                  aJSONArray(lCount1) = VARIANT$(JSONArray.item(lCount1))
              NEXT lCount1
                  FUNCTION = JSONArray.Count
              END FUNCTION
               '-----------------------------------------------
              ' JSONArray                           End
              '-----------------------------------------------
              
              '-----------------------------------------------
              ' JSONMembers
              ' Enumerate and extract JSON Members into an Array
              '
              ' Usage     JSONMembers (sData, aJSONMembers())
              ' Usage     JSONMembers (sData, aJSONMembers(), lLevel)
              ' lLevel = used in recurstion
              ' return Result = 0 no objects, -1 No Data, -2 invalid content sData, positive value = number lines
              '-----------------------------------------------
              FUNCTION JSONMembers (sData AS STRING, BYREF aJSONMembers() AS STRING, OPTIONAL BYVAL lLevel AS LONG) AS LONG
              LOCAL sOne, sName, sValue, sType AS STRING
              LOCAL lCount1, lCount2, lLeftBrace, lLCount, DQpair, lDQLeft, lDQRight AS LONG
              LOCAL lResult AS LONG
              
              LOCAL JSONMember AS ILINKLISTCOLLECTION
              LET JSONMember = CLASS "LinkListCollection"
              
              IF LEN (sData) < 2 THEN FUNCTION = - 1  : EXIT FUNCTION              ' No usefull Data
              IF TALLY(sData, $ESC) <> 0 THEN FUNCTION = - 2  : EXIT FUNCTION      ' $ESC present in String, function will not work
              
              lLCount = 0
              lLeftBrace = 0
              DQpair = 0
              
              FOR lCount1 = 1 TO LEN(sData)
                sOne = MID$(sData, lCount1, 1)
              
                IF sOne = "[" THEN lLCount += 1                     'Keep track of []  Arrays
                IF sOne = "]" THEN lLCount -= 1                     '
                IF sOne = "{" THEN lLeftBrace += 1                  'Keep track of {}  Objects
                IF sOne = "}" THEN lLeftBrace -= 1                  '
                IF lLCount = 0 AND(lLeftBrace = 1 OR lCount1 = LEN(sData)) THEN     'if not inside a [], and but inside an {}
                  IF sOne = $DQ THEN                                                'Keep track of double quote pairs
                    DQpair = 1 - DQpair                                             'if DQpair = 0 and you have a Delimiter its end of string.
                  END IF
              
                  IF DQpair = 0 AND MID$(sData, lCount1 + 1, 1) = ":" THEN          'end of $DQ + : --> we have a name
                    lDQRight = lCount1
                    sName = TRIM$(MID$(sData, lDQLeft TO lDQRight), ANY " " + $DQ)
                  END IF
              
                  IF DQPair = 1 AND sOne = $DQ THEN lDQLeft = lCount1
                  IF DQPair = 0 AND(sOne = "," OR lCount1 = LEN(sData)) THEN            '"," End of Member / Value
                    lDQLeft = lDQRight + 2
                    lDQRight = lCount1
                    sValue = TRIM$(MID$(sData, lDQLeft TO lDQRight - 1))
              
                    sType = ""
                    IF LEFT$(sValue, 1) = "{" THEN sType = "O"                               'Object
                    IF LEFT$(sValue, 1) = "[" THEN sType = "A"                               'Array
                    IF UCASE$(sValue) = "TRUE" OR UCASE$(sValue) = "False" THEN sType = "B"  'Bolean
                    IF UCASE$(sValue) = "NULL" THEN sType = "N"                              'Null
                    IF VERIFY(sValue, "0123456789.,+-Ee") = 0 AND ((LEN(sValue) = 1 AND VAL(sValue)=0) OR VAL(sValue) <> 0)  THEN sType = "9"  'Number
                    IF LEFT$(sValue, 1) = $DQ THEN
                      sType = "S"                                                            'String
                      REPLACE "\" + $DQ WITH $DQ IN sValue                                   ' convert the \values to their single value
                      REPLACE "\\" WITH "\" IN sValue                                        ' all these are inside "" strings
                      REPLACE "\/" WITH "/" IN sValue
                      REPLACE "\t" WITH $TAB IN sValue
                      REPLACE "\r" WITH $CR IN sValue
                      REPLACE "\n" WITH $LF IN sValue
                      REPLACE "\f" WITH $FF IN sValue
                      REPLACE "\b" WITH $BS IN sValue
                      sValue = TRIM$(sValue,$DQ)                                           'Remove leading and Trailling " from string value
                    END IF
              
                       IF sType = "A" THEN                                                   'Array inside an Object
                        JSONMember.add((FORMAT$(lLevel) + $ESC + sType + $ESC + sName) AS WSTRING)
                        lResult = JSONArrays (sValue, aJSONMembers(), lLevel +1)             'Process Array inside Object
                        IF lResult > 0 THEN                                                  'Items were found
                          FOR lCount2 = 1 TO lResult
                          JSONMember.add((aJSONMembers(lCount2)) AS WSTRING)                 'add them to our list
                          NEXT lCount2
                        END IF
                       ELSEIF sType = "O" THEN                                               'Object inside an Object
                        JSONMember.add((FORMAT$(lLevel) + $ESC + sType + $ESC + sName) AS WSTRING)
                        lResult = JSONMembers (sValue, aJSONMembers(), lLevel +1)            'Process Object inside Object
                        IF lResult > 0 THEN                                                  'Items were found
                          FOR lCount2 = 1 TO lResult
                          JSONMember.add((aJSONMembers(lCount2)) AS WSTRING)                 'add them to our list
                          NEXT lCount2
                        END IF
                       ELSE
                        JSONMember.add((FORMAT$(lLevel) + $ESC + sType + $ESC + sName + $ESC + sValue) AS WSTRING)
                       END IF
              
                  END IF
                END IF
              NEXT lCount1
              REDIM aJSONMembers(1 TO JSONMember.Count)
              FOR lCount1 = 1 TO JSONMember.Count                                       'Transfer our list to our array
                  aJSONMembers(lCount1) = VARIANT$(JSONMember.item(lCount1))
              NEXT lCount1
                  FUNCTION = JSONMember.Count
              END FUNCTION
               '-----------------------------------------------
              ' JSONMembers                           End
              '-----------------------------------------------
              
              '-----------------------------------------------
              ' JSONObjectsEnum
              ' Enumerate and extract JSON Objects into an Array
              '
              ' Usage     JSONObjectsEnum (sFile, aJSONObjets())
              ' return Result = 0 no objects, -1 No Data, -2 invalid content sData, positive value = number lines
              '-----------------------------------------------
              FUNCTION JSONObjectsEnum (sFile AS STRING, BYREF aJSONObjets() AS STRING) AS LONG
              LOCAL sOne AS STRING
              LOCAL lCount1, lLeftBrace, lRightBrace, lLCount AS LONG
              LOCAL vTemp AS VARIANT
              LOCAL JSONObj AS ILINKLISTCOLLECTION            ' This is convenient since we don't know how many JSON Objects we have
              LET JSONObj = CLASS "LinkListCollection"        ' So we can add to a list no need to DIM/REDIM array
              
              IF LEN (sFile) < 2 THEN FUNCTION = - 1  : EXIT FUNCTION
              IF TALLY(sFile, $ESC) <> 0 THEN FUNCTION = - 2  : EXIT FUNCTION      ' $ESC present in String, function will not work
              
              sFile = REMOVE$(sFile, ANY $CRLF+$TAB)               ' Remove any CR and/or LF JSON does not need then -- Usually there for readability.
              
              lLCount = 0
              FOR lCount1 = 1 TO LEN(sFile)
                sOne = MID$(sFile, lCount1, 1)
                IF sOne = "{" THEN
                  IF lLCount = 0 THEN
                    lLeftBrace = lCount1
                  END IF
                  lLCount += 1
                END IF
                IF sOne = "}" THEN
                  IF lLCount = 1 THEN
                    lRightBrace = lCount1
                  END IF
                  lLCount -= 1
                  IF lLcount = 0 THEN
                    vTemp = TRIM$(MID$(sFile, lLeftBrace TO lRightBrace), ANY " ")      'Get info between brasses {} include brasses trim any leading/trailing spaces
                    JSONObj.add(vTemp)                                                  'Put it in our PowerList
                  END IF
                END IF
              NEXT lCount1
              
              REDIM aJSONObjets(1 TO JSONObj.count)
              FOR lCount1 = 1 TO JSONObj.count                                          'Transfer our list to our array
                  aJSONObjets(lCount1) = VARIANT$(JSONObj.item(lCount1))
              NEXT lCount1
              FUNCTION = JSONObj.count
              END FUNCTION
              '-----------------------------------------------
              ' JSONObjectsEnum                           End
              '-----------------------------------------------
              
              '%Unicode = 1
              '#INCLUDE ONCE "Win32API.inc"
              #INCLUDE ONCE "gdiplus.inc"
              
              ' GDI+ Image(jpg,png,etc) String to bmp handle to use in Control___________________
              FUNCTION ImageToBitmap (stFileData AS STRING,              _
                                      lgPixelW AS LONG,                  _
                                      lgPixelH AS LONG) AS DWORD
              '------------------------------------------------------------------------------
              ' Converts an image file in memory to a bitmap in memory and returns its
              ' handle for manipulation and display of the image using the PB GRAPHIC
              ' statements. The bitmap may be optionally scaled on loading.
              '
              ' Receives a file data buffer.
              '
              ' Receives optional size limits or specifications.
              '
              ' Returns a PB bitmap handle and the returned size of the bitmap.
              '
              ' The stFileData input string should contain the raw binary data of the
              ' image, for example, loaded from file using something like:
              '
              '  open "Image.jpg" for binary as #1
              '  stFileData = string$(lof(1), 0)
              '  get #1,,stFileData
              '  close #1
              '  hBitmap = ImageToBitmap(stFileData, lgPixelW, lgPixelH)
              '
              ' If both the lgPixelW and the lgPixelH parameters are passed as zero,
              ' then the bitmap is loaded with the same pixel width and height as the
              ' source. This size is returned in the lgPixelW and lgPixelH parameters.
              '
              ' If one of the lgPixelW or lgPixelH parameters is passed as zero, then
              ' the bitmap is scaled to the width or height specified by the non-zero
              ' parameter. Aspect ratio is preserved and the zero parameter is filled
              ' in with the scaled width or height on return.
              '
              ' If the specified width or height is negative, the absolute value is
              ' treated as a maximum value. That is, the image may be scaled down,
              ' preserving the aspect ratio, but is never scaled up.
              '
              ' If both the lgPixelW or lgPixelH parameters are specified, then the
              ' bitmap is scaled to the specified size, ignoring the source aspect ratio.
              ' The returned lgPixelW and lgPixelH values will be the same as on entry.
              '
              ' If both width and height are specified and one or both of them is
              ' negative, the absolute values are treated as maximum values. That
              ' is, the image may be scaled down, preserving the aspect ratio, but
              ' is never scaled up.
              '
              ' The stFileData contents are returned as received. The function
              ' result is zero if there is some error.
              '
              ' The format of the image passed is determined automatically from the
              ' signature found in the input buffer. If you wish to know the image
              ' formats which can be decoded by the installed version of GDI+, see
              ' the next paragraph.
              '
              ' Special feature:
              ' If the stFileData parameter is passed as a null string, the returned
              ' string is not a file data buffer but an enumerated list of the decoder
              ' types available. The list is in the form of a sequence of strings in
              ' the format "*.ext" separated by semicolons. The return value is zero
              ' (a bitmap is not created). The returned string can be used directly
              ' for an Open File dialog.
              '
              '------------------------------------------------------------------------------
              LOCAL Stream AS iStream
              LOCAL ptCodecInfo AS IMAGECODECINFO PTR
              LOCAL tStartupInput AS GDIPLUSSTARTUPINPUT
              LOCAL dwToken AS DWORD
              LOCAL dcGraphic AS DWORD
              LOCAL dwFileSize AS DWORD
              LOCAL pFileData AS BYTE PTR
              LOCAL hGlobalMem AS DWORD
              LOCAL pGlobalMem AS BYTE PTR
              LOCAL hImage AS DWORD
              LOCAL lgStatus AS LONG
              LOCAL lgResult AS LONG
              LOCAL hGraphic AS DWORD
              LOCAL lgWidth AS LONG
              LOCAL lgHeight AS LONG
              LOCAL hBitmap1 AS DWORD
              LOCAL hBitmap2 AS DWORD
              LOCAL dwEncoderCount AS DWORD
              LOCAL dwEncInfoSize AS DWORD
              LOCAL stImageCodecInfo AS STRING
              LOCAL lgIndex AS LONG
              LOCAL stFileExt AS STRING
              LOCAL lgNoScaleUp AS LONG
              
              ' If an empty file buffer was passed, fill it with a list of
              ' supported decoder formats and exit.
              IF stFileData = "" THEN
                tStartupInput.GDIplusVersion = 1
                IF GDIplusStartup(dwToken, tStartupInput, BYVAL %NULL) <> 0 THEN
                  EXIT FUNCTION
                END IF
                GdipGetImageDecodersSize dwEncoderCount, dwEncInfoSize
                stImageCodecInfo = STRING$(dwEncInfoSize, $NUL)
                ptCodecInfo = STRPTR(stImageCodecInfo)
                lgResult = GdipGetImageDecoders(dwEncoderCount, dwEncInfoSize, BYVAL ptCodecInfo)
                IF lgResult THEN
                  GDIplusShutdown dwToken
                  EXIT FUNCTION
                END IF
                stFileExt=""
                FOR lgIndex = 1 TO dwEncoderCount
                  stFileExt += PARSE$(@[email protected],";",1) + ";"
                  INCR ptCodecInfo
                NEXT lgIndex
                GDIplusShutdown dwToken
                stFileData = LCASE$(RTRIM$(stFileExt, ";"))
                EXIT FUNCTION
              END IF
              
              ' Make a pointer to the file data and get its size
              dwFileSize = LEN(stFileData)
              pFileData = STRPTR(stFileData)
              
              ' Allocate global memory
              GLOBALMEM ALLOC dwFileSize TO hGlobalMem
              IF hGlobalMem = 0 THEN
                EXIT FUNCTION
              END IF
              
              ' Lock the global memory location and get a pointer
              GLOBALMEM LOCK hGlobalMem TO pGlobalMem
              IF pGlobalMem = 0 THEN
                GLOBALMEM FREE hGlobalMem TO lgResult
                EXIT FUNCTION
              END IF
              
              ' Copy the file data into the the global memory
              POKE$ pGlobalMem, PEEK$(pFileData, dwFileSize)
              
              ' Create a stream from the file in global memory
              lgResult = CreateStreamOnHGlobal(hGlobalMem, BYVAL %FALSE, Stream)
              IF lgResult <> 0 THEN
                GLOBALMEM UNLOCK hGlobalMem TO lgResult
                GLOBALMEM FREE hGlobalMem TO lgResult
                EXIT FUNCTION
              END IF
              
              ' Start GDI+
              tStartupInput.GDIplusVersion = 1
              IF GDIplusStartup(dwToken, tStartupInput, BYVAL %NULL) <> 0 THEN
                FUNCTION = 0
                EXIT FUNCTION
              END IF
              
              ' Create a GDI+ bitmap from the memory file stream
              ' Caution: Even though GDI+ appears to be finished with
              ' the global memory stream, it cannot be freed yet.
              lgStatus = GdipCreateBitmapFromStream(Stream, hImage)
              IF hImage = 0 THEN
                GDIplusShutdown dwToken
                Stream = NOTHING
                GLOBALMEM UNLOCK hGlobalMem TO lgResult
                GLOBALMEM FREE hGlobalMem TO lgResult
                EXIT FUNCTION
              END IF
              
              ' Get the image width and height and create a new PB bitmap
              GdipGetImageWidth  hImage, lgWidth
              GdipGetImageHeight hImage, lgHeight
              GRAPHIC BITMAP NEW lgWidth, lgHeight TO hBitmap1
              GRAPHIC ATTACH hBitmap1, 0
              
              ' Create a GDI+ handle for the new PB bitmap
              GRAPHIC GET DC TO dcGraphic
              GdipCreateFromHDC dcGraphic, hGraphic
              IF hGraphic = 0 THEN
                GRAPHIC BITMAP END
                GdipDisposeImage hImage
                GDIplusShutdown dwToken
                Stream = NOTHING
                GLOBALMEM UNLOCK hGlobalMem TO lgResult
                GLOBALMEM FREE hGlobalMem TO lgResult
                EXIT FUNCTION
              END IF
              
              ' Copy the GDI+ bitmap into the PB bitmap
              GdipDrawImageRectI hGraphic, hImage, 0, 0, lgWidth, lgHeight
              
              ' The image data is now in the PB bitmap area so GDI+
              ' can be shut down and the global memory freed.
              GdipDeleteGraphics hGraphic
              GdipDisposeImage hImage
              GDIplusShutdown dwToken
              Stream = NOTHING
              GLOBALMEM UNLOCK hGlobalMem TO lgResult
              GLOBALMEM FREE hGlobalMem TO lgResult
              
              ' Set the scaled image width and height. If no scaling
              ' is specified, or if the specified width and height
              ' match the loaded width and height, exit here.
              IF lgPixelW < 0 THEN
                lgPixelW = ABS(lgPixelW)
                lgNoScaleUp = %TRUE
              END IF
              IF lgPixelH < 0 THEN
                lgPixelH = ABS(lgPixelH)
                lgNoScaleUp = %TRUE
              END IF
              
              IF (lgPixelW = 0) AND (lgPixelH = 0) THEN
                lgPixelW = lgWidth
                lgPixelH = lgHeight
                FUNCTION = hBitmap1
                EXIT FUNCTION
              ELSEIF lgPixelH = 0 THEN 'Width specified:
                IF lgNoScaleUp THEN 'Max width specified:
                  IF lgWidth > lgPixelW THEN
                    lgPixelH = lgHeight * (lgPixelW / lgWidth)
                  ELSE
                    lgPixelW = lgWidth
                    lgPixelH = lgHeight
                  END IF
                ELSE
                END IF
              ELSEIF lgPixelW = 0 THEN 'Height specified:
                IF lgNoScaleUp THEN 'Max height specified:
                  IF lgHeight > lgPixelH THEN
                    lgPixelW = lgWidth * (lgPixelH / lgHeight)
                  ELSE
                    lgPixelW = lgWidth
                    lgPixelH = lgHeight
                  END IF
                ELSE
                  lgPixelW = lgWidth * (lgPixelH / lgHeight)
                END IF
              ELSEIF lgNoScaleUp THEN 'Max width and height specified:
                IF lgHeight > lgPixelH THEN
                  lgPixelW = lgWidth * (lgPixelH / lgHeight)
                  IF lgWidth > lgPixelW THEN
                    lgPixelH = lgHeight * (lgPixelW / lgWidth)
                  END IF
                ELSEIF lgWidth > lgPixelW THEN
                  lgPixelH = lgHeight * (lgPixelW / lgWidth)
                ELSE
                  lgPixelW = lgWidth
                  lgPixelH = lgHeight
                END IF
              END IF
              IF (lgPixelW = lgWidth) AND (lgPixelH = lgHeight) THEN
                FUNCTION = hBitmap1
                EXIT FUNCTION
              END IF
              
              ' Scale the image, if required, and exit
              GRAPHIC BITMAP NEW lgPixelW, lgPixelH TO hBitmap2
              GRAPHIC ATTACH hBitmap2, 0
              GRAPHIC STRETCH hBitmap1, 0, (0, 0) - (lgWidth, lgHeight) _
                TO (0, 0) - (lgPixelW, lgPixelH), %MIX_COPYSRC, %HALFTONE
              GRAPHIC ATTACH hBitmap1, 0
              GRAPHIC BITMAP END
              FUNCTION = hBitmap2
              
              END FUNCTION
              ' GDI+ Image(jpg,png,etc) String to bmp handle to use in Control___________END_____
              '

              Comment

              Working...
              X