PureBasic Forums - English

http://www.purebasic.com
https://www.purebasic.fr/english/

Probleme avec la procedure WindowCallback !

https://www.purebasic.fr/english/viewtopic.php?t=8605

Page 1 of 1

Probleme avec la procedure WindowCallback !

Posted: Wed Dec 03, 2003 10:18 pm
by Dionyzos
Bonjour,

J'ai utilisé dans mon appli la procédure SetWindowCallback et pourtant l'appli ne me rend pas la main pendant l'execution, et je ne vois pas pourquoi :(

voici mon code :

Code: Select all

Enumeration
  #gIndex
  #Window
  #Editor
  #LabD
  #LabF
  #Deb
  #Fin
  #Btn
  #Prog
EndEnumeration

Global TEMOIN.s
Global titre$, titre_org$, origine$, genre$, annee$, duree$, acteurs$, realisateurs$, resume$, ligne$, erreur$



;####################################################
;
; Rapatrie le contenu de la page web dont l'URL est
; 'URL', et enregistre la source dans le fichier 'File'
;
;####################################################
Procedure OpenURL(File.s, URL.s, OpenType.b) 
  ;?OpenType [1 = IOTPreconfig | 2 =  IOTDirect | 3 = IOTProxy] 
  ;content.s = OpenURL("http://www.google.de/index.html", 1) 
  
  URL = "http://www.allocine.fr/film/fichefilm_gen_cfilm="+URL+".html"
  isLoop.b=1 
  INET_RELOAD.l = $80000000 
  hInet.l=0 
  hURL.l=0 
  Bytes.l=0 
  Buffer.l=4096

  AllocateMemory(0,Buffer) 
  UseMemory(0) 

  If CreateFile(1, File) = 0
    MessageRequester("Erreur", "Impossible de créer le fichier Temp", 0)
    End
  EndIf

  hInet = InternetOpen_("PB@INET", OpenType, #Null, #Null, 0) 
  hURL = InternetOpenUrl_(hInet, URL, #Null, 0, INET_RELOAD, 0) 
  c = 0 
  Repeat
    Delay(5)
    InternetReadFile_(hURL, MemoryID(), Buffer, @Bytes) 
    If Bytes = 0 
      isLoop=0 
    Else
      UseFile(1) 
      WriteData(MemoryID(), Bytes) 
    EndIf 
  Until isLoop=0 
  InternetCloseHandle_(hURL) 
  InternetCloseHandle_(hInet) 
  CloseFile(1)    
  FreeMemory(0) 
EndProcedure 




;####################################################
;
; Retourne la chaine de texte dans le fichier "fich"
; entre la borne gauche "brn_gch" et la borne droite
; "brn_drt".
; Les bornes sont au format 'string' et doivent être
; exclusives dans la mesure où la procédure ne renverra
; que le premier couple, de ces deux bornes, trouvé.
;
;####################################################
Procedure.s ScanFile(File.s, brn_gch.s, brn_drt.s)
  str$ = ""
  ctn_fich$ = ""
  ReadFile(0, File)
  size = 63000
  AllocateMemory(0, size, 0)
  ReadData(MemoryID(), size)
  ctn_fich$ = PeekS(MemoryID(), size)
  FreeMemory(0)
  x = FindString(ctn_fich$, brn_gch, 1)
  y = FindString(ctn_fich$, brn_drt, 1)
  CloseFile(0)
  If x <> 0 And y <> 0
    ReadFile(1, File)
    x + Len(brn_gch)
    size = y - x
    AllocateMemory(1, size, 0)
    FileSeek(x-1)
    ReadData(MemoryID(), size)
    str$ = PeekS(MemoryID(), size)
    FreeMemory(1)
    CloseFile(1)
  EndIf
  ProcedureReturn str$
EndProcedure




;####################################################
;
; Scanne la source de la fiche HTML pour récolter les
; informations du film, et les place dans leur variable
; globale respective.
;
;####################################################
Procedure Scan_Source(num)
  titre$ = "" : titre_org$ = "" : origine$ = "" : genre$ = "" : annee$ = ""
  duree$ = "" : acteurs$ = "" : realisateurs$ = "" : resume$ = "" : ligne$ = ""
  G.s = Chr(34) ; Guillemets
  bg.s = "" : bd.s = "" : temp.s = "" : erreur$ = ""
  ; Création du fichier temporaire HTML contenant la source HTML extrait du site
  OpenURL("temp.htm", Str(num), 1)

;TITRE & TITRE ORIGINALE
  bg = "<FONT Class="+G+"titrePage"+G+">"
  bd = "</FONT></TD></TR><TR><TD><font >Film"
  temp = ScanFile("temp.htm", bg, bd)
  temp = ReplaceString(temp, " <font >(", "µ", 1, 1)
  temp = RemoveString(temp, ")</font>")
  temp = ReplaceString(temp, "'", "\'", 1, 1)
  If FindString(temp, "<td>", 1) <> 0 Or FindString(temp, "<TD>", 1) <> 0
    temp = "### Erreur : Fiche n°: "+Str(num)+" au niveau de \'Titre\' !"
    erreur$ = "   !!! Erreur !!! (voir la ligne correspondante dans le fichier 'divx.sql')"
  EndIf
  titre$ = StringField(temp, 1, "µ")
  titre_org$ = StringField(temp, 2, "µ")

;ORIGINE
  bg = "Film</font>&nbsp;<FONT Class="+G+"size2"+G+">"
  bd = "</FONT> <font >("
  temp = ScanFile("temp.htm", bg, bd)
  temp = ReplaceString(temp, "'", "\'", 1, 1)
  If FindString(temp, "<td>", 1) <> 0 Or FindString(temp, "<TD>", 1) <> 0
    temp = "### Erreur : Fiche n°: "+Str(num)+" au niveau de \'Origine\' !"
    erreur$ = "   !!! Erreur !!! (voir la ligne correspondante dans le fichier 'divx.sql')"
  EndIf
  origine$ = ReplaceString(temp, "</FONT>, <FONT Class="+G+"size2"+G+">", ", ", 1, 1)

;ANNEE
  bg = "</FONT> <font >("
  bd = ")</font>. <FONT Class="
  temp = ScanFile("temp.htm", bg, bd)
  If FindString(temp, "<td>", 1) <> 0 Or FindString(temp, "<TD>", 1) <> 0
    temp = "### Erreur : Fiche n°: "+Str(num)+" au niveau de \'Année\' !"
    erreur$ = "   !!! Erreur !!! (voir la ligne correspondante dans le fichier 'divx.sql')"
  EndIf
  annee$ = temp

;GENRE(S)
  bg = ")</font>. <FONT Class="+G+"size2"+G+">"
  bd = "</FONT>. <FONT Class="+G+"size2"+G+">Dur"
  temp = ReplaceString(ScanFile("temp.htm", bg, bd), "</FONT>, <FONT Class="+G+"size2"+G+">", ", ", 1, 1)
  If FindString(temp, "<td>", 1) <> 0 Or FindString(temp, "<TD>", 1) <> 0
    temp = "### Erreur : Fiche n°: "+Str(num)+" au niveau de \'Genre(s)\' !"
    erreur$ = "   !!! Erreur !!! (voir la ligne correspondante dans le fichier 'divx.sql')"
  EndIf
  genre$ = ReplaceString(temp, "'", "\'", 1, 1)

;DUREE
  bg = "Durée&nbsp;:&nbsp;"
  bd = "mn. </FONT>"
  temp = ScanFile("temp.htm", bg, bd)
  If FindString(temp, "<td>", 1) <> 0 Or FindString(temp, "<TD>", 1) <> 0
    temp = "### Erreur : Fiche n°: "+Str(num)+" au niveau de \'Durée\' !"
    erreur$ = "   !!! Erreur !!! (voir la ligne correspondante dans le fichier 'divx.sql')"
  Else
    hre = Val(Trim(StringField(temp, 1, "h")))
    min = Val(Trim(StringField(temp, 2, "h")))
    temp = Str((hre * 60 ) + min)
  EndIf
  duree$ = temp

;ACTEUR(S)
  bg = "Avec&nbsp;</FONT><A "
  bd = "</TD></TR><TR><TD><FONT Class="+G+"titreDescription"+G+">Réalisé"
  temp = ScanFile("temp.htm", bg, bd)
  temp = ReplaceString(temp, "Class="+G+"link1"+G+">", "µ", 1, 1)
  temp = ReplaceString(temp, "</A>", "µ", 1, 1)
  champ.s = "" : temp2.s = "" : k = 2 : quit = 0
  Repeat
    champ = StringField(temp, k, "µ")
    champ = ReplaceString(champ, "&nbsp;", " ", 1, 1)
    If champ = ""
      temp2 = Left(temp2, Len(temp2)-2)
      Break
    EndIf
    temp2 + champ + ", "
    k+2
  Until quit = 1
  temp2 = ReplaceString(temp2, "'", "\'", 1, 1)
  If FindString(temp2, "<td>", 1) <> 0 Or FindString(temp2, "<TD>", 1) <> 0
    temp2 = "### Erreur : Fiche n°: "+Str(num)+" au niveau de \'Acteur(s)\' !"
    erreur$ = "   !!! Erreur !!! (voir la ligne correspondante dans le fichier 'divx.sql')"
  EndIf
  acteurs$ = temp2

;REALISATEUR(S)
  bg = "Réalisé par&nbsp;"
  bd = "</A></TD></TR></TABLE>"
  temp = ScanFile("temp.htm", bg, bd)
  temp = ReplaceString(temp, "Class="+G+"link1"+G+">", "µ", 1, 1)
  temp = ReplaceString(temp, "</A>", "µ", 1, 1)
  champ.s = "" : temp2.s = "" : k = 2 : quit = 0
  Repeat
    champ = StringField(temp, k, "µ")
    champ = ReplaceString(champ, "&nbsp;", " ", 1, 1)
    If champ = ""
      temp2 = Left(temp2, Len(temp2)-2)
      Break
    EndIf
    temp2 + champ + ", "
    k+2
  Until quit = 1
  temp2 = ReplaceString(temp2, "'", "\'", 1, 1)
  If FindString(temp2, "<td>", 1) <> 0 Or FindString(temp2, "<TD>", 1) <> 0
    temp2 = "### Erreur : Fiche n°: "+Str(num)+" au niveau de \'Réalisateur(s)\' !"
    erreur$ = "   !!! Erreur !!! (voir la ligne correspondante dans le fichier 'divx.sql')"
  EndIf
  realisateurs$ = temp2

;RESUME
  bg = "<DIV Align='justify'><FONT class="+G+"size2"+G+">"
  bd = "</FONT></DIV></TD></TR><TR><TD><IMG Border=0 Src="
  temp = ScanFile("temp.htm", bg, bd)
  If temp = ""
    bg = "<DIV Align='justify'><FONT class="+G+"size2"+G+">"
    bd = "</FONT></DIV></TD></TR></TABLE></TD><TD><IMG Border=0 Src="
    temp = ScanFile("temp.htm", bg, bd)
  EndIf
  temp = ReplaceString(temp, "'", "\'", 1, 1)
  If FindString(temp, "<td>", 1) <> 0 Or FindString(temp, "<TD>", 1) <> 0
    temp = "### Erreur : Fiche n°: "+Str(num)+" au niveau de \'Synopsis\' !"
    erreur$ = "   !!! Erreur !!! (voir la ligne correspondante dans le fichier 'divx.sql')"
  EndIf
  resume$ = RemoveString(temp, "<br>", 1)
  
  DeleteFile("temp.htm")

EndProcedure




;####################################################
;
; Procédure appelée lorsque l'on clique sur le bouton
;
;####################################################
Procedure.s Main()
  cur0 = LoadCursor_(0, #IDC_ARROW) 
  cur1 = LoadCursor_(0, #IDC_APPSTARTING) 
  SetCursor_(cur1)
  cancel = 0

  SetGadgetText(#Editor, "")
  DisableGadget(#Deb, 1)
  DisableGadget(#Fin, 1)
  SetGadgetText(#Btn, "Stop")

  Delay(100)

  If CreateFile(5, "divx.sql") = 0
    MessageRequester("Erreur","Impossible de créer le fichier de requêtes 'divx.sql' !", 0)
    End
  EndIf

  If CreateFile(6, "scan.log") = 0
    MessageRequester("Erreur","Impossible de créer le fichier de log 'scan.log' !", 0)
    End
  EndIf

  deb = Val(GetGadgetText(#Deb))
  fin = Val(GetGadgetText(#Fin))

  For k = deb To fin

    Scan_Source(k)

    requete$ = "INSERT INTO `divx` (`titre`, `titre_orig`, `origine`, `genre`, `annee`, `duree`, `acteurs`, `auteurs`, `pitch`) VALUES ('"+titre$+"', '"+titre_org$+"', '"+origine$+"', '"+genre$+"', '"+annee$+"', '"+duree$+"', '"+acteurs$+"', '"+realisateurs$+"', '"+resume$+"');"

    If titre$ = ""
      ligne$ = RSet$(Str(k), 5, "0") + " : <FICHE INCONNUE>"
      UseFile(6)
      WriteStringN(ligne$)
    Else
      If erreur$ <> ""
        ligne$ = RSet$(Str(k), 5, "0") + "#: " + ReplaceString(titre$, "\'", "'", 1, 1)+erreur$
      Else
        ligne$ = RSet$(Str(k), 5, "0") + " : " + ReplaceString(titre$, "\'", "'", 1, 1)+erreur$
      EndIf
      UseFile(6)
      WriteStringN(ligne$)
      UseFile(5)
      WriteStringN(requete$)
    EndIf

    SetGadgetText(#Editor, ligne$)
;    Debug ligne$
    pos = ((k - deb) * 100) / (fin - deb)
    SetGadgetState(#Prog, pos)

    event.l = WindowEvent()
    If event = #PB_EventGadget
      Select EventGadgetID() 
        Case #Btn
          SetGadgetText(#Editor, "Pause...")
          If MessageRequester("Attention", "Etes-vous sûr de vouloir arrêter l'opération ?", #PB_MessageRequester_YesNo) = 6
            cancel = 1
            Break
          EndIf
      EndSelect
    EndIf 

  Next  

  CloseFile(5)
  CloseFile(6)

  DisableGadget(#Deb, 0)
  DisableGadget(#Fin, 0)
  SetGadgetText(#Btn, "Scanner")

  SetCursor_(cur0)
  DestroyCursor_(cur0) 
  DestroyCursor_(cur1)

  If cancel = 1  
    SetGadgetText(#Editor, "Stoppé !")
    MessageRequester("Terminé", "Opération arrêtée !", 0)
  Else
    SetGadgetText(#Editor, "Terminé !")
    MessageRequester("Terminé", "Opération terminée avec succès !", 0)
  EndIf
  SetGadgetState(#Prog, 0)
EndProcedure




;####################################################
;
; Procedure de CallBack
;
;####################################################
Procedure WindowCallback(WindowID, Message, wParam, lParam) 
  Resultat = #PB_ProcessPureBasicEvents 
    If Message = #WM_PAINT
      Debug "OK !!!"
;      SetGadgetText(#Editor, ligne$)
    EndIf
;  EndIf

  ProcedureReturn Resultat 
EndProcedure 




;####################################################
;
; Boucle PRINCIPALE
;
;####################################################
If OpenWindow(#Window, 0, 0, 400, 85, #PB_Window_SystemMenu | #PB_Window_TitleBar | #PB_Window_ScreenCentered | #PB_Window_MinimizeGadget, "Scan HTML 1.1") 
    
  If CreateGadgetList(WindowID()) 
    TextGadget(#LabD, 5, 8, 20, 20, "De :")
    StringGadget(#Deb, 30, 5, 50, 20, "1", #PB_String_Numeric)
    TextGadget(#LabF, 90, 8, 20, 20, "A :")
    StringGadget(#Fin, 108, 5, 50, 20, "2", #PB_String_Numeric)
    TextGadget(#Editor, 5, 35, 390, 20, "Cliquez sur 'Scanner'...") 
    ButtonGadget(#Btn, 320, 5, 75, 21, "Scanner")
    ProgressBarGadget(#Prog, 5, 60, 390, 20, 0, 100, #PB_ProgressBar_Smooth)
  EndIf 

  SetWindowCallback(@WindowCallback()) 

  Repeat 
    EventID.l = WaitWindowEvent() 
    If EventID = #PB_EventGadget    
      Select EventGadgetID() 
        Case #Btn
CallDebugger
          Main()
      EndSelect 
    EndIf        
  Until EventID = #PB_EventCloseWindow 
EndIf 
End
Désolé pour le désordre du code :wink:

Qq d'expérimenté sur les WindowCallback arriverait-il à trouver mon erreur ?

Lorsque on click sur le bouton 'scanner' l'application ne répond presque plus et on parvient difficilement à stopper l'execution car la boucle FOR accapare l'appli :(

HEEELLLLPPP !! :cry:

Merci d'avance à celui ou celle qui aura la patience de se pencher sur mon problème :) [/code]

Posted: Fri Dec 05, 2003 12:55 am
by KarLKoX
Uh ... it is a ENGLISH board, you must go to the french board if you want to talk in french ...
About your problem, search the forum for "DoEvents".

Posted: Fri Dec 05, 2003 7:36 pm
by Dionyzos
yes, I know it, but the only French forum of PureBasc is down since several weeks :cry:

but thank you for the advice :wink:

Do you know a French forum of Purebasic other than this one ? :
http://www.serveurperso.com/~cederavic/IPB/index.php

Thanks
[/url]

Posted: Fri Dec 05, 2003 8:00 pm
by Psychophanta
Dionyzos, have you updated libs?
If not, go to http://www.purebasic.com/beta/ and get it. It solved a problem to another user who had a problem with windowcallback, so perhaps also to you. :)

Heeey; Dionyzos is the ancient Greece wine-God... :)

Posted: Fri Dec 05, 2003 8:23 pm
by KarLKoX
Dionyzos wrote: Do you know a French forum of Purebasic other than this one ? :
http://www.serveurperso.com/~cederavic/IPB/index.php

Thanks
[/url]
Here.

Posted: Fri Dec 05, 2003 9:47 pm
by dontmailme
@KarlKox

What does your sig say ??

I looked at this thread with Google's translator.....

and it said your Sig says....

Who kisses too much puffs out a hair. :!: :?: 8O

Posted: Fri Dec 05, 2003 10:58 pm
by KarLKoX
It is a sentence from a comic very known in France, named Desproges (he died of a cancer) :lol:

(Real sence : who f*** too much eat a hair)

Posted: Sat Dec 06, 2003 12:22 am
by Comtois
but the only French forum of PureBasc is down
it's ok now
All times are UTC+01:00
Page 1 of 1

Powered by phpBB® Forum Software © phpBB Limited