PDA

Visualizza versione completa : Associate the Zodiac with Your Monthly Horoscope in VBA


A.Maurizio
09-05-2017, 17.11.30
Hello to All my name is A.Maurizio
And my question and this: Time ago I was able to create a program entirely in VBA
Using an Excel sheet, where I was looking for the zodiac sign I wanted through a ComboBox, and then pressing a button I called my Horoscope.
Everything using this Code:

###################################

Private Sub Cmd_AvviaOroscopo_Click()
On Error Resume Next
Range("F2").Value = "" & ListBox1.Text
'vSegno = Target
vSegno = Range("J2").Value & ""
Range("F2").Value = "" & Oroscopo(vSegno)
End Sub


And then in the Module I wrote this:


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

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 = "http://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


Now All That Worked Well Up To Some Years ago; Then nothing happens to me since then.
Here is my question and this: There would not be another way to view it all without adopting my Criterion.
Thank you for all the help you want to give me, Sincerely greetings from A.Maurizio

RunDLL
09-05-2017, 20.09.15
Se ti chiami Maurizio perché non scrivi in italiano?

A.Maurizio
10-05-2017, 17.47.18
Ciao RunDLL hai Pienamente ragione a dire che mi chiamo (Maurizio) anche sé a dire il Vero sono di Origine (Spagnola)
Ma ho scritto in Inglese in quanto Google mi dava inizialmente una traduzione del vostro Forum come lingua (Inglese) e poi subito dopo e passato All'italiano, per qui non sapendo bene come coportarmi , ho pensato bene di scrivere in Inglese; Tutto qui.
Ora e in Italiano Grazie infinite per la tua Puntualizzazione.
###############################################

E la mia Domanda e questa : Tempo fa ero riuscito a creare un programma totalmente in VBA
Sfruttando un Foglio di Excel, dove cercavo il Segno zodiacale da me desiderato attraverso una ComboBox, e poi premendo un Tasto Richiamavo il proprio Oroscopo.
Il Tutto utilizzando questo Codice:

Private Sub Cmd_AvviaOroscopo_Click()
On Error Resume Next
Range("F2").Value = "" & ListBox1.Text
'vSegno = Target
vSegno = Range("J2").Value & ""
Range("F2").Value = "" & Oroscopo(vSegno)
End Sub


E poi nel Modulo ho Scritto 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

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 = "http://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 tutto Ciò a funzionato Bene fino a Qualche anno fa; Poi da allora non mi compare più nulla.
Per qui la mia domanda e questa: Non ci sarebbe un altro modo sempre per visualizzare il tutto senza adottare il mio Criterio.
Grazie sin da ora per tutto l'aiuto che vorrete darmi in merito, Sinceri saluti da A.Maurizio

A.Maurizio
10-05-2017, 18.58.35
Ciao RunDLL Preferisco che provi questo Progetto in quanto rispecchia meglio il mio Desiderio sul mio oroscopo del Mese.
Premetto che non funziona comunque , però forse per te e più facile da capire ae dove poter mettere le mani ; Grazie

Alexsandra
10-05-2017, 22.37.47
ci sono un paio di problemi.
1) nel codice della form relativo al tasto "OK" hai messo il codice
Private Sub Cmd_Scrivi_Oroscopo_Click()
Dim mySegno As Long
mySegno = Me.TextBox1.Text '<<< Variare
MsgBox (Oroscopo1(mySegno))
End Sub
ma la variabile mySegno vuole un valore numerico e non una stringa. come pure nel codice del combobox dove metti il codice
Private Sub ComboBox1_Change()
Me.TextBox1.Text = Me.ComboBox1.Text
End Sub
poni il valore del textbox = al valore del combobox in formato testo, ma invece devi usare l'espressione ComboBox1.ListIndex + 1 che identifica il n° di voce scelta, per cui diventa un valore numerico (integer o long) in questo modo non ti rimanda errore nel codice del textbox.
in sostanza il codice del combo diventa
Private Sub ComboBox1_Change()
y = ComboBox1.ListIndex + 1
End Sub
dichiarando la variabile y come Public a inizio modulo.

Il 2° problema è che ...... la pagina che cerchi nella funzione Oroscopo1 .... non esiste più in quel sito è diventata una cosa del genere

h***p://www.donnad.it/in-intimita/oroscopo-e-sogni/oroscopo-settimanale/ariete-21-marzo-20-aprile-44

e non come è inserito nella funzione

h***p://oroscopo.donnad.it/oroscopo/settimanale/segno/s/
a cui aggiungi solo il valore del segno in scelto in forma numerica

A.Maurizio
11-05-2017, 11.44.07
Ciao Alexsandra ascolta : non sò se ho eseguito alla lettara le tue indicazioni , però ho cercato di tradurre il tutto in questo modo :

Private Sub Cmd_Scrivi_Oroscopo_Click()
Dim mySegno As Long
Dim Y As Variant
mySegno = Me.TextBox1.Text '<<< Variare
MsgBox (Oroscopo1(Segno, Y & mySegno))
End Sub

Private Sub ComboBox1_Change()
Y = ComboBox1.ListIndex + 1
Me.TextBox1.Text = Y
End Sub


E per quanto riguardava la Variabile (Y) lo aggiunto in quest'altro modo :

Public Function Oroscopo1(ByVal Segno As Long, ByVal Y As Long) As String


Però non solo continua a non funzionare nulla; Pur cambiano anche l'indirizzo di Pagina HTML.
Però vorrei anche dire che nel mio piccolo anche come ti avevo documentato io nel primo post funzionava benissimo qualche anno fa.

Poi chiaramente come dici tu la pagina in questione e scaduta per qui attualmente non la riconosce più; per qui risulta vuota.
Ahora la mia successiva domanda e questa : Apportate tutte quese modifiche che tu mi hai suggerito .
In più ho anche cambiato indirizzo Html da :

h***p://oroscopo.donnad.it/oroscopo/settimanale/segno/s/


E stato modificato in :

http://www.oggi.it/oroscopo/oroscopo-della-settimana/


Ma continua a non funzionare; Tu al posto mio come riuscireti ad aggirare l'ostacolo in modo tale che possa dinuovo funzionare .
Grazie Sincero da A.Maurizio

Alexsandra
12-05-2017, 14.45.46
No, non va messa così la variabile, non va bene.
Dal codice iniziale che hai postato mi sembra che tu vuoi importare l'oroscopo selezionato e portarlo a video in un box

Per fare questo l'oroscopo deve essere inserito in una tabella (nella pagina web), trovarne il nome o l'indice(della tabella) e rifare la query. Se non si estrapola il nome/indice della tabella importi tutta la pagina, per cui il 1° passo è di scegliere il sito più adatto e trovare il nome della tabella, il resto è facile

A.Maurizio
12-05-2017, 17.14.58
Ciao Alexsandra per cortesia non potresti farmi un Esempio Pratico
anche solo per il primo segno zodiacale , poi una volta capito il tutto me la cavo da solo .
Ma come mi hai spiegato tu non ho capito assolutamente nulla.
Grazie ancora una volta della tua pazienza Saluti da A.Maurizio

A.Maurizio
12-05-2017, 17.58.11
Ciao Alexandra Prova a Guardare questo File e più o meno Simile all'altro solo leggermente Migliorato.
Ma comunque non funziona Più neppure questo.
Grazie da A.Maurizio

Alexsandra
13-05-2017, 00.16.36
allora .....
c'è un problema, se interroghi una pagina web con una query carichi delle tabelle, ma moltissimi siti usano degli script per mostrare a video il testo, che risiede in un DB.

E' meglio usare l'html e guardando il codice sorgente della pagina che riporta l'oroscopo ogni cosa è inclusa in un oggetto che ha anche un nome. Nel ns. caso quello che ci serve ha il nome di article-oroscopo.

cancella (o sposta) tutto il codice che hai nel foglio1 e inserisci questo

Private Sub Cmd_AvviaOroscopo_Click()
Dim y, URL As String
Dim htm As Object

y = Range("J2").Value
URL = "http://www.oroscopi.info/oroscopo-giorno-" & y & ".html"

Set htm = CreateObject("htmlFile")
With CreateObject("msxml2.xmlhttp")
.Open "GET", URL, False
.send
htm.body.innerHTML = .responseText
End With
With htm.getElementById("article-oroscopo")
ThisWorkbook.Worksheets("Foglio1").Range("F2").Value = .innerText
End With

htm.Close
Set htm = Nothing

End Sub

vedrai che così funziona.

NB: devi inserire i segni zodiacali in minuscolo nel range C1:C12 così come sono ti danno un errore.

ti allego anche il file modificato

A.Maurizio
13-05-2017, 09.57.11
Grazie Infinite Alexsandra Oltre a dirti che sei Fantastico in quanto il tuo progetto e Davvero Superlativo.
Devo dirti anche Grazie di Tutto cuore perché senza di te non sarei riuscito a fare nulla.
Perché se e vero che tale progetto lo creato da me , e anche vero che per certi versi mi ero fatto aiutare dai visitatori del Forum PC-Facile che anche a loro devo togliere tanto di cappello.
ma ora a distanza di tempo non sapevo più dove mettere le mani.
Ecco il perché ancora una volta ti devo dire Grazie e Buon Fine Settimana da A.Maurizio

A.Maurizio
14-05-2017, 17.39.26
Ciao Alexsandra sempre che non sia per te un problema di perdita di tempo.
Vorrei chiederti ancora un piccolo Aiutino che è questo :
Nella formazione del tuo oroscopo : che ripeto và benissimo, ho notato che c'é molta distanza trà la Data; Il Seme scelto; e la descrizione del proprio oroscopo.
Per qui la mia domanda e questa: Non c'è la possibilità di ridurre il tutto , cosi chè io possa anche inserire qualche grado in più come formato testo senza stravolgere tutto il tuo lavoro.
Grazie Saluti da A.Maurizio

RunDLL
15-05-2017, 12.49.13
Grazie Infinite Alexsandra Oltre a dirti che sei Fantastico
ehm, fantasticA :timid:

Alexsandra
15-05-2017, 13.54.48
Quegli spazi dipendono dal sito web da cui si scarica l'oroscopo, si può tagliare del testo una volta inserito nella cella. provo a vedere se c'è un altro sito con un codice più pulito, altrimenti ci si deve "arrangiare" ed aggirare il problema elaborando la stringa nella cella

:act: :fiufiu:

Alexsandra
15-05-2017, 15.26.09
prova questo se ti va bene.

A.Maurizio
15-05-2017, 17.33.03
Davero Sconvolgente la Tua Preparazione in Fase di Prorammazione Grazie infinite Saluti Sinceri Ciao e alla prossima da A.Maurizio