Grabber de rfcs

Télécharger le projet
Commenter

Description

ce ptit code fait, en 15 minutes permet de grabber les RFCs a partir du site www.faqs.org

Source / Exemple : 


' 1 module :
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
   ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
   
Private Const ERROR_SUCCESS As Long = 0

Public Function DownloadFile(ByVal sURL As String, ByVal sLocalFile As String) As Boolean
   Dim lngRetVal As Long
   
   ' API ui permet de telecharger un fichier
   DownloadFile = URLDownloadToFile(0&, sURL, sLocalFile, 0&, 0&) = ERROR_SUCCESS
End Function

' 1 formulaire avec :
' 2 boutons pause,grab (CmdPause,CmdGrab)
' 2 champs texte (TextDebut,TextFin)
' 1 champs texte (TextCheminDest)

Dim stop_demande As Boolean

Private Sub CmdPause_Click()
    stop_demande = True
    
    ' empeche de recliquer sur le bouton
    CmdPause.Enabled = False
    
    ' reactive le bouton grab
    CmdGrab.Enabled = True
End Sub

Private Sub Form_Load()
    stop_demande = False
    CmdPause.Enabled = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
    End
End Sub

Private Sub CmdGrab_Click()
    Dim result, NumRfc
    
    ' empeche de recliquer sur le bouton
    CmdGrab.Enabled = False
    
    ' active le bouton pause
    CmdPause.Enabled = True
    
    ' desactive la pause
    stop_demande = False
    
    ' chemin destination
    DossierDest = TextCheminDest.Text
    If Right(DossierDest, 1) <> "\" Then DossierDest = DossierDest & "\"
    
    ' si le chemin n'existe pas, on le créer
    If StrComp(Dir(DossierDest, vbDirectory), "") = 0 Then MkDir (DossierDest)
    
    ' derniere rfc a grabber
    NbRfcs = TextFin.Text
    
    ' TextDebut.Text = 1ere rfc a grabber
    
    For NumRfc = TextDebut.Text To NbRfcs
        
        ' indique l'avancemement des telechargements
        LabelFais.Caption = NumRfc & " / " & NbRfcs
        
        ' url de la rfc à telecharger
        Url = "http://www.faqs.org/rfcs/rfc" & NumRfc & ".html"
        
        ' telecharge la rfc, renvois faux si le fichier n'existe pas
        result = DownloadFile(Url, DossierDest & "rfc" & NumRfc & ".html")
        
        ' debugage
        Debug.Print Url & " --> " & DossierDest & " : " & result
        
        ' impose une petite pause a chaque fois, pour ne pas utiliser 100% du proc
        temps = Timer
        While Timer - temps < 0.1
            DoEvents
        Wend
        
        ' met a jour la 1ere rfc, au cas ou on fais pause et que l'on recommence
        TextDebut.Text = NumRfc
        
        ' stop la boucle si on presse "pause"
        If stop_demande Then Exit For
    Next
End Sub

Conclusion :


si besoin d'aide, posez vos questions
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (cs_monstermax)