[VB] Connection HTTP pour récupérer un fichier binaire

Connection HTTP pour récupérer un fichier binaire [VB] - VB/VBA/VBS - Programmation

Marsh Posté le 15-04-2004 à 10:51:46    

Bonjour,
 
Je suis en train de faire un programme VB, qui doit se connecter à un site web, et aspirer une page, ainsi que tous les fichiers qui sont en lien.
 
J'utilise le composant WinSock afin de me connecter en HTTP au serveur.
 
Je récupère la page sans problème. Les images GIF et JPG passent aussi sans problème.
Mais les fichiers PDF sont systématiquement corrompus. Ils font pourtant la bonne taille, mais Acrobat Reader ne peux pas les lire.
Si je les télécharge manuellement, ils sont OK.
 
J'en déduis que ma façon de récupérer les données HTTP n'est pas bonne, et que ça altère les données.
 
J'utilise actuellement ces fonctions : (wscHttp est le nom de mon contrôle WinSock)
 


Private Sub wscHttp_Close()
    Dim strHttpResponseHeader As String
     
    If Not m_bResponseReceived Then
        strHttpResponseHeader = Left$(m_strHttpResponse, _
                                InStr(1, m_strHttpResponse, _
                                vbCrLf & vbCrLf) - 1)
        m_strHttpResponse = Mid(m_strHttpResponse, _
                            InStr(1, m_strHttpResponse, _
                            vbCrLf & vbCrLf) + 4)
        m_bResponseReceived = True
    End If
End Sub
 
Private Sub wscHttp_Connect()
    Dim strHttpRequest As String
     
    strHttpRequest = "GET " & m_strFilePath & " HTTP/1.1" & vbCrLf
    strHttpRequest = strHttpRequest & "Host: " & m_strRemoteHost & vbCrLf
    strHttpRequest = strHttpRequest & "Connection: close" & vbCrLf
    strHttpRequest = strHttpRequest & "Accept: */*" & vbCrLf
    strHttpRequest = strHttpRequest & vbCrLf
    wscHttp.SendData strHttpRequest
End Sub
 
Private Sub wscHttp_DataArrival(ByVal bytesTotal As Long)
    On Error Resume Next
     
    Dim strData As String
     
    wscHttp.GetData strData
    m_strHttpResponse = m_strHttpResponse & strData
End Sub
 
Sub downLoadFile(url As String, lfileType As String)
    Dim objRegExp As RegExp
    Dim objMatch As Match
    Dim colMatches As MatchCollection
     
    url = Replace(url, " ", "%20" )
    Set objRegExp = New RegExp
    objRegExp.Pattern = "(\w+):\/\/([^/:]+)(:\d*)?([^# ]*)"
    objRegExp.IgnoreCase = True
    objRegExp.Global = True
     
    If objRegExp.Test(url) Then
         
        m_strProtocol = objRegExp.Replace(url, "$1" )
        m_strRemoteHost = objRegExp.Replace(url, "$2" )
        m_strRemotePort = objRegExp.Replace(url, "$3" )
        m_strFilePath = objRegExp.Replace(url, "$4" )
         
        If Len(m_strRemotePort) = 0 Then
            m_strRemotePort = "80"
        Else
            m_strRemotePort = Right(m_strRemotePort, Len(m_strRemotePort) - 1)
        End If
         
        fileType = lfileType
         
        m_strHttpResponse = ""
        m_bResponseReceived = False
         
        With wscHttp
            .Close
            .LocalPort = 0
            .Connect m_strRemoteHost, m_strRemotePort
            Do While .State < 8
                DoEvents
            Loop
            If .State = 9 Then
                MsgBox ("Error: Disconnected from server." )
            End If
        End With
    Else
        ' Cas spécial : Lien de type "file" ou "mailto"
        [...]
    End If
     
    Exit Sub
ERR_HANDLER_DWL:
    m_strHttpResponse = ""
End Sub
 
Sub saveFile(content As String, fileName As String, filePath As String)
    If LCase(Left(fileName, 7)) <> "mailto:" Then
        If content <> "m_bytes()" Then
            intFile = FreeFile
            Open filePath & fileName For Binary Access Write As #intFile
            Put #intFile, , content
            Close #intFile
        Else
            intFile = FreeFile
            Open filePath & fileName For Binary Access Write As #intFile
            Put #intFile, , m_bytes
            Close #intFile
        End If
    End If
End Sub


 
Comment pourrais-je modifier ma sauce pour récupérer correctement des données binaires ? J'ai trouvé un tuto, mais j'avoue n'avoir rien compris :(
Deplus, pour les fichiers actuels et la page HTML, est-ce que ça va poser problème si je les télécharge en binaire et non en ASCII comme actuellement ? J'aimerais autant se faire se peu ne pas avoir 36 façons d'accéder aux fichiers.

Reply

Marsh Posté le 15-04-2004 à 10:51:46   

Reply

Marsh Posté le 15-04-2004 à 10:55:46    

excuse mais chuis intéressé par ton code qui récupère le page web, ya moyen que tu le mettes ici ?

Reply

Marsh Posté le 15-04-2004 à 11:02:49    

Si tu veux. Le voilà :
 

Code :
  1. Private m_strRemoteHost As String    'the web server to connect to
  2. Private m_strFilePath As String      'relative path to the file to retrieve
  3. Private m_strHttpResponse As String  'the server response
  4. Private m_bResponseReceived As Boolean
  5. Private m_strRemotePort As String
  6. Private fileType As String
  7. Private currentDoc As String
  8. Private m_bytes() As Byte
  9. Private dom As DOMDocument
  10. Private canRefresh As Boolean
  11. Private language As String * 3
  12. Const siteRoot = "http://gemseas-devl.euro.med.ge.com:8081/egx/"
  14. Private Type t_lp
  15.     login As String * 30
  16.     pass As String * 30
  17.     language As String * 3
  18. End Type
  20. Private Sub Command1_Click()
  21.     Dim tabpro() As String
  22.     Dim i As Integer
  23.     Dim strURL As String
  24.     Dim errMsg As String
  25.     Dim errNb As Integer
  26.     Dim nbDocs As Integer
  27.    
  28.     If codpro.Text = "" Then
  29.         fillCodpro
  30.     End If
  32.     errNb = 0
  33.     nbDocs = 0
  34.     If Len(Trim(codpro.Text)) = 0 Then
  35.         MsgBox ("Please type at least a product code." )
  36.         codpro.Text = ""
  37.         Exit Sub
  38.     End If
  39.     tabpro = Split(UCase(codpro.Text), "," )
  40.     ProgressBar1.Max = UBound(tabpro) + 1
  41.     ProgressBar2.Max = 3
  42.     On Error GoTo ERROR_HANDLER
  43.     If Not auth(errMsg) Then
  44.         errNb = errNb + 1
  45.         MsgBox errMsg
  46.         codpro.Text = ""
  47.         Exit Sub
  48.     End If
  49.     For i = LBound(tabpro) To UBound(tabpro)
  50.         currentDoc = Trim(tabpro(i))
  51.         ProgressBar1.Value = i
  52.         Label5.Caption = currentDoc
  53.         If Trim(currentDoc) <> "" Then
  54.             nbDocs = nbDocs + 1
  55.             downLoadFile siteRoot & "W_PRO_SPR_D_print.asp?CHP:CODPRO=" & currentDoc & "&LOG=" & Text1.Text & "&PASS=" & Text2.Text & "&CODLAN=" & language, "root"
  56.             If fileType = "root" Then
  57.                 If m_strHttpResponse = "404" Then
  58.                     MsgBox "Product " & currentDoc & " doesn't exist."
  59.                     errNb = errNb + 1
  60.                 Else
  61.                     If Not FileExists(App.Path & "\documents\" & currentDoc) Then
  62.                         MkDir App.Path & "\documents\" & currentDoc
  63.                     End If
  64.                     saveFile getLinks(getImages(getCSS(m_strHttpResponse))), currentDoc & ".doc", App.Path & "\documents\"
  65.                 End If
  66.             End If
  67.         End If
  68.     Next
  69. EXIT_LABEL:
  70.     If errNb = 0 Then
  71.         MsgBox "Documents downloaded successfully"
  72.     Else
  73.         MsgBox nbDocs - errNb & " documents downloaded and " & errNb & " aborted on error."
  74.     End If
  75.     codpro.Text = ""
  76.     Exit Sub
  77.        
  78. ERROR_HANDLER:
  79.         If Err.Number = 5 Then
  80.             strURL = strURL & "/"
  81.             Resume 0
  82.         Else
  83.             MsgBox "Error was occurred." & vbCrLf & _
  84.                     "Error #: " & Err.Number & vbCrLf & _
  85.                     "Description: " & Err.Description, vbExclamation
  86.             GoTo EXIT_LABEL
  87.         End If
  88. End Sub
  90. Sub downLoadFile(url As String, lfileType As String)
  91.     Dim objRegExp As RegExp
  92.     Dim objMatch As Match
  93.     Dim colMatches As MatchCollection
  94.    
  95.     url = Replace(url, " ", "%20" )
  96.     Set objRegExp = New RegExp
  97.     objRegExp.Pattern = "(\w+):\/\/([^/:]+)(:\d*)?([^# ]*)"
  98.     objRegExp.IgnoreCase = True
  99.     objRegExp.Global = True
  100.    
  101.     If objRegExp.Test(url) Then
  102.        
  103.         m_strProtocol = objRegExp.Replace(url, "$1" )
  104.         m_strRemoteHost = objRegExp.Replace(url, "$2" )
  105.         m_strRemotePort = objRegExp.Replace(url, "$3" )
  106.         m_strFilePath = objRegExp.Replace(url, "$4" )
  107.        
  108.         If Len(m_strRemotePort) = 0 Then
  109.             m_strRemotePort = "80"
  110.         Else
  111.             m_strRemotePort = Right(m_strRemotePort, Len(m_strRemotePort) - 1)
  112.         End If
  113.        
  114.         fileType = lfileType
  115.        
  116.         m_strHttpResponse = ""
  117.         m_bResponseReceived = False
  118.        
  119.         With wscHttp
  120.             .Close
  121.             .LocalPort = 0
  122.             .Connect m_strRemoteHost, m_strRemotePort
  123.             Do While .State < 8
  124.                 DoEvents
  125.             Loop
  126.             If .State = 9 Then
  127.                 MsgBox ("Error: Disconnected from server." )
  128.             End If
  129.         End With
  130.     Else
  131.         If LCase(Left(url, 7)) <> "mailto:" Then
  132.             On Error GoTo ERR_HANDLER_DWL
  133.             ReDim m_bytes(FileLen(url))
  135.             intFile = FreeFile
  136.             Open url For Binary Access Read As #intFile
  137.             Get #intFile, , m_bytes
  138.             Close #intFile
  139.             m_strHttpResponse = "m_bytes()"
  140.         Else
  141.             m_strHttpResponse = ""
  142.         End If
  143.     End If
  144.    
  145.     Exit Sub
  146. ERR_HANDLER_DWL:
  147.     m_strHttpResponse = ""
  148. End Sub
  150. Private Sub Form_Load()
  151.     Dim intFile As Integer
  152.     Dim lp As t_lp
  153.    
  154.     canRefresh = True
  155.     Load frmSplash
  156.     frmSplash.Show
  157.     frmSplash.Refresh
  158.    
  159.     On Error GoTo noFile
  160.     intFile = FreeFile
  161.     Open App.Path & "\documents\_" For Random As #intFile
  162.     Get #intFile, , lp
  163.     Close #intFile
  164.    
  165.     Text1.Text = Trim(lp.login)
  166.     Text2.Text = Trim(lp.pass)
  167.     language = Trim(lp.language)
  168.     If language = "" Then
  169.         language = "ENG"
  170.     End If
  171.     On Error GoTo 0
  172.    
  173.     Set dom = New DOMDocument
  174.    
  175.     dom.async = False
  176.     If Not dom.Load(siteRoot & "bin/menus.xml.asp?CODLAN=" & language) Then
  177.         MsgBox "Can't contact server, or data error. Can't initialize filters."
  178.         End
  179.     End If
  180.    
  181.     refreshFilters
  182.     Unload frmSplash
  183.     Exit Sub
  184. noFile:
  185.     Close #intFile
  186.     Text1.Text = ""
  187.     Text2.Text = ""
  188. End Sub
  190. Private Sub Form_Unload(Cancel As Integer)
  191.     Dim intFile As Integer
  192.     Dim lp As t_lp
  193.            
  194.     lp.login = Text1.Text
  195.     lp.pass = Text2.Text
  196.     lp.language = language
  197.    
  198.     On Error GoTo noFile
  199.     intFile = FreeFile
  200.     Open App.Path & "\documents\_" For Random As #intFile
  201.     Put #intFile, , lp
  202.     Close #intFile
  203.     End
  204.     Exit Sub
  205. noFile:
  206.     Close #intFile
  207.     MsgBox "Can't save your settings !"
  208.     End
  209. End Sub
  211. Private Sub ImageCombo1_Click()
  212.     refreshFilters
  213. End Sub
  215. Private Sub ImageCombo2_Click()
  216.     refreshFilters
  217. End Sub
  219. Private Sub ImageCombo3_Click()
  220.     refreshFilters
  221. End Sub
  223. Private Sub ImageCombo4_Click()
  224.     If ImageCombo4.SelectedItem.Key <> "" Then
  225.         canRefresh = True
  226.         Load frmSplash
  227.         frmSplash.Show
  228.         frmSplash.Refresh
  229.        
  230.         Set dom = New DOMDocument
  231.        
  232.         dom.async = False
  233.         If Not dom.Load(siteRoot & "bin/menus.xml.asp?CODLAN=" & ImageCombo4.SelectedItem.Key) Then
  234.             MsgBox "Can't contact server, or data error. Can't initialize filters."
  235.             End
  236.         End If
  237.    
  238.         Unload frmSplash
  239.     End If
  240.     refreshFilters
  241. End Sub
  243. Private Sub ImageCombo5_Click()
  244.     refreshFilters
  245. End Sub
  247. Private Sub wscHttp_Close()
  248.     Dim strHttpResponseHeader As String
  249.    
  250.     If Not m_bResponseReceived Then
  251.         strHttpResponseHeader = Left$(m_strHttpResponse, _
  252.                                 InStr(1, m_strHttpResponse, _
  253.                                 vbCrLf & vbCrLf) - 1)
  254.         m_strHttpResponse = Mid(m_strHttpResponse, _
  255.                             InStr(1, m_strHttpResponse, _
  256.                             vbCrLf & vbCrLf) + 4)
  257.         m_bResponseReceived = True
  258.     End If
  259. End Sub
  261. Private Sub wscHttp_Connect()
  262.     Dim strHttpRequest As String
  263.    
  264.     strHttpRequest = "GET " & m_strFilePath & " HTTP/1.1" & vbCrLf
  265.     strHttpRequest = strHttpRequest & "Host: " & m_strRemoteHost & vbCrLf
  266.     strHttpRequest = strHttpRequest & "Connection: close" & vbCrLf
  267.     strHttpRequest = strHttpRequest & "Accept: */*" & vbCrLf
  268.     strHttpRequest = strHttpRequest & vbCrLf
  269.     wscHttp.SendData strHttpRequest
  270. End Sub
  272. Private Sub wscHttp_DataArrival(ByVal bytesTotal As Long)
  273.     On Error Resume Next
  274.    
  275.     Dim strData As String
  276.    
  277.     wscHttp.GetData strData
  278.     m_strHttpResponse = m_strHttpResponse & strData
  279. End Sub
  281. Sub saveFile(content As String, fileName As String, filePath As String)
  282.     If LCase(Left(fileName, 7)) <> "mailto:" Then
  283.         If content <> "m_bytes()" Then
  284.             intFile = FreeFile
  285.             Open filePath & fileName For Binary Access Write As #intFile
  286.             Put #intFile, , content
  287.             Close #intFile
  288.         Else
  289.             intFile = FreeFile
  290.             Open filePath & fileName For Binary Access Write As #intFile
  291.             Put #intFile, , m_bytes
  292.             Close #intFile
  293.         End If
  294.     End If
  295. End Sub
  297. Function getImages(ByRef document As String)
  298.     Dim objRegExp As RegExp
  299.     Dim objMatch As Match
  300.     Dim colMatches As MatchCollection
  301.     Dim myDoc As String
  302.     Dim myDoc2 As String
  303.     Dim imgFileName As String
  304.     Dim j As Integer
  305.        
  306.     ProgressBar2.Value = 2
  307.     Label6.Caption = "Pictures"
  308.    
  309.     myDoc = document
  310.     myDoc2 = document
  311.     Set objRegExp = New RegExp
  312.     objRegExp.Pattern = "(<img[^>]*?src=['|""])([^'|^""]+?)(['|""].*?> )"
  313.     objRegExp.IgnoreCase = True
  314.     objRegExp.Global = True
  315.    
  316.     If (objRegExp.Test(myDoc2)) Then
  317.         Set colMatches = objRegExp.Execute(myDoc2)
  318.         j = 0
  319.         ProgressBar3.Max = colMatches.Count
  320.         For Each objMatch In colMatches
  321.             imgFileName = Right(objRegExp.Replace(objMatch.Value, "$2" ), Len(objRegExp.Replace(objMatch.Value, "$2" )) - InStrRev(Replace(objRegExp.Replace(objMatch.Value, "$2" ), "\", "/" ), "/" ))
  322.             j = j + 1
  323.             ProgressBar3.Value = j
  324.             Label7.Caption = imgFileName
  325.             frmMain.Refresh
  326.             myDoc = Replace(myDoc, objMatch.Value, objRegExp.Replace(objMatch.Value, "$1" & currentDoc & "\" & imgFileName & "$3" ), 1, 1)
  327.             downLoadFile objRegExp.Replace(objMatch.Value, "$2" ), "img"
  328.             saveFile m_strHttpResponse, imgFileName, App.Path & "\documents\" & currentDoc & "\"
  329.         Next
  330.     End If
  331.     getImages = myDoc
  332. End Function
  334. Function getCSS(ByVal document As String) As String
  335.     Dim objRegExp As RegExp
  336.     Dim objMatch As Match
  337.     Dim colMatches As MatchCollection
  338.     Dim myDoc As String
  339.     Dim myDoc2 As String
  340.     Dim cssFileName As String
  341.     Dim j As Integer
  342.    
  343.     ProgressBar2.Value = 1
  344.     Label6.Caption = "Layout"
  345.    
  346.     myDoc = document
  347.     myDoc2 = document
  348.     Set objRegExp = New RegExp
  349.     objRegExp.Pattern = "(<link[^>]*?href=['|""])([^'|^""]+?)(['|""].*?> )"
  350.     objRegExp.IgnoreCase = True
  351.     objRegExp.Global = True
  352.    
  353.     If (objRegExp.Test(myDoc2)) Then
  354.         Set colMatches = objRegExp.Execute(myDoc2)
  355.         j = 0
  356.         ProgressBar3.Max = colMatches.Count
  357.         For Each objMatch In colMatches
  358.             cssFileName = Right(objRegExp.Replace(objMatch.Value, "$2" ), Len(objRegExp.Replace(objMatch.Value, "$2" )) - InStrRev(Replace(objRegExp.Replace(objMatch.Value, "$2" ), "\", "/" ), "/" ))
  359.             j = j + 1
  360.             ProgressBar3.Value = j
  361.             Label7.Caption = cssFileName
  362.             frmMain.Refresh
  363.             myDoc = Replace(myDoc, objMatch.Value, objRegExp.Replace(objMatch.Value, "$1" & currentDoc & "\" & cssFileName & "$3" ), 1, 1)
  364.             downLoadFile objRegExp.Replace(objMatch.Value, "$2" ), "css"
  365.             saveFile m_strHttpResponse, cssFileName, App.Path & "\documents\" & currentDoc & "\"
  366.         Next
  367.     End If
  368.     getCSS = myDoc
  369. End Function
  371. Function getLinks(ByRef document As String)
  372.     Dim objRegExp As RegExp
  373.     Dim objMatch As Match
  374.     Dim colMatches As MatchCollection
  375.     Dim myDoc As String
  376.     Dim myDoc2 As String
  377.     Dim linkFileName As String
  378.     Dim j As Integer
  379.    
  380.     ProgressBar2.Value = 3
  381.     Label6.Caption = "Documents"
  382.    
  383.     myDoc = document
  384.     myDoc2 = document
  385.     Set objRegExp = New RegExp
  386.     objRegExp.Pattern = "(<a[^>]*?href=['|""])([^'|^""]+?)(['|""].*?> )"
  387.     objRegExp.IgnoreCase = True
  388.     objRegExp.Global = True
  389.     If (objRegExp.Test(myDoc2)) Then
  390.         Set colMatches = objRegExp.Execute(myDoc2)
  391.         j = 0
  392.         ProgressBar3.Max = colMatches.Count
  393.         For Each objMatch In colMatches
  394.             linkFileName = Right(objRegExp.Replace(objMatch.Value, "$2" ), Len(objRegExp.Replace(objMatch.Value, "$2" )) - InStrRev(Replace(objRegExp.Replace(objMatch.Value, "$2" ), "\", "/" ), "/" ))
  395.             j = j + 1
  396.             ProgressBar3.Value = j
  397.             Label7.Caption = linkFileName
  398.             frmMain.Refresh
  399.             myDoc = Replace(myDoc, objMatch.Value, objRegExp.Replace(objMatch.Value, "$1" & currentDoc & "\" & linkFileName & "$3" ), 1, 1)
  400.             downLoadFile objRegExp.Replace(objMatch.Value, "$2" ), "link"
  401.             saveFile m_strHttpResponse, linkFileName, App.Path & "\documents\" & currentDoc & "\"
  402.         Next
  403.     End If
  404.     getLinks = myDoc
  405. End Function
  407. Function auth(ByRef errMsg As String) As Boolean
  408.     downLoadFile siteRoot & "verifLogin.asp?log=" & Text1.Text & "&pass=" & Text2.Text, ""
  409.     errMsg = m_strHttpResponse
  410.     If errMsg = "OK" Then
  411.         auth = True
  412.     Else
  413.         auth = False
  414.     End If
  415. End Function
  417. Public Function FileExists(ByVal strFileName As String) As Boolean
  418.     Dim dtm As Date
  419. On Error GoTo ErrHandler
  420.     dtm = FileSystem.FileDateTime(strFileName)
  421.     FileExists = True
  422.     Exit Function
  423. ErrHandler:
  424.     FileExists = False
  425. End Function
  427. Sub refreshFilters()
  428.     Dim fam As String
  429.     Dim sfa As String
  430.     Dim ssf As String
  431.     Dim bt As String
  432.    
  433.     If canRefresh Then
  434.         canRefresh = False
  435.         If ImageCombo1.SelLength <> 0 Then
  436.             fam = ImageCombo1.SelectedItem.Key
  437.         End If
  438.         If ImageCombo2.SelLength <> 0 Then
  439.             sfa = ImageCombo2.SelectedItem.Key
  440.         End If
  441.         If ImageCombo3.SelLength <> 0 Then
  442.             ssf = ImageCombo3.SelectedItem.Key
  443.         End If
  444.         If ImageCombo4.SelLength <> 0 Then
  445.             language = ImageCombo4.SelectedItem.Key
  446.         End If
  447.         If ImageCombo5.SelLength <> 0 Then
  448.             bt = ImageCombo5.SelectedItem.Key
  449.         End If
  450.    
  451.         ImageCombo1.ComboItems.Clear
  452.         ImageCombo2.ComboItems.Clear
  453.         ImageCombo3.ComboItems.Clear
  454.         ImageCombo4.ComboItems.Clear
  455.         ImageCombo5.ComboItems.Clear
  456.        
  457.         ' Families
  458.         fillFamily fam, sfa, ssf
  459.         fillBT bt
  460.         fillLanguage language
  461.        
  462.         ImageCombo1.Refresh
  463.         ImageCombo2.Refresh
  464.         ImageCombo3.Refresh
  465.         ImageCombo4.Refresh
  466.         ImageCombo5.Refresh
  467.        
  468.         canRefresh = True
  469.     End If
  470. End Sub
  472. Sub fillFamily(fam As String, sfa As String, ssf As String)
  473.     Dim myItem As ComboItem
  474.     Dim el
  475.     Dim curItem As Integer
  476.    
  477.     curItem = 1
  478.     Set myItem = ImageCombo1.ComboItems.Add(, "", "All" )
  479.     myItem.Selected = True
  480.     For Each el In dom.selectSingleNode("interface/families" ).childNodes
  481.         curItem = curItem + 1
  482.         If el.tagName = "fam" Then
  483.             Set myItem = ImageCombo1.ComboItems.Add(, el.Attributes(0).Value, el.Attributes(1).Value)
  484.             If myItem.Key = fam Then
  485.                 myItem.Selected = True
  486.             End If
  487.         End If
  488.     Next
  489.    
  490.     fillSubFamily fam, sfa, ssf
  491. End Sub
  493. Sub fillSubFamily(fam As String, sfa As String, ssf As String)
  494.     Dim myItem As ComboItem
  495.     Dim el
  496.     Dim el2
  497.     Dim curItem As Integer
  498.    
  499.     curItem = 1
  500.     Set myItem = ImageCombo2.ComboItems.Add(, "", "All" )
  501.     myItem.Selected = True
  502.    
  503.     If fam <> "" Then
  504.         For Each el In dom.selectSingleNode("interface/families" ).childNodes
  505.             If el.tagName = "fam" Then
  506.                 If el.Attributes(0).Value = fam Then
  507.                     For Each el2 In el.childNodes
  508.                         curItem = curItem + 1
  509.                         If el2.tagName = "sfa" Then
  510.                             Set myItem = ImageCombo2.ComboItems.Add(, el2.Attributes(0).Value, el2.Attributes(1).Value)
  511.                             If myItem.Key = sfa Then
  512.                                 myItem.Selected = True
  513.                             End If
  514.                         End If
  515.                     Next
  516.                    
  517.                 End If
  518.             End If
  519.         Next
  520.     End If
  521.    
  522.     fillSubSubFamily fam, sfa, ssf
  523. End Sub
  525. Sub fillSubSubFamily(fam As String, sfa As String, ssf As String)
  526.     Dim myItem As ComboItem
  527.     Dim el
  528.     Dim el2
  529.     Dim el3
  530.     Dim curItem As Integer
  531.    
  532.     curItem = 1
  533.     Set myItem = ImageCombo3.ComboItems.Add(, "", "All" )
  534.     myItem.Selected = True
  535.    
  536.     If fam <> "" And sfa <> "" Then
  537.         For Each el In dom.selectSingleNode("interface/families" ).childNodes
  538.             If el.tagName = "fam" Then
  539.                 If el.Attributes(0).Value = fam Then
  540.                     For Each el2 In el.childNodes
  541.                         If el2.tagName = "sfa" Then
  542.                             If el2.Attributes(0).Value = sfa Then
  543.                                 For Each el3 In el2.childNodes
  544.                                     curItem = curItem + 1
  545.                                     If el3.tagName = "ssf" Then
  546.                                         Set myItem = ImageCombo3.ComboItems.Add(, el3.Attributes(0).Value, el3.Attributes(1).Value)
  547.                                         If myItem.Key = ssf Then
  548.                                             myItem.Selected = True
  549.                                         End If
  550.                                     End If
  551.                                 Next
  552.                             End If
  553.                         End If
  554.                     Next
  555.                 End If
  556.             End If
  557.         Next
  558.     End If
  559. End Sub
  561. Sub fillLanguage(language As String)
  562.     Dim myItem As ComboItem
  563.     Dim el
  564.     Dim curItem As Integer
  565.    
  566.     curItem = 1
  567.     For Each el In dom.selectSingleNode("interface/languages" ).childNodes
  568.         curItem = curItem + 1
  569.         If el.tagName = "lan" Then
  570.             Set myItem = ImageCombo4.ComboItems.Add(, el.Attributes(0).Value, el.Attributes(1).Value)
  571.             If myItem.Key = language Then
  572.                 myItem.Selected = True
  573.             End If
  574.         End If
  575.     Next
  576. End Sub
  578. Sub fillBT(bt As String)
  579.     Dim myItem As ComboItem
  580.     Dim el
  581.     Dim curItem As Integer
  582.    
  583.     curItem = 1
  584.     Set myItem = ImageCombo5.ComboItems.Add(, "", "All" )
  585.     myItem.Selected = True
  586.     For Each el In dom.selectSingleNode("interface/bts" ).childNodes
  587.         curItem = curItem + 1
  588.         If el.tagName = "bt" Then
  589.             Set myItem = ImageCombo5.ComboItems.Add(, el.Attributes(0).Value, el.Attributes(1).Value)
  590.             If myItem.Key = bt Then
  591.                 myItem.Selected = True
  592.             End If
  593.         End If
  594.     Next
  595. End Sub
  597. Sub fillCodpro()
  598.     Dim inet As InternetExplorer
  599.    
  600.     Set inet = New InternetExplorer
  601.     inet.Visible = False
  602.     inet.Navigate siteRoot & "bin/codpros.asp?FAM=" & ImageCombo1.SelectedItem.Key & "&SFA=" & ImageCombo2.SelectedItem.Key & "&SSF=" & ImageCombo3.SelectedItem.Key & "&BT=" & ImageCombo5.SelectedItem.Key
  603.     Do While Not inet.readyState = READYSTATE_COMPLETE
  604.         DoEvents
  605.     Loop
  606.     codpro.Text = inet.document.body.innerHTML
  607. End Sub


 
PS: j'ai laissé les url et tout, m'en fout c'est des adresses internes ;)
 
PS²: Par contre, c'est loin de faire ce que tu veux à mon avis, ce programme sert à télécharger des documents à partir d'une appli intranet, donc c'est pas du tout gééraliste, à mon avis tu ne pourras pas en faire grand chose ;)


Message édité par Arjuna le 15-04-2004 à 11:03:56
Reply

Marsh Posté le 15-04-2004 à 11:04:30    

je verrais bien merci quand même :)

Reply

Marsh Posté le 15-04-2004 à 11:29:32    

Pour ceux que ça intéresse, c'est ce tuto que j'avais suivie.
http://www.vbip.com/winsock/index.asp
 
Seul problème, c'est que l'accès à des fichiers binaires vient après un tas de trucs dont je n'ai pas besoin, et le code est du coup trop complexe pour que j'y comprenne quoi que ce soit :sweat:
 
Par contre, ce tuto est vraiment très bien et couvre un peu tout les domaines (www, ftp, smtp, application distribuée, chat, etc.)

Reply

Marsh Posté le 15-04-2004 à 14:11:25    

Du nouveau.
 
J'ai comparé les deux fichiers (le bon et le mauvais)
 
C'est encore plus bizarre que ça...
=> Ils sont rigoureusement identiques SAUF que celui qui est foireux s'arrête d'un coup, à 301 886 octets.
La taille ne semble pas "ronde", donc j'en déduit que c'est pas un problème au niveau de la taille de la chaîne de caractère.
 
En regardant en Hexa, je pensais tomber sur un caractère à la con, style EOF, qui aurait pu foutre en l'air la représentation des données dans une chaîne de caractères, mais même pas !
 
En effet, j'ai à la fin du fichier foireux la suite :
 
2a 45 __ (ça s'arrête là)
 
Alors que dans le fichier original, j'ai :
 
2a 45 4a 3b 27
 
=> Ce ne sont même pas des caractères spéciaux, ça correspond à la chaîne " *EJ:' "
 
:sweat:
 
Là je sèche vraiment, je ne comprends pas ce qui fait que ça ne fonctionne pas :cry:


Message édité par Arjuna le 15-04-2004 à 14:11:39
Reply

Marsh Posté le 15-04-2004 à 14:53:53    

Merci pour votre aide :sweat:
 
Bon, j'ai résolu mon problème (mais alors là il va falloir m'expliquer comment ! :lol:)
 
En fait, j'ai juste rajouté : "vbString" en paramètre de getData :
 
    wscHttp.GetData strData, vbString
 
Et maintenant le fichier se charge correctement :heink:

Reply

Marsh Posté le 15-04-2004 à 16:28:06    

Bon, maintenant j'ai un autre problème :heink:
 
Private dom As DOMDocument
 
Function machin()
    Set dom = New DOMDocument
    dom.async = False
    If Not dom.Load(siteRoot & "bin/menus.xml.asp?CODLAN=" & language) Then
        MsgBox "Can't contact server, or data error. Can't initialize filters."
        End
    End If
End Function
 
Premier passage dans la fonction, ça passe.
Second passage, systématiquement j'ai une erreur comme quoi la source est indisponible. L'erreur est instantanée.
 
J'ai essayé de trouver un .Close ou autre pour forcer le dom à bien se vider avant d'en charger une nouvelle couche, mais j'ai pas trouvé. J'ai donc tenté de faire un set dom = Nothing avant l'affectation du constructeur, mais toujours la même donne, même erreur.
 
De quoi ça peut venir :??:
 
J'utilise MSXML 3.0

Reply

Marsh Posté le 16-04-2004 à 11:04:56    

Vous êtes tous morts ou quoi ? :cry:

Reply

Marsh Posté le 21-01-2005 à 15:01:27    

j'ai à peu prés le même problème que le tien, je voudrai me connecter à un site et ensuite y envoyer une requête qui va me retourner les données dont j'ai besoin. Mais je n'ai pas accés à la base de données du site et le site est fait en ASP tandis que mon application est faite en VBA. je ne sais pas si tu as une idée de comment je pourrai le faire. merci

Reply

Marsh Posté le 21-01-2005 à 15:01:27   

Reply

Marsh Posté le 24-01-2005 à 14:37:44    

Alors, tout bête :
 
Ta page ASP doit retourner un flux HTML de ce type : (ou un XML à la limite)
 

Code :
  1. <html>
  2.    <head>NE PAS VENIR ICI !</head>
  3.    <body>
  4.       <p>Si vous voyez ce texte, c'est que vous n'avez rien à faire sur cette page. Ouste ! On dégage ! <a href="/default.asp">Foutez-moi le camp de là avant que je m'énerve !</a></p>
  5.    <div style="display: none" id="data1">val1;val2;val3<br/>val4;val5;val6<br/></div>
  6.    <div style="display: none" id="data2">val1;val2;val3<br/>val4;val5;val6<br/></div>
  7.    </body>
  8. </html>


(des DIV nommées avec ID, contenant un flux CSV, avec retour à la ligne sous forme de <br/> )
 
Ensuite, dans ta macro, tu lies "Internet Controls"
 
Puis ta macro :
 

Code :
  1. Sub getData()
  2.     Dim ie As New InternetExplorer
  3.     Dim data1 As String
  4.     Dim data2 As String
  5.    
  6.     Dim arrData() As String
  7.     Dim arrLineData() As String
  8.     Dim val1 As String
  9.     Dim val2 As String
  10.     Dim val3 As String
  11.    
  12.     Dim i As Integer
  13.    
  14.     ie.Visible = False
  15.     ie.Navigate "http://server/getdata.asp?param1=" & param1
  16.     Do While Not ie.ReadyState = READYSTATE_COMPLETE
  17.         DoEvents
  18.     Loop
  19.     data1 = ie.Document.getElementById("data1" ).innerHTML
  20.     data2 = ie.Document.getElementById("data1" ).innerHTML
  21.     ie.Quit
  22.     Set ie = Nothing
  23.    
  24.     arrData = Split(data1, "<br/>" )
  25.     For i = LBound(arrData) To UBound(arrData)
  26.         arrLineData = Split(arrData(i), ";" )
  27.         val1 = arrLineData(0)
  28.         val2 = arrLineData(1)
  29.         val3 = arrLineData(2)
  30.         'Do something with va1, val2 and val3
  31.     Next
  32.    
  33.     arrData = Split(data2, "<br/>" )
  34.     For i = LBound(arrData) To UBound(arrData)
  35.         arrLineData = Split(arrData(i), ";" )
  36.         val1 = arrLineData(0)
  37.         val2 = arrLineData(1)
  38.         val3 = arrLineData(2)
  39.         'Do something with va1, val2 and val3
  40.     Next
  41. End Sub


 
A quelques bugs prêt (pas testé ;)) ça doit marcher :)

Reply

Marsh Posté le 24-01-2005 à 16:07:01    

peux-tu m'expliquer ce qui fait ce code stp!!!


---------------
bou
Reply

Marsh Posté le 24-01-2005 à 16:15:32    

Il ouvre IE dans une fenêtre invisible.
Il va ensuite sur la page ASP dont tu as besoin (n'oublie pas de passer les éventuels paramètres en QueryString).
Ensuite, il attend que la page aie fini de charger.
 
Et quand c'est fini, il recherche les deux blocs de données (dans mon exemple) puis les parcours ligne pas ligne (le premier split) puis valeur par valeur (le second split imbriqué dans la boucle). Une fois que tu as tes valeurs, tu en fait ce que tu veux :)

Reply

Marsh Posté le 24-01-2005 à 16:29:19    

je pense que tu vas mieux comprendre si tu jetes un coup d'oeil sur le site à l'adresse suivante:
http://69.159.241.96/alliancewebse [...] ysFilter=0


---------------
bou
Reply

Marsh Posté le 24-01-2005 à 16:34:37    

Nope, je comprends pas mieu :D
 
Mais bon, ça doit toujours fonctionner avec mon système, sauf que là, c'est pas du VBA, mais plutôt du VB.NET, ce qui est littéralement différent.
 
C'est un aspect que je n'ai pas regardé, mais dans le namespace System.Web, il y a tout ce qu'il faut pour communiquer en HTTP avec d'autres sites. Creuse de ce côté là.
 
Ensuite, t'auras plus qu'à parser le HTML reçu afin de retrouver les infos dont tu as besoin.

Reply

Marsh Posté le 24-01-2005 à 16:43:23    

merci quand même


---------------
bou
Reply

Marsh Posté le 24-01-2005 à 19:29:39    

si tu as un exemple déjà fait, ça pourrait m'aider beaucoup


---------------
bou
Reply

Marsh Posté le 24-01-2005 à 19:50:57    

avec .NET nope.

Reply

Marsh Posté le 24-01-2005 à 19:51:36    

Mais crée un autre topic dans la cat "C#/Managed", il y sera plus à sa place.

Reply

Marsh Posté le 24-01-2005 à 19:58:20    

je ne comprend pas qu'est ce que tu veux dire?


---------------
bou
Reply

Marsh Posté le 24-01-2005 à 20:04:58    

Ben parceque vu que tes pages sont en ASPX, j'en déduit que ça n'a rien à voir avec du VBA, ni même du VB, mais du VB.NET
 
Hors, le VB.NET, c'est ni plus ni moins que du C# avec une syntaxe différente. Le fonctionnement est le même, et les librairies sont aussi les mêmes.
 
Pour cette raison, si tu veux des réponses à ton problème, il faut poster ton problème dans C#/Managed (en précisant qu'il s'agit de VB.NET) et non ici, où tu as moins de chances de trouver une personne qui saura répondre à ton problème.

Reply

Marsh Posté le 24-01-2005 à 20:11:29    

non, mais mon application est en VBA et non en VB.NET


---------------
bou
Reply

Marsh Posté le 24-01-2005 à 20:14:42    

Comprends rien.
 
Le site que tu m'as montré, c'est celui sur lequel tu dois retrouver les infos ?
 
Ben le code que je t'ai pondu marche, suffit de l'adapter :
-> Tu peux récupérer les éléments du SELECT afin de simuler le choix d'un site, puis après, en parcourant le tableau retourné, tu trouveras sans problème les données.
 
ie.Body.Document, c'est l'objet "document" que tu as en JavaScript à l'intérieur d'une page sous Internet Explorer. Tu peux donc utiliser toutes les fonctions JS que tu veux (style "getElementById()", et accéder à tous les éléments HTML depuis ton script VBA).

Reply

Marsh Posté le 24-01-2005 à 20:16:39    

ben c'est la requête que je ne sais pas comment faire.
désolée je ne connais pas VBA beaucoup...


---------------
bou
Reply

Marsh Posté le 24-01-2005 à 20:41:25    

y'a pas de requête

Reply

Marsh Posté le 24-01-2005 à 20:49:19    

alors peux-tu me dire comment le faire stp. j'en ai aucune  idée


---------------
bou
Reply

Marsh Posté le 24-01-2005 à 20:52:32    

ben je peux pas tout t'expliquer. pour voir le fonctionnement avec un formulaire, tu peux regarder ça :
 
http://forum.hardware.fr/hardwaref [...] 7024-1.htm

Reply

Marsh Posté le 24-01-2005 à 21:04:49    

non, je ça ne marche pas, mais si tu peux me faire un petit code qui pourrait m'aider ça sera vraiment gentil.
merciiiii


---------------
bou
Reply

Marsh Posté le    

Reply

Sujets relatifs:

Leave a Replay

Make sure you enter the(*)required information where indicate.HTML code is not allowed