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