FiveTech Software tech support forums

karinha wrote:Ora tocca a te Silvio. Esempi da "giocare".

Ahora te toca a ti Silvio. Ejemplos que tienes para "jugar/trabajar".

Terminó la participación en este tema muy interesante.

Participation ended in this very interesting topic.

Code: Select all | Expand

// \samples\RRSSILV2.PRG.PRG - 28/02/2022 Modified by Joao Santos.

#include "FiveWin.ch" 
#include "Splitter.ch"

#Define CLR_LGRAY      nRGB( 230, 230, 230 )

/* 
 * ********************************************************* 
 * 
 * FEED READER: Modulo leitor de feeds 
 * Autor: Jose Carlos da Rocha 
 * 
 * ********************************************************* 
*/

MEMVAR aDatos, aBitmaps, oWnd2, aFeeds, oRSSLbx, cRSSLbx, oChildWnd

STATIC lChildWnd := .T., lSuccess := .F.

FUNCTION FeedReader( oWnd, opcao, lHorizontal )
 
   LOCAL cTitle, oFntLBX, fntArial, oBmp, oBtn01, oBtn02
   LOCAL oGet, oSplit, oBar //, oGraph, oTree
   LOCAL oFRTree, oFRHTML, oFRLbx, oVSplit, oHSplit

   HB_GCALL( .F. )

   IF( .NOT. IsInternet() ) // Asi, es mejor Silvio.

      MsgStop( "Controlla la tua internet", "Attenzione" )

      HB_GCALL( .T. )

      CLEAR MEMORY

      PostQuitMessage( 0 )

      QUIT

      RETURN NIL

   ENDIF

   SetBalloon( .T. ) // Balloon shape required for tooltips

   SkinButtons()

   aDatos := {}

   cTitle := "|| Lettore RSS -  Really Simple Syndication Versione: 3.0 ||"

   aBitmaps := { "..\bitmaps\alphabmp\facebook.bmp",;
                 "..\bitmaps\alphabmp\windows.bmp",;
                 "..\bitmaps\alphabmp\game.bmp",;
                 "..\bitmaps\alphabmp\viddler.bmp",;
                 "..\bitmaps\alphabmp\mail.bmp",;
                 "..\bitmaps\alphabmp\call.bmp",;
                 "..\bitmaps\alphabmp\settings2.bmp",;
                 "..\bitmaps\alphabmp\exit.bmp" }

   IF FILE( "feeds.arr" ) // Nuevo

      DELETEFILE( "feeds.arr" )

   ENDIF

   // By Silvio: 28/02/2022
   IIF(  .NOT. FILE("feeds.arr"),;
      EK_SAVEARR( { "http://forums.fivetechsupport.com/rss.php" }, "feeds.arr" ), "" )
   
   aFeeds  := EK_RESTARR( "feeds.arr" )
   cRSSLbx := aFeeds[1]
   aDatos  := FeedLoaderArray( cRSSLbx )

   DEFINE FONT oFntLBX  NAME "Courier New"   SIZE  0,-12
   DEFINE FONT fntArial NAME "Arial"         SIZE 10,22

   DEFINE WINDOW oChildWnd FROM 0,0 TO 600,750 PIXEL TITLE cTitle

   // DEFINE BUTTONBAR oBar OF oChildWnd SIZE 24, 24 //_3D // Button Bar com efeito 3D / Outlook
   DEFINE BUTTONBAR oBar BUTTONSIZE 24, 24 _3DLOOK TOP OF oChildWnd 2007

   @ 0, 25 SAY " "+cTitle FONT fntArial SIZE 950, 150 ;
      COLOR RGB(216,208,200), CLR_GRAY PIXEL OF oBar
                                                                // 24
   @ .5,  5 BITMAP oBmp FILENAME "..\bitmaps\16x16\floppy.bmp" SIZE 50, 24 ;
      NOBORDER SCROLL UPDATE PIXEL OF oBar

   //       RESOURCE "bmpbtn24" SIZE 70,24 ;
   @ .5,(oChildWnd:nWidth-72*1) BTNBMP oBtn01 PROMPT "Close"    ;
      FILENAME "..\bitmaps\16x16\Exit.bmp" SIZE 70,24           ;
      ACTION ( oChildWnd:End(), lChildWnd := .f. ) NOBORDER     ;
      OF oBar LEFT FONT oFntLBX

   @ .5,(oChildWnd:nWidth-72*2) BTNBMP oBtn02 PROMPT "Menu..."  ;
      FILENAME "..\bitmaps\16x16\new.bmp" SIZE 70, 24           ;
      ACTION FUN() NOBORDER OF oBar LEFT FONT oFntLBX

   /*
   @ 0, 0 LISTBOX oRSSLbx VAR cRSSLbx ITEMS aFeeds SIZE 200,200 PIXEL ;
      OF oChildWnd
   */
   @ 0, 0 LISTBOX oRSSLbx VAR cRSSLbx OF oChildWnd SIZE 200, 200 PIXEL   ;
      ITEMS aFeeds

     oRSSLbx:nStyle        := 1

   oRSSLbx:bLdblClick := { | nRow, nCol | ( ;
      aDatos := FeedLoaderArray( aFeeds[oRSSLbx:GetPos()] ), ;
                oFRLbx:lHitBottom    := .f.              ,   ;
                oFRLbx:blogiclen     := {|| len(aDatos) },   ;
                oFRLbx:GoTop()                           ,   ;
                oFRLbx:Refresh() ) }

   @ 000, 205 LISTBOX oFRLbx FIELDS "" ;
      HEADERS "", "Titulo", "Data"     ;
      FIELDSIZES 24, 550, 250          ;
      SIZE 300,200 PIXEL OF oChildWnd UPDATE

   oFRLbx:bLdblClick    := { | nRow, nCol | oFRHTML:Do( "Navigate2", aDatos[oFRLbx:nat][4] ) }

   oFRLbx:nat           := 1
   oFRLbx:bline         := { || { aDatos[ oFRLbx:nat ][ 1 ], ;
                                  aDatos[ oFRLbx:nat ][ 2 ], ;
                                  aDatos[ oFRLbx:nat ][ 3 ]} }

   oFRLbx:bgotop        := { || oFRLbx:nat := 1 }
   oFRLbx:bgobottom     := { || oFRLbx:nat := eval( oFRLbx:blogiclen ) }
   oFRLbx:bskip         := { | nwant, nold | nold := oFRLbx:nat, oFRLbx:nat +=nwant,;
   oFRLbx:nat           := max( 1, min( oFRLbx:nat, eval( oFRLbx:blogiclen ) ) ),;
   oFRLbx:nat - nold }

   oFRLbx:blogiclen     := { || len( aDatos[1] ) }

   oFRLbx:nClrBackHead  := CLR_WHITE  // Cor do Fundo do Cabe‡alho
   oFRLbx:nClrText      := {|| nRGB( 000, 000, 000 ) } // Cor do Fundo do Cabe‡alho
   oFRLbx:nClrBackFocus := CLR_WHITE   // Cor do Cursor Em Cima do Ötem
   oFRLbx:nClrForeFocus := CLR_HRED    // Cor da letra da barra ativa
   oFRLbx:nClrForeHead  := CLR_BLACK   // Cor nos Headers - Cabe‡alhos
   oFRLbx:nColAct       := 1           // Onde o Cursor Vai Iniciar na coluna
   oFRLbx:nLineStyle    := 3           // Estilo das linhas nos dados da Browse
   oFRLbx:lCellStyle    := .T.         // Somente pinta a c‚lula em que o cursor esta no momento
   oFRLbx:aJustify := { .F., .F., .F. }
   oFRLbx:lMChange      := .F.         // Desabilita Mousemove - Movimentos do Mouse Congelam.
   oFRLbx:SetFocus()                   // Refocus on The Browse - Ativa o Foco na ListBox(Browse)
   oFRLbx:Refresh()                    // Estabiliza o Browse/Listbox - Refresca os Dados.

   oFRLbx:SetFont( oFntLBX )

   @ 205,205 ACTIVEX oFRHTML PROGID "Shell.Explorer.2" SIZE 300, 150 ;
      OF oChildWnd

   oFRHTML:Silent := .T.  // Nuevo.

   @ 200,205 SPLITTER oHSplit ; 
             HORIZONTAL ; 
             PREVIOUS CONTROLS oFRLbx ; 
             HINDS CONTROLS oFRHTML ; 
             TOP MARGIN 80 ; 
             BOTTOM MARGIN 80 ; 
             SIZE 300, 4  PIXEL ; 
             OF oChildWnd ; 
             _3DLOOK 

   @ 000,200 SPLITTER oVSplit ; 
             VERTICAL ; 
             PREVIOUS CONTROLS oRSSLbx ; 
             HINDS CONTROLS oFRLbx, oHSplit, oFRHTML ; 
             LEFT MARGIN 80 ; 
             RIGHT MARGIN 80 ; 
             SIZE 4, 355  PIXEL ; 
             OF oChildWnd ; 
             _3DLOOK 

   // https://abruzzoweb.it/rss-google-news-laquila.xml
   // ON INIT ( oFRHTML:Do( "Navigate2", "http://feeds2.feedburner.com/WikinewsUltimeNotizie" ) ) ;
   ACTIVATE WINDOW oChildWnd MAXIMIZED                                ;
      ON INIT ( oFRHTML:Do( "Navigate2", "https://abruzzoweb.it/rss-google-news-laquila/feed/" ) ) ;
      ON RESIZE ( oVSplit:AdjLeft(), oHSplit:AdjRight() )

   // By Silvio: 28/02/2022
   /*
   ACTIVATE WINDOW oChildWnd MAXIMIZED ;
      ON INIT ( oFRHTML:Do( "Navigate2", "http://forums.fivetechsupport.com/rss.php" ) ) ;
      ON RESIZE ( oVSplit:AdjLeft(), oHSplit:AdjRight() )
   */

   oFntLBX:End()
   fntArial:End()

   HB_GCALL( .T. )

   CLEAR MEMORY

   PostQuitMessage( 0 )

   QUIT

RETURN NIL

FUNCTION FeedLoaderArray( cURL )
 
   LOCAL oXMLDoc, cChannelTitle, cChannelLink, cChannelDescr, cChannelCopy
   LOCAL RespText, objXMLHTTP, cXMLFeed, aFeedLoaderArray := {}
   LOCAL X, I, Y

   // DEFAULT cURL := "https://g1.globo.com/Rss2/0,,AS0-5600,00.xml"
   DEFAULT cURL := "https://abruzzoweb.it/rss-google-news-laquila.xml"

   // Carrega variavel com conteudo do XML do RSS 
   // MsgRun( "Puxando arquivo...", "Leitor de RSS", {|| cXMLFeed := FeedPuching( cURL ) } )
   MsgRun( "Ottenere file...", "Lettore RSS", {|| cXMLFeed := FeedPuching( cURL ) } )

   // Bloco de leitura e assinalacao do conteudo do RSS 
   #IFDEF __XHARBOUR__

       TRY

          oXmlDoc := GetActiveObject( "Microsoft.XMLDOM" )

       CATCH

         TRY

            oXmlDoc := CreateObject( "Microsoft.XMLDOM" )

         CATCH

            Alert( "ERROR! in xHarbour" )

         END

      END

   #ELSE

      oXmlDoc := TOleAuto():New( "Microsoft.XMLDOM" )

   #ENDIF

   oXMLDoc:async := .f.

   lSuccess := oXMLDoc:loadXML( cXMLFeed )

   if lSuccess

      x := oXMLDoc:getElementsByTagName( "channel" ) 

      cChannelTitle := oXMLDoc:selectNodes("//title"):Item(0):Text
      cChannelLink  := oXMLDoc:selectNodes("//link"):Item(0):Text 
      cChannelDescr := oXMLDoc:selectNodes("//description"):Item(0):Text
      cChannelCopy  := oXMLDoc:selectNodes("//copyright"):Item(0):Text

      y := oXMLDoc:getElementsByTagName( "item" )

      for i = 1 to y:length 
         // cItemTitle, cItemPDate, cItemLink, cItemDescr
         AADD( aFeedLoaderArray, ;
               { "", oXMLDoc:selectNodes("//item/title"):Item(i-1):Text  , ;
                     oXMLDoc:selectNodes("//item/pubDate"):Item(i-1):Text, ;
                     oXMLDoc:selectNodes("//item/link"):Item(i-1):Text   , ;
                     oXMLDoc:selectNodes("//item/description"):Item(i-1):Text } )

      next 

   endif

RETURN aFeedLoaderArray

FUNCTION FeedLoader( cURL )

   LOCAL cChannelTitle, cChannelLink, cChannelDescr, cChannelCopy
   LOCAL cItemTitle, cItemPDate, cItemLink, cItemDescr
   LOCAL RespText, objXMLHTTP, cXMLFeed, oXMLDoc, X, I, Y

   //DEFAULT cURL := "https://g1.globo.com/Rss2/0,,AS0-5600,00.xml"
        // cURL := "https://rss.terra.com.br/0,,EI4795,00.xml"
   DEFAULT cURL := "https://abruzzoweb.it/rss-google-news-laquila.xml"

   if recco() <= 0

      // Carrega variavel com conteudo do XML do RSS 
      MsgRun( "Puxando arquivo...", "Leitor de RSS", {|| cXMLFeed := FeedPuching( cURL ) } ) 

      //MemoEdit( cXMLFeed ) 
      MemoWrit( "feeds.xml", ANSITOOEM( cXMLFeed ) )

      IF FILE( "feeds.xml" )

         MemoEdit( MemoRead( "feeds.xml" ) )

      ENDIF

      MsgRun( "Criando..." )

      // Bloco de leitura e assinalacao do conteudo do RSS 
      #IFDEF __XHARBOUR__

          TRY

             oXmlDoc := GetActiveObject( "Microsoft.XMLDOM" )

          CATCH

            TRY
               oXmlDoc := CreateObject( "Microsoft.XMLDOM" )
            CATCH

               Alert( "ERROR! in xHarbour" )

            END

         END

      #ELSE

         oXmlDoc := TOleAuto():New( "Microsoft.XMLDOM" )

      #ENDIF

      oXMLDoc:async := .f.

      //lSuccess := oXMLDoc:load( "feeds.xml" ) 
      lSuccess := oXMLDoc:loadXML( cXMLFeed ) 

      if lSuccess

         x := oXMLDoc:getElementsByTagName( "channel" ) 

         cChannelTitle := oXMLDoc:selectNodes("//title"):Item(0):Text 
         cChannelLink  := oXMLDoc:selectNodes("//link"):Item(0):Text 
         cChannelDescr := oXMLDoc:selectNodes("//description"):Item(0):Text 
         cChannelCopy  := oXMLDoc:selectNodes("//copyright"):Item(0):Text 

         y := oXMLDoc:getElementsByTagName( "item" )

         for i = 1 to y:length

             cItemTitle := oXMLDoc:selectNodes("//item/title"):Item(i-1):Text 
             cItemPDate := oXMLDoc:selectNodes("//item/pubDate"):Item(i-1):Text 
             cItemLink  := oXMLDoc:selectNodes("//item/link"):Item(i-1):Text 
             cItemDescr := oXMLDoc:selectNodes("//item/description"):Item(i-1):Text

             dbAppend( 0 )

             feeds->IDCHANNEL   := cURL 
             // 
             feeds->CHANNEL     := cChannelTitle 
             feeds->CHANNELLIN  := cChannelLink 
             feeds->CHANNELDES  := cChannelDescr 
             feeds->CHANNELCOP  := cChannelCopy 
             // 
             feeds->ITEMTITLE   := cItemTitle 
             feeds->ITEMPDATE   := cItemPDate 
             feeds->ITEMLINK    := cItemLink 
             feeds->ITEMDESC    := cItemDescr

             dbCommitAll()

         next 
    
         // xBrowse()  // teste

      endif

   endif

RETURN NIL

FUNCTION FeedPuching( cURL )
 
   LOCAL oServer, cResponseText

   #IFDEF __XHARBOUR__  // xHarbour

      Try

         oServer:= CreateObject( "MSXML2.ServerXMLHTTP.6.0" )

      Catch

         MsgInfo('Erro na Criação do Serviço')

         Return Nil

      End

   #ELSE

      Try

         //oServer:= win_OleCreateObject( "MSXML2.ServerXMLHTTP.5.0") // funciona

         // teste for Silvio.
         oServer := TOLEAuto():New( "MSXML2.ServerXMLHTTP.5.0" ) // funciona

      Catch

         MsgInfo('Erro na Criação do Serviço! harbour', 'Atenção!')

         Return nil

      End

   #ENDIF

   Try

      oServer:Open( "GET", cURL, .F. )

      oServer:SetRequestHeader( "Content-Type", "application/x-www-form-urlencoded" )
      oServer:SetRequestHeader( "Connection", "keep-alive" )

      oServer:Send()
      oServer:WaitForResponse( 10000 )

      cResponseText := oServer:ResponseText

   Catch

      MsgInfo('Erro na conexão com o site!', 'Atenção!')

      Return nil

   End

   lSuccess := .F.  // return to .F.
   oServer  := NIL

RETURN( cResponseText )
/*
 * 
 * *** *** *** *** *** *** *** *** *** *** *** *** *** *** *** 
 * Descricao: Funcoes para tratamento de arrays 
 * *** *** *** *** *** *** *** *** *** *** *** *** *** *** *** 
 * 
*/
FUNCTION EK_SAVEARR(Arg1, Arg2, Arg3)        //Arg1=Array, Arg2=archivo, Arg3=doserror
 
   LOCAL Local1:= Fcreate(Arg2), Local2

   Arg3:= Ferror()

   If (Arg3 == 0)

      Local2:= _eksavesub(Arg1, Local1, @Arg3)

      Fclose( Local1 )

      If (Local2 .AND. Ferror() != 0)

         Arg3:= Ferror() 
         Local2:= .F.

      EndIf

    Else

      Local2:= .F.

   EndIf

RETURN( Local2 )

STATIC FUNCTION _EKSAVESUB(Arg1, Arg2, Arg3)
 
   LOCAL Local1, Local2, Local3, lRet

   // private lret

   lret:= .T.

   Local1:= ValType(Arg1)

   Fwrite(Arg2, Local1, 1)

   If (Ferror() == 0)

     Do Case 
      Case Local1 = "A" 
         Local2:= Len(Arg1) 
         Fwrite(Arg2, L2Bin(Local2), 4) 
         If (Ferror() == 0) 
           AeVal(Arg1, {|_1| lret:= _eksavesub(_1, Arg2)}) 
          Else 
           lret:= .F. 
         EndIf 
      Case Local1 = "B" 
         lret:= .F. 
      Case Local1 = "C" 
         Local2:= Len(Arg1) 
         Fwrite(Arg2, L2Bin(Local2), 4) 
         Fwrite(Arg2, Arg1) 
      Case Local1 = "D" 
         Local2:= 8 
         Fwrite(Arg2, L2Bin(Local2), 4) 
         Fwrite(Arg2, DToC(Arg1)) 
      Case Local1 = "L" 
         Local2:= 1 
         Fwrite(Arg2, L2Bin(Local2), 4) 
         Fwrite(Arg2, iif(Arg1, "T", "F")) 
      Case Local1 = "N" 
         Local3:= Str(Arg1) 
         Local2:= Len(Local3) 
         Fwrite(Arg2, L2Bin(Local2), 4) 
         Fwrite(Arg2, Local3) 
     Endcase

    Else

      lret:= .F.

   Endif

   Arg3:= ferror()

RETURN lret

FUNCTION EK_RESTARR(Arg1, Arg2)       // Arg1=Archivo, Arg2=doserror
 
   LOCAL Local1 := Fopen(Arg1), Local2

   Arg2:= Ferror()

   If (Arg2 == 0) 
      Local2:= _ekrestsub(Local1, @Arg2) 
      FClose(Local1) 
    Else 
      Local2:= {} 
   Endif

RETURN Local2

STATIC FUNCTION _EKRESTSUB(Arg1, Arg2)
 
   LOCAL Local1:= " ", Local2, Local3, Local4, Local5, Local6

   Fread(Arg1, @Local1, 1)

   Local3:= Space(4)

   Fread(Arg1, @Local3, 4)

   Local2:= Bin2L(Local3)

   Arg2:= Ferror() 

   If (Arg2 == 0) 

      Do Case 
      Case Local1 = "A"
         Local4:= {}
         For Local6 := 1 To Local2
            AAdd(Local4, _ekrestsub(Arg1))
         Next Local6
      Case Local1 = "C"
         Local4:= Space(Local2)
         Fread(Arg1, @Local4, Local2)
      Case Local1 = "D"
         Local5:= Space(8)
         Fread(Arg1, @Local5, 8)
         Local4:= CToD(Local5)
      Case Local1 = "L"
         Local5:= " "
         Fread(Arg1, @Local5, 1)
         Local4:= Local5 = "T"
      Case Local1 = "N"
         Local5:= Space(Local2)
         Fread(Arg1, @Local5, Local2)
         Local4:= Val(Local5)
      Endcase

      Arg2:= ferror()

   Endif

RETURN( Local4 )

FUNCTION Fun()
 
RETURN( .T. )
// fin / end
 

Regards, saludos.