|
Login
  • Page:
  • 1

TOPIC: Come Risolvere Questo Problema sula Pagina HTML

Come Risolvere Questo Problema sula Pagina HTML 6 years 3 months ago #8946

  • Maury1704
  • Maury1704's Avatar
  • OFFLINE
  • Expert Boarder
  • Posts: 91
  • Karma: 0
Ciao a Tutti mi chiamo Maurizio , vi scrivo in quanto vorrei risolvere questo Problema con Excel .
Il Problema in questione e questo :
Io essendo un Autodidatta , una Brava persona tempo fa mi Aveva Dato questo Listato , Per Estrapolare L'oroscopo
da una Pagina HTML e inserire il tutto in una Cella del mio Foglio di Lavoro .
Ora questo Listato Funziona Benissimo , però mi da soltanto il nome del Segno Zodiacale e il suo Oroscopo Mensile ,
mentre io verrei anche che mi Potesse comparire più o meno in questo modo :

Ariete
21 marzo - 20 aprile
e poi la descrizione Dell'oroscopo Richiesto .

Il Listato che questa Brava Persona mi diede e questo :

Public Function Oroscopo(ByVal vSegno As Variant) As String

Dim sSource As String
Dim aSegni As Variant
Dim j As Integer
Dim sSegno As String
Dim nSegno As Integer
Dim sOroscopo As String
Dim Http1 As Object
Dim sUrl As String
Dim nAtH2 As Long
Dim nAtP As Long
Dim nAtCP As Long

On Error GoTo Oroscopo_Error

Application.ScreenUpdating = False

aSegni = Split("Ariete Toro Gemelli Cancro Leone Vergine Bilancia Scorpione Sagittario Capricorno Acquario Pesci")
If IsNumeric(vSegno) Then
nSegno = vSegno
sSegno = aSegni(nSegno - 1)
Else
sSegno = vSegno
For j = 0 To 11
If aSegni(j) = sSegno Then
nSegno = j + 1
End If
Next
End If
Set Http1 = CreateObject("MSXML2.XMLHTTP")

sUrl = "oroscopo.donnad.it/oroscopo/settimanale/segno/s/" & nSegno
Http1.Open "GET", sUrl, False
Http1.Send
sSource = Http1.responseText
Set Http1 = Nothing

nAtH2 = InStr(1, sSource, "</h2>", vbTextCompare)
nAtP = InStr(nAtH2, sSource, "<p>", vbTextCompare) + 3
nAtCP = InStr(nAtP, sSource, "</p>", vbTextCompare) - nAtP
sOroscopo = VBA.Mid(sSource, nAtP, nAtCP)
sOroscopo = sSegno & vbCrLf & VBA.Trim(Replace(Replace(Replace(sOroscopo, vbLf, ""), vbCr, ""), vbTab, ""))

Oroscopo_Error:
If Err.Number <> 0 Then
Set Http1 = Nothing
sOroscopo = "Non disponibile!"
End If

Oroscopo = sOroscopo

End Function

Ora Io chiedo a voi in Base a questo listato come e cosa si può aggiungere per Ottenere questi tipi di informazioni !
Io non né sono Capace ecco il motivo per qui chiedo a voi queste cose : Grazie per tutto l'aiuto che riuscirete a Darmi
Sinceri Saluti da Maurizio
The administrator has disabled public write access.
  • Page:
  • 1
Time to create page: 0.494 seconds