Fetch Solution

Date: 02-16-2022

Return to Index

 
'Compilable Example:  (Jose Includes)
#Compile Exe
#Dim All
#Include "httprequest.inc"
#Include "ole2utils.inc"
#Include "WinInet.inc"
 
' ========================================================================================
' Main
' ========================================================================================
 
Function PBMain
   Local OnlineImageURL, LocalImageURL As String
 
   'OnlineImageURL = "https://forum.powerbasic.com/filedata/fetch?id=790991"
   '   OnlineImageURL = "https://forum.powerbasic.com/filedata/fetch?id=781720&d=1559518390"
   OnlineImageURL = "https://forum.powerbasic.com/filedata/fetch?id=781720"
   '   LocalImageURL = Exe.Path$ + "rodimage.jpg"
 
   'If DownloadUrlPBForum ("https://forum.powerbasic.com/filedata/fetch?id=783212&d=1564353461", LocalImageURL) = %false Then MsgBox "Failed"
   If DownloadUrlPBForum ("https://forum.powerbasic.com/filedata/fetch?id=783212", LocalImageURL) = %false Then MsgBox "Failed"
   If DownloadUrlPBForum (OnlineImageURL,"")= %false Then MsgBox "Failed"
 
End Function
 
Function DownloadUrlPBForum(OnlineImageURL As String, LocalImageURL As String) As Long
   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, wFilename As WString
   Local lCount1, lCount2 As Long
   Static wsCookies, vb_UserID, vb_PassHash As WString
 
   ' these are the magic cookies that ID you
   vb_UserID ="vb3187userid=4494"
   vb_PassHash ="vb3187password=3c5a241ea7d86776373402ef052d29c6b68ef518a20c2a7be655f8b6"
 
   Function = %false
 
   ' Creates an instance of the HTTP service
   pWHttp = NewCom "WinHttp.WinHttpRequest.5.1"
   If IsNothing(pWHttp) Then Exit Function
 
   Try
 
      'OK we have what we need now fetch the image
      pWHttp.Open "GET", OnlineImageURL , %false
      pWHttp.setRequestHeader "Cookie", wsCookies + "; " + vb_UserID + "; " + vb_PassHash
 
      pWHttp.Send
 
      ' Wait for response with a timeout of 5 seconds
      iSucceeded = pWHttp.WaitForResponse(5)
 
      If iSucceeded Then
         wsHeaders = Format$(pWHttp.Status) + " " + pWHttp.Statustext + $CrLf
         wsHeaders += pWHttp.GetAllResponseHeaders
         MsgBox wsHeaders
 
         If pWHttp.Status <> 200 Then Exit Function ' failed to get what we asked for.
 
         For lCount1 = 1 To ParseCount(wsHeaders, $CrLf)               ' extract Filename from header
            wTemp1 = Parse$(wsHeaders, $CrLf, lCount1)
            If Tally(wTemp1, "filename=") = 1 Then
               For lCount2 = 1 To ParseCount(wTemp1, ";")
                  wFilename = Parse$(wTemp1, ";", lCount2)
                  If Tally (wFilename, "filename=") = 1 Then wFilename = Remove$(wFilename, "filename=") : Exit For : Exit For
               Next lCount2
            End If
         Next lCount
 
         ? "ParseCount: " + Str$(ParseCount(wsHeaders,$CrLf))
 
         wFilename = Trim$(wFilename,Any $Dq+$Spc)
         'MSGBOX wFilename
 
         ' Get the response as a stream
         vStream = pWHttp.ResponseStream
         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
               'MSGBOX strBuffer
               ' Save the buffer into a file
               If LocalImageURL <> "" Then wFilename = LocalImageURL
               If wFilename = "" Then wFilename = "My-image.html"
               If IsFile (wFilename) Then Kill wFilename
               Open wFilename For Binary As #1
               Put #1, 1, strBuffer
               Close #1
               MsgBox "File saved" + wFileName
               Function = %true
            Else
               MsgBox "Buffer is empty"
            End If
         End If
      End If
   Catch
      OleShowErrorInfo ObjResult
   End Try
 
End Function
   ' ============

created by gbSnippets
http://www.garybeene.com/sw/gbsnippets.htm