PureBasic

Code : Tout sélectionner

Structure dico
  base.s
  def.s
  mot.s
EndStructure
Global NewList basedef.dico()
Global Site.s="http://www.larousse.fr/dictionnaires/francais/"
ProcedureDLL.s Url2Text2(Url.s, OpenType.b,ProxyAndPort.s)
  ; 1 INTERNET_OPEN_TYPE_DIRECT                       Resolves all host names locally.
  ; 0 INTERNET_OPEN_TYPE_PRECONFIG                    Retrieves the proxy Or direct configuration from the registry.
  ; 4 INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY  Retrieves the proxy Or direct configuration from the registry And prevents the use of a startup Microsoft JScript Or Internet Setup (INS) file.
  ; 3 INTERNET_OPEN_TYPE_PROXY                        Passes requests To the proxy unless a proxy bypass list is supplied And the name To be resolved bypasses the proxy. In this Case, the function uses INTERNET_OPEN_TYPE_DIRECT.
  
  isLoop.b=1
  INET_RELOAD.l = $80000000
  hInet.l=0
  hURL.l=0
  Bytes.l=0
  Buffer.s=Space(2048)
  RES.s=""
  
  
  hInet = InternetOpen_("", OpenType, ProxyAndPort, "", 0)
  hURL = InternetOpenUrl_(hInet, Url, #Null, 0, INET_RELOAD, 0)
  
  Repeat
    InternetReadFile_(hURL,@Buffer, Len(Buffer), @Bytes)
    If Bytes = 0
      isLoop=0
    Else
      RES = RES + Left(Buffer, Bytes)
    EndIf
  Until isLoop=0
  
  InternetCloseHandle_(hURL)
  InternetCloseHandle_(hInet)
  ProcedureReturn RES
EndProcedure
ProcedureDLL.s Url2Text(Url.s)
  ProcedureReturn Url2Text2(Url,1,"") 
EndProcedure
Procedure recherchemot(mot$)
  a$=url2text(site+mot$)
  ;base
  basen1.i=FindString(a$,"CatgramDefinition")  
  base.s=Right(a$,Len(a$)-(basen1+18))
  basen.i=FindString(base,"</p>")-1
  base=Left(base,basen)
  If basen1=0
    base="definition a rajouter"
  EndIf ;problème !!
  ;End
  ;definition
  defn1=FindString(a$,"ul class="+Chr(34)+"Definitions")
  def.s=Right(a$,Len(a$)-(defn1+22))
  defn=FindString(def,"</ul>")-1
  def.s=Left(def,defn)
  If defn1=0
    base="definition a rajouter"
    def=""
  EndIf ;problème !!
  If FindString(a$,"par le correcteur")
    base="definition absente du dictionnaire"
    def=""
  EndIf
  If Len(base)>0
    *membase=AllocateMemory(Len(base)*4)
    PokeS(*membase,base,-1,#PB_Ascii)
    base=PeekS(*membase,-1,#PB_UTF8)
    FreeMemory(*membase)
  EndIf
  If Len(def)>0
    *memdef=AllocateMemory(Len(def)*4)
    PokeS(*memdef,def,-1,#PB_Ascii)
    def=PeekS(*memdef,-1,#PB_UTF8)
    FreeMemory(*memdef)
  EndIf  
  
  If FindString(base,"<a class="+Chr(34)+"lienconj"+Chr(34)+" href="+Chr(34)+"/conjugaison/francais/")
    base=ReplaceString(base,"<a class="+Chr(34)+"lienconj"+Chr(34)+" href="+Chr(34)+"/conjugaison/francais/","")
    n=FindString(base,"/")-1
    base=Left(base,n)
  EndIf
  defn=0
  While FindString(def,"<li class="+Chr(34)+"DivisionDefinition"+Chr(34)+">",1,#PB_String_NoCase)
    defn+1
    def=ReplaceString(def,"<li class="+Chr(34)+"DivisionDefinition"+Chr(34)+">","§"+Str(defn)+" ",#PB_String_NoCase,1,1)
  Wend
  def=ReplaceString(def,"</li>","",1,#PB_String_NoCase)
  def=ReplaceString(def,"<span class="+Chr(34)+"ExempleDefinition"+Chr(34)+">"," Ex: ",#PB_String_NoCase)
  def=ReplaceString(def,"</span>","",1,#PB_String_NoCase)
  def=ReplaceString(def,"<span class="+Chr(34)+"Renvois"+Chr(34)+">","",#PB_String_NoCase)

  While FindString(def,"<")
    For t=1 To Len(def)
      If Mid(def,t,1)="<"
        deb=t-1
      EndIf
      If Mid(def,t,1)=">"
        def=Left(def,deb)+Right(def,Len(def)-t)
        Break
      EndIf
    Next t
  Wend
  While FindString(base,"<")
    For t=1 To Len(base)
      If Mid(base,t,1)="<"
        deb=t-1
      EndIf
      If Mid(base,t,1)=">"
        base=Left(base,deb)+Right(base,Len(base)-t)
        Break
      EndIf
    Next t
  Wend
  ;def
  def=ReplaceString(def,"&nbsp;:"," ")
  def=ReplaceString(def,Chr(9),"")
  def=ReplaceString(def,"  ","")
  def=ReplaceString(def,Chr(13),"")
  ;base
  base=ReplaceString(base,"&nbsp;:"," ")
  base=ReplaceString(base,Chr(9),"")
  
  AddElement(basedef())
  basedef()\base=base
  basedef()\def=def
  basedef()\mot=mot$
EndProcedure

recherchemot("test")
Debug basedef()\mot
Debug basedef()\base
Debug basedef()\def

Code : Tout sélectionner

test
definition a rajouter