Importare dati da pagina WEB

[draleo]

E’ possibile importare in Excel (o in qualche altra parte del disco C) dati da pagine WEB ?
Mi spiego meglio:
in un foglio Excel, colonna A, ho una lunga serie di collegamenti a pagine WEB
es : http://ecc ecc
cliccandoci sopra viene visualizzata la pagina
Io avrei necessità di copiare le pagine WEB (in realtà mi interessano solo le immagini jpg della pagina, ma, al limite potrei importare tutta la pagina e poi cancellare tutto quello che NON è immagine JPG ) e salvarle da qualche parte del disco rigido. Sono centinaia di indirizzi e farlo a mano ,singolarmente, è da escludere.
Se si potesse realizzare una procedura in excel che in automatico, apra le singole pagine e le salvi (oppure le copi) da qualche parte, allora la cosa potrebbe essere fattibile
draleo

[casanmaner]

Post by draleo
E’ possibile importare in Excel (o in qualche altra parte del disco C) dati da pagine WEB ?
in un foglio Excel, colonna A, ho una lunga serie di collegamenti a pagine WEB
es : http://ecc ecc
cliccandoci sopra viene visualizzata la pagina
Io avrei necessità di copiare le pagine WEB (in realtà mi interessano solo le immagini jpg della pagina, ma, al limite potrei importare tutta la pagina e poi cancellare tutto quello che NON è immagine JPG ) e salvarle da qualche parte del disco rigido. Sono centinaia di indirizzi e farlo a mano ,singolarmente, è da escludere.
Se si potesse realizzare una procedura in excel che in automatico, apra le singole pagine e le salvi (oppure le copi) da qualche parte, allora la cosa potrebbe essere fattibile
draleo

Potresti fornire un link?
Importare dati da una pagina web è possibile tramite l'apposita funzione "query web" (Dati-Carica dati esterni-Da Web).
Ma non so se si riesca ad importare le immagini presenti.

[draleo]

Post by casanmaner

Post by draleo
E’ possibile importare in Excel (o in qualche altra parte del disco C) dati da pagine WEB ?
in un foglio Excel, colonna A, ho una lunga serie di collegamenti a pagine WEB
es : http://ecc ecc
cliccandoci sopra viene visualizzata la pagina
Io avrei necessità di copiare le pagine WEB (in realtà mi interessano solo le immagini jpg della pagina, ma, al limite potrei importare tutta la pagina e poi cancellare tutto quello che NON è immagine JPG ) e salvarle da qualche parte del disco rigido. Sono centinaia di indirizzi e farlo a mano ,singolarmente, è da escludere.
Se si potesse realizzare una procedura in excel che in automatico, apra le singole pagine e le salvi (oppure le copi) da qualche parte, allora la cosa potrebbe essere fattibile
draleo

Potresti fornire un link?
Importare dati da una pagina web è possibile tramite l'apposita funzione "query web" (Dati-Carica dati esterni-Da Web).
Ma non so se si riesca ad importare le immagini presenti.

Grazie. Ti do 3 link. Sono centinaia. Per ciascuno dovrei estrarre (copiare,salvare) dalla pagina le immagini Jpg, se possibile ;altrimenti l'intera pagina .troverò poi il modo per eliminare quello che non è immagine Jpg

http://colnect.com/stamps/stamp/1443
http://colnect.com/stamps/stamp/1444
http://colnect.com/stamps/stamp/527899
draleo

[casanmaner]

Post by draleo

Post by casanmaner

Post by draleo
E’ possibile importare in Excel (o in qualche altra parte del disco C) dati da pagine WEB ?
in un foglio Excel, colonna A, ho una lunga serie di collegamenti a pagine WEB
es : http://ecc ecc
cliccandoci sopra viene visualizzata la pagina
Io avrei necessità di copiare le pagine WEB (in realtà mi interessano solo le immagini jpg della pagina, ma, al limite potrei importare tutta la pagina e poi cancellare tutto quello che NON è immagine JPG ) e salvarle da qualche parte del disco rigido. Sono centinaia di indirizzi e farlo a mano ,singolarmente, è da escludere.
Se si potesse realizzare una procedura in excel che in automatico, apra le singole pagine e le salvi (oppure le copi) da qualche parte, allora la cosa potrebbe essere fattibile
draleo

Potresti fornire un link?
Importare dati da una pagina web è possibile tramite l'apposita funzione "query web" (Dati-Carica dati esterni-Da Web).
Ma non so se si riesca ad importare le immagini presenti.

Grazie. Ti do 3 link. Sono centinaia. Per ciascuno dovrei estrarre (copiare,salvare) dalla pagina le immagini Jpg, se possibile ;altrimenti l'intera pagina .troverò poi il modo per eliminare quello che non è immagine Jpg
http://colnect.com/stamps/stamp/1443
http://colnect.com/stamps/stamp/1444
http://colnect.com/stamps/stamp/527899

Provando con la Query-Web le immagini non vengono importate.
Una soluzione un po' maccheronica, e al momento limitata a riportare di volta in volta su un solo foglio, dopo averlo ripulito da eventuali precedenti importazioni, le immagini che mi pare di aver inteso di interesse, è questa che ti propongo (e provata su quei tre link).

Vedi questo file di esempio dove nel foglio Link ho inserito i tre link.
Nel foglio Immagini riporto il link di riferimento (quello su cui si è cliccato nel foglio Link), il nome del francobollo e l'immagine del francobollo (e nel caso la seconda immagine con quella che mi pare una "filigrana" del retro):

https://www.dropbox.com/s/9x5lo3x4ubhq73s/Importare%20dati%20da%20pagina%20WEB.xlsm?dl=0

Come detto di volta in volta le immagini vengono riportate (nota bene che a volte, probabilmente a causa di un caricamento non completo, le immagini non vengon riportate e allora occorre riprovare) e quindi ad ogni successiva azione le immagini precedenti vengono eliminate per "dare spazio" a quelle relative al link cliccato.
Nulla vieta che tu possa fare una copia del foglio dandogli un nome a tuo piacere.
In teoria si potrebbe pensare di creare un foglio ad ogni "link" ma non so se tutti i link hanno la stessa struttura per magari prendere il nome dal numero dopo "stamp/" presente nel link.
Intanto vedi se già così ti può essere d'aiuto.
Magari poi ci sarà qualcuno più esperto che proporrà una soluzione migliore.
Questo è il codice presente nel modulo di classe del foglio Link:
'---
Option Explicit

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Call Main(Target.Address)
End Sub
'---

Questo il codice vba presente nel modulo standard Modulo1:

'---
Option Explicit

'N.B. tra i riferimenti ho inserito il riferimento a Microsoft Forms 2.0 Object Library
'Un modo veloce per aggiungere il riferimento è, se non già presente, inserire una UserForm _
e nel caso eliminarla se non utilizzata

Sub Main(sUrl As String)
Call CancellaTutto
Call CopiaPaginaWeb(sUrl)
End Sub

Sub CopiaPaginaWeb(sUrl As String)
Dim DataObj As New DataObject
Dim IEobj As Object
Dim sp As Shape
Dim iLeft As Double
Dim rngName As Range, rngUrl As Range
Dim rngPos As Range
Dim sName As String

Set IEobj = CreateObject("InternetExplorer.Application")
With IEobj
.Navigate sUrl
Do Until .ReadyState = 4: TimerDelay (1): Loop
On Error Resume Next
With .Document
Do Until .ReadyState = "complete": TimerDelay (1): Loop
sName = .getElementById("name").InnerHtml
DataObj.SetText .DocumentElement.InnerHtml
.Quit
End With
On Error GoTo 0
DataObj.PutInClipboard
End With

With Worksheets("Immagini")
.Activate
Set rngUrl = .Range("A1")
Set rngName = .Range("A2")
Set rngPos = .Range("A4")
With rngUrl
.PasteSpecial xlPasteAll
.Select
End With
.Cells.Clear
rngUrl = sUrl
rngName = sName
For Each sp In .Shapes
With sp
Select Case Left(.Name, Len("Picture"))
Case Is <> "Picture"
.Delete
Case Else
If Not .Visible Then
.Delete
Else
.Top = rngPos.Top
.Left = iLeft + rngPos.Left
iLeft = iLeft + rngPos.Left + .Width + 5
End If
End Select
End With
Next sp
End With

Set IEobj = Nothing
End Sub

Sub CancellaTutto()
Dim sp As Shape
With Worksheets("Immagini")
.Cells.Clear
For Each sp In .Shapes
sp.Delete
Next
End With
End Sub

Private Function TimerDelay(Optional Delay As Double)
Const vDelay As Double = 0.25
Dim vTimer As Double
If Delay = 0 Then Delay = vDelay
vTimer = Timer
Do While Timer < vTimer + Delay: Loop
End Function
'---

[draleo]

Post by casanmaner

Post by draleo

Post by casanmaner

Post by draleo
E’ possibile importare in Excel (o in qualche altra parte del disco C) dati da pagine WEB ?
in un foglio Excel, colonna A, ho una lunga serie di collegamenti a pagine WEB
es : http://ecc ecc
cliccandoci sopra viene visualizzata la pagina
Io avrei necessità di copiare le pagine WEB (in realtà mi interessano solo le immagini jpg della pagina, ma, al limite potrei importare tutta la pagina e poi cancellare tutto quello che NON è immagine JPG ) e salvarle da qualche parte del disco rigido. Sono centinaia di indirizzi e farlo a mano ,singolarmente, è da escludere.
Se si potesse realizzare una procedura in excel che in automatico, apra le singole pagine e le salvi (oppure le copi) da qualche parte, allora la cosa potrebbe essere fattibile
draleo

Potresti fornire un link?
Importare dati da una pagina web è possibile tramite l'apposita funzione "query web" (Dati-Carica dati esterni-Da Web).
Ma non so se si riesca ad importare le immagini presenti.

Grazie. Ti do 3 link. Sono centinaia. Per ciascuno dovrei estrarre (copiare,salvare) dalla pagina le immagini Jpg, se possibile ;altrimenti l'intera pagina .troverò poi il modo per eliminare quello che non è immagine Jpg
http://colnect.com/stamps/stamp/1443
http://colnect.com/stamps/stamp/1444
http://colnect.com/stamps/stamp/527899

Provando con la Query-Web le immagini non vengono importate.
Una soluzione un po' maccheronica, e al momento limitata a riportare di volta in volta su un solo foglio, dopo averlo ripulito da eventuali precedenti importazioni, le immagini che mi pare di aver inteso di interesse, è questa che ti propongo (e provata su quei tre link).
Vedi questo file di esempio dove nel foglio Link ho inserito i tre link.
https://www.dropbox.com/s/9x5lo3x4ubhq73s/Importare%20dati%20da%20pagina%20WEB.xlsm?dl=0
Come detto di volta in volta le immagini vengono riportate (nota bene che a volte, probabilmente a causa di un caricamento non completo, le immagini non vengon riportate e allora occorre riprovare) e quindi ad ogni successiva azione le immagini precedenti vengono eliminate per "dare spazio" a quelle relative al link cliccato.
Nulla vieta che tu possa fare una copia del foglio dandogli un nome a tuo piacere.
In teoria si potrebbe pensare di creare un foglio ad ogni "link" ma non so se tutti i link hanno la stessa struttura per magari prendere il nome dal numero dopo "stamp/" presente nel link.
Intanto vedi se già così ti può essere d'aiuto.
Magari poi ci sarà qualcuno più esperto che proporrà una soluzione migliore.
'---
Option Explicit
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Call Main(Target.Address)
End Sub
'---
'---
Option Explicit
'N.B. tra i riferimenti ho inserito il riferimento a Microsoft Forms 2.0 Object Library
'Un modo veloce per aggiungere il riferimento è, se non già presente, inserire una UserForm _
e nel caso eliminarla se non utilizzata
Sub Main(sUrl As String)
Call CancellaTutto
Call CopiaPaginaWeb(sUrl)
End Sub
Sub CopiaPaginaWeb(sUrl As String)
Dim DataObj As New DataObject
Dim IEobj As Object
Dim sp As Shape
Dim iLeft As Double
Dim rngName As Range, rngUrl As Range
Dim rngPos As Range
Dim sName As String
Set IEobj = CreateObject("InternetExplorer.Application")
With IEobj
.Navigate sUrl
Do Until .ReadyState = 4: TimerDelay (1): Loop
On Error Resume Next
With .Document
Do Until .ReadyState = "complete": TimerDelay (1): Loop
sName = .getElementById("name").InnerHtml
DataObj.SetText .DocumentElement.InnerHtml
.Quit
End With
On Error GoTo 0
DataObj.PutInClipboard
End With
With Worksheets("Immagini")
.Activate
Set rngUrl = .Range("A1")
Set rngName = .Range("A2")
Set rngPos = .Range("A4")
With rngUrl
.PasteSpecial xlPasteAll
.Select
End With
.Cells.Clear
rngUrl = sUrl
rngName = sName
For Each sp In .Shapes
With sp
Select Case Left(.Name, Len("Picture"))
Case Is <> "Picture"
.Delete
Case Else
If Not .Visible Then
.Delete
Else
.Top = rngPos.Top
.Left = iLeft + rngPos.Left
iLeft = iLeft + rngPos.Left + .Width + 5
End If
End Select
End With
Next sp
End With
Set IEobj = Nothing
End Sub
Sub CancellaTutto()
Dim sp As Shape
With Worksheets("Immagini")
.Cells.Clear
For Each sp In .Shapes
sp.Delete
Next
End With
End Sub
Private Function TimerDelay(Optional Delay As Double)
Const vDelay As Double = 0.25
Dim vTimer As Double
If Delay = 0 Then Delay = vDelay
vTimer = Timer
Do While Timer < vTimer + Delay: Loop
End Function
'---

Sarà il gran caldo che mi ha rincoglionito, ma non riesco a lanciare la procedura:F5 su Private Sub Worksheet_FollowHyperlink e mi presenta la macro Cancella Tutto; F5 su sub main e mi chiede quale macro lanciare; lancio CancellaTutto e viene azzerato il foglio immagini;F5 su CopiaPaginaWeb e mi ripresenta solo la macro Cancella Tutto. Eppure il riferimento a Microsoft Forms 2.0 Object Library c'è. Dove sbaglio ? non si può mettere un pulsante per lanciare il tutto ? Comunque, se ho intuito bene il funzionamento, Importa una immagine per volta, cancellando quella precedente ? Se fosse così non risolverebbe il mio problema, che consiste nello scaricare tutte le immagini di tutti i link, mettendole tutte nello stesso foglio, una sotto l'altra, magari saltando una 10-15 righe tra l'una e l'altra. Si può fare ?

draleo

[draleo]

Post by draleo
Sarà il gran caldo che mi ha rincoglionito, ma non riesco a lanciare la procedura:F5 su Private Sub Worksheet_FollowHyperlink e mi presenta la macro Cancella Tutto; F5 su sub main e mi chiede quale macro lanciare; lancio CancellaTutto e viene azzerato il foglio immagini;F5 su CopiaPaginaWeb e mi ripresenta solo la macro Cancella Tutto. Eppure il riferimento a Microsoft Forms 2.0 Object Library c'è. Dove sbaglio ? non si può mettere un pulsante per lanciare il tutto ? Comunque, se ho intuito bene il funzionamento, Importa una immagine per volta, cancellando quella precedente ? Se fosse così non risolverebbe il mio problema, che consiste nello scaricare tutte le immagini di tutti i link, mettendole tutte nello stesso foglio, una sotto l'altra, magari saltando una 10-15 righe tra l'una e l'altra. Si può fare ?
draleo

Pardon, solo ora ho capito come funziona: devo cliccare sul link e si scatena la procedura. Ma:
1) viene salvata solo l'ultima immagine, io le devo salvare tutte
2) i i link sono centinaia e cliccarli tutti richiederebbe la mia presenza per ore davanti al PC. Non si può automatizzare in modo che una volta lanciata la procedura , questa proceda da sola fino all'ultimo link dell'elenco
draleo

[casanmaner]

Ciao,
prova a vedere con questo file.
E' presente il foglio Link dove devono essere presenti i Link (o se senza il collegamento ipertestuale l'intera URL e in questo caso attivare una diversa linea di codice che vedrai commentata). Nel foglio è presente un pulsante per lanciare la procedura che, in base alla "current region", passa ogni link (quindi i link non devono avere salti di righe ma essere presenti in una colonna, in esempio in colonna A a partire da A1, senza interruzioni di righe).
E' presente un foglio Tmp_Immagini dove temporaneamente incollo quanto copio da ciascuna URL.
E' presente un terzo foglio "Immagini" dove incollo quelle che dovrebbero essere le sole immagini dei francobolli.
Con i tre link che hai riportato ottengo qualcosa del genere:
Loading Image...
Le immagini alla fine vengono rinominate con "Immagine 1", "Immagine 2", ecc. ecc.

Questo è il file Excel:
https://www.dropbox.com/s/qju284akea4lubv/Importare%20dati%20da%20pagina%20WEB%20%232.xlsm?dl=0

Questo il codie presente nel solo modulo1:
'---
Option Explicit

'N.B. tra i riferimenti ho inserito il riferimento a Microsoft Forms 2.0 Object Library
'Un modo veloce per aggiungere il riferimento è, se non già presente, inserire una UserForm _
e nel caso eliminarla se non utilizzata


Sub ImportaImmagini()
Dim Wb As Workbook
Dim wsLink As Worksheet
Dim WsTmp As Worksheet
Dim wsImmagini As Worksheet
Dim rngLink As Range
Dim DataObj As New DataObject
Dim IEobj As Object
Dim sUrl As String
Dim sp As Shape
Dim iLeft As Double
Dim sName As String
Dim rngUrl As Range, r As Range
Dim sp2 As Shape
Dim iStep As Long
Const DeltaStep = 25 'numero di celle tra una immagine di una Url e l'altra
Const DeltaLeft = 5 'numero di celle di lato nel caso di due immagini in una Url

Set Wb = ThisWorkbook
With Wb
Set wsLink = .Worksheets("Link")
Set WsTmp = .Worksheets("Tmp_Immagini")
Set wsImmagini = .Worksheets("Immagini")
End With
Set rngLink = wsLink.Range("A1").CurrentRegion.Columns(1)
Set IEobj = CreateObject("InternetExplorer.Application")
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo Errore
Call CancellaWsImmagini
For Each r In rngLink.Cells
sUrl = r.Hyperlinks(1).Address 'prende l'indirizzo del link _
(da usare se le celle presentano un link)
'sUrl = r.Value 'prende il valore nella cella _
(da usare se le celle non presentano un link _
ma il valore della cella corrisponde all'intera URL)
With IEobj
.Navigate sUrl
Do Until .ReadyState = 4: TimerDelay (2): Loop
On Error Resume Next
With .Document
Do Until .ReadyState = "complete": TimerDelay: Loop
sName = .getElementById("name").InnerHtml
DataObj.SetText .DocumentElement.InnerHtml
End With
On Error GoTo 0
DataObj.PutInClipboard
End With
With wsImmagini
With .Range("A1")
.Offset(iStep) = sUrl
.Offset(iStep + 1) = sName
End With
End With
With WsTmp
With .Range("A1")
.PasteSpecial xlPasteAll
End With
For Each sp In .Shapes
With sp
Select Case Left(.Name, Len("Picture"))
Case Is <> "Picture"
.Delete
Case Else
If Not .Visible Then
.Delete
Else
.Cut
wsImmagini.Range("A1").Offset(iStep + 2, iLeft).PasteSpecial
iLeft = iLeft + DeltaLeft
End If
End Select
End With
Next sp
End With
iStep = iStep + DeltaStep
iLeft = 0
Next r
RiprendiErrore:
Call CancellaWsTemp
With wsImmagini
.Activate
.Range("A1").Activate
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
Call RinominaImmagini
IEobj.Quit
Set IEobj = Nothing
Exit Sub
Errore:
MsgBox "Errore VBA " & Err.Number & vbNewLine & _
Err.Description & vbNewLine & _
"La procedura verrà interrotta!", vbCritical, "Errore VBA"
Resume RiprendiErrore
End Sub

Sub CancellaWsTemp()
Dim sp As Shape
With ThisWorkbook.Worksheets("Tmp_Immagini")
.Cells.Clear
End With
End Sub

Sub CancellaWsImmagini()
Dim sp As Shape
With ThisWorkbook.Worksheets("Immagini")
.Cells.Clear
For Each sp In .Shapes
sp.Delete
Next
End With
End Sub

Sub RinominaImmagini()
Dim sp As Shape
Dim cont As Long
With ThisWorkbook.Worksheets("Immagini")
For Each sp In .Shapes
cont = cont + 1
sp.Name = "Immagine " & cont
Next
End With
End Sub

Private Function TimerDelay(Optional Delay As Double)
Const vDelay As Double = 0.25
Dim vTimer As Double
If Delay = 0 Then Delay = vDelay
vTimer = Timer
Do While Timer < vTimer + Delay: Loop
End Function
'---

Nota che a volte la prima immagine non viene "presa".
Ho impostato a 2 secondi il ritardo in questa istruzione:
Do Until .ReadyState = 4: TimerDelay (2): Loop
perché mi pare che con questo tempo l'eventualità si riduca a poche occasioni.

Prova a vedere cosa succede con tutti i tui link.

ciao

[draleo]

Post by casanmaner
Ciao,
prova a vedere con questo file.
E' presente il foglio Link dove devono essere presenti i Link (o se senza il collegamento ipertestuale l'intera URL e in questo caso attivare una diversa linea di codice che vedrai commentata). Nel foglio è presente un pulsante per lanciare la procedura che, in base alla "current region", passa ogni link (quindi i link non devono avere salti di righe ma essere presenti in una colonna, in esempio in colonna A a partire da A1, senza interruzioni di righe).
E' presente un foglio Tmp_Immagini dove temporaneamente incollo quanto copio da ciascuna URL.
E' presente un terzo foglio "Immagini" dove incollo quelle che dovrebbero essere le sole immagini dei francobolli.
https://www.dropbox.com/s/kmdon88mmz286bs/Immagine.jpg?dl=0
Le immagini alla fine vengono rinominate con "Immagine 1", "Immagine 2", ecc. ecc.
https://www.dropbox.com/s/qju284akea4lubv/Importare%20dati%20da%20pagina%20WEB%20%232.xlsm?dl=0
'---
Option Explicit
'N.B. tra i riferimenti ho inserito il riferimento a Microsoft Forms 2.0 Object Library
'Un modo veloce per aggiungere il riferimento è, se non già presente, inserire una UserForm _
e nel caso eliminarla se non utilizzata
Sub ImportaImmagini()
Dim Wb As Workbook
Dim wsLink As Worksheet
Dim WsTmp As Worksheet
Dim wsImmagini As Worksheet
Dim rngLink As Range
Dim DataObj As New DataObject
Dim IEobj As Object
Dim sUrl As String
Dim sp As Shape
Dim iLeft As Double
Dim sName As String
Dim rngUrl As Range, r As Range
Dim sp2 As Shape
Dim iStep As Long
Const DeltaStep = 25 'numero di celle tra una immagine di una Url e l'altra
Const DeltaLeft = 5 'numero di celle di lato nel caso di due immagini in una Url
Set Wb = ThisWorkbook
With Wb
Set wsLink = .Worksheets("Link")
Set WsTmp = .Worksheets("Tmp_Immagini")
Set wsImmagini = .Worksheets("Immagini")
End With
Set rngLink = wsLink.Range("A1").CurrentRegion.Columns(1)
Set IEobj = CreateObject("InternetExplorer.Application")
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo Errore
Call CancellaWsImmagini
For Each r In rngLink.Cells
sUrl = r.Hyperlinks(1).Address 'prende l'indirizzo del link _
(da usare se le celle presentano un link)
'sUrl = r.Value 'prende il valore nella cella _
(da usare se le celle non presentano un link _
ma il valore della cella corrisponde all'intera URL)
With IEobj
.Navigate sUrl
Do Until .ReadyState = 4: TimerDelay (2): Loop
On Error Resume Next
With .Document
Do Until .ReadyState = "complete": TimerDelay: Loop
sName = .getElementById("name").InnerHtml
DataObj.SetText .DocumentElement.InnerHtml
End With
On Error GoTo 0
DataObj.PutInClipboard
End With
With wsImmagini
With .Range("A1")
.Offset(iStep) = sUrl
.Offset(iStep + 1) = sName
End With
End With
With WsTmp
With .Range("A1")
.PasteSpecial xlPasteAll
End With
For Each sp In .Shapes
With sp
Select Case Left(.Name, Len("Picture"))
Case Is <> "Picture"
.Delete
Case Else
If Not .Visible Then
.Delete
Else
.Cut
wsImmagini.Range("A1").Offset(iStep + 2, iLeft).PasteSpecial
iLeft = iLeft + DeltaLeft
End If
End Select
End With
Next sp
End With
iStep = iStep + DeltaStep
iLeft = 0
Next r
Call CancellaWsTemp
With wsImmagini
.Activate
.Range("A1").Activate
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
Call RinominaImmagini
IEobj.Quit
Set IEobj = Nothing
Exit Sub
MsgBox "Errore VBA " & Err.Number & vbNewLine & _
Err.Description & vbNewLine & _
"La procedura verrà interrotta!", vbCritical, "Errore VBA"
Resume RiprendiErrore
End Sub
Sub CancellaWsTemp()
Dim sp As Shape
With ThisWorkbook.Worksheets("Tmp_Immagini")
.Cells.Clear
End With
End Sub
Sub CancellaWsImmagini()
Dim sp As Shape
With ThisWorkbook.Worksheets("Immagini")
.Cells.Clear
For Each sp In .Shapes
sp.Delete
Next
End With
End Sub
Sub RinominaImmagini()
Dim sp As Shape
Dim cont As Long
With ThisWorkbook.Worksheets("Immagini")
For Each sp In .Shapes
cont = cont + 1
sp.Name = "Immagine " & cont
Next
End With
End Sub
Private Function TimerDelay(Optional Delay As Double)
Const vDelay As Double = 0.25
Dim vTimer As Double
If Delay = 0 Then Delay = vDelay
vTimer = Timer
Do While Timer < vTimer + Delay: Loop
End Function
'---
Nota che a volte la prima immagine non viene "presa".
Do Until .ReadyState = 4: TimerDelay (2): Loop
perché mi pare che con questo tempo l'eventualità si riduca a poche occasioni.
Prova a vedere cosa succede con tutti i tui link.
ciao

Ho provato con una 20na di link e la prima impressione è stata: eccezionale !
domani proverò con un numero più consistente di links, ma credo che il buongiorno si veda dal mattino... Magari , poiché la procedura è abbastanza lenta e, durante l'attesa non si capisce se stia funzionando oppure no, sarebbe utile avere sulla barra di stato qualche informazione, per seguire l'andamento del processo (per es sto lavorando all'immagine num o qualcosa del genere). Inoltre il ritardo di 2 secondi è poco (meglio 4 secondi): un paio di immagini infatti sono state saltate. lo testerò meglio, ma comunque è ottimo
draleo

[casanmaner]

Post by draleo

Post by casanmaner
Ciao,
prova a vedere con questo file.
E' presente il foglio Link dove devono essere presenti i Link (o se senza il collegamento ipertestuale l'intera URL e in questo caso attivare una diversa linea di codice che vedrai commentata). Nel foglio è presente un pulsante per lanciare la procedura che, in base alla "current region", passa ogni link (quindi i link non devono avere salti di righe ma essere presenti in una colonna, in esempio in colonna A a partire da A1, senza interruzioni di righe).
E' presente un foglio Tmp_Immagini dove temporaneamente incollo quanto copio da ciascuna URL.
E' presente un terzo foglio "Immagini" dove incollo quelle che dovrebbero essere le sole immagini dei francobolli.
https://www.dropbox.com/s/kmdon88mmz286bs/Immagine.jpg?dl=0
Le immagini alla fine vengono rinominate con "Immagine 1", "Immagine 2", ecc. ecc.
https://www.dropbox.com/s/qju284akea4lubv/Importare%20dati%20da%20pagina%20WEB%20%232.xlsm?dl=0
'---
Option Explicit
'N.B. tra i riferimenti ho inserito il riferimento a Microsoft Forms 2.0 Object Library
'Un modo veloce per aggiungere il riferimento è, se non già presente, inserire una UserForm _
e nel caso eliminarla se non utilizzata
Sub ImportaImmagini()
Dim Wb As Workbook
Dim wsLink As Worksheet
Dim WsTmp As Worksheet
Dim wsImmagini As Worksheet
Dim rngLink As Range
Dim DataObj As New DataObject
Dim IEobj As Object
Dim sUrl As String
Dim sp As Shape
Dim iLeft As Double
Dim sName As String
Dim rngUrl As Range, r As Range
Dim sp2 As Shape
Dim iStep As Long
Const DeltaStep = 25 'numero di celle tra una immagine di una Url e l'altra
Const DeltaLeft = 5 'numero di celle di lato nel caso di due immagini in una Url
Set Wb = ThisWorkbook
With Wb
Set wsLink = .Worksheets("Link")
Set WsTmp = .Worksheets("Tmp_Immagini")
Set wsImmagini = .Worksheets("Immagini")
End With
Set rngLink = wsLink.Range("A1").CurrentRegion.Columns(1)
Set IEobj = CreateObject("InternetExplorer.Application")
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo Errore
Call CancellaWsImmagini
For Each r In rngLink.Cells
sUrl = r.Hyperlinks(1).Address 'prende l'indirizzo del link _
(da usare se le celle presentano un link)
'sUrl = r.Value 'prende il valore nella cella _
(da usare se le celle non presentano un link _
ma il valore della cella corrisponde all'intera URL)
With IEobj
.Navigate sUrl
Do Until .ReadyState = 4: TimerDelay (2): Loop
On Error Resume Next
With .Document
Do Until .ReadyState = "complete": TimerDelay: Loop
sName = .getElementById("name").InnerHtml
DataObj.SetText .DocumentElement.InnerHtml
End With
On Error GoTo 0
DataObj.PutInClipboard
End With
With wsImmagini
With .Range("A1")
.Offset(iStep) = sUrl
.Offset(iStep + 1) = sName
End With
End With
With WsTmp
With .Range("A1")
.PasteSpecial xlPasteAll
End With
For Each sp In .Shapes
With sp
Select Case Left(.Name, Len("Picture"))
Case Is <> "Picture"
.Delete
Case Else
If Not .Visible Then
.Delete
Else
.Cut
wsImmagini.Range("A1").Offset(iStep + 2, iLeft).PasteSpecial
iLeft = iLeft + DeltaLeft
End If
End Select
End With
Next sp
End With
iStep = iStep + DeltaStep
iLeft = 0
Next r
Call CancellaWsTemp
With wsImmagini
.Activate
.Range("A1").Activate
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
Call RinominaImmagini
IEobj.Quit
Set IEobj = Nothing
Exit Sub
MsgBox "Errore VBA " & Err.Number & vbNewLine & _
Err.Description & vbNewLine & _
"La procedura verrà interrotta!", vbCritical, "Errore VBA"
Resume RiprendiErrore
End Sub
Sub CancellaWsTemp()
Dim sp As Shape
With ThisWorkbook.Worksheets("Tmp_Immagini")
.Cells.Clear
End With
End Sub
Sub CancellaWsImmagini()
Dim sp As Shape
With ThisWorkbook.Worksheets("Immagini")
.Cells.Clear
For Each sp In .Shapes
sp.Delete
Next
End With
End Sub
Sub RinominaImmagini()
Dim sp As Shape
Dim cont As Long
With ThisWorkbook.Worksheets("Immagini")
For Each sp In .Shapes
cont = cont + 1
sp.Name = "Immagine " & cont
Next
End With
End Sub
Private Function TimerDelay(Optional Delay As Double)
Const vDelay As Double = 0.25
Dim vTimer As Double
If Delay = 0 Then Delay = vDelay
vTimer = Timer
Do While Timer < vTimer + Delay: Loop
End Function
'---
Nota che a volte la prima immagine non viene "presa".
Do Until .ReadyState = 4: TimerDelay (2): Loop
perché mi pare che con questo tempo l'eventualità si riduca a poche occasioni.
Prova a vedere cosa succede con tutti i tui link.
ciao

Ho provato con una 20na di link e la prima impressione è stata: eccezionale !
domani proverò con un numero più consistente di links, ma credo che il buongiorno si veda dal mattino... Magari , poiché la procedura è abbastanza lenta e, durante l'attesa non si capisce se stia funzionando oppure no, sarebbe utile avere sulla barra di stato qualche informazione, per seguire l'andamento del processo (per es sto lavorando all'immagine num o qualcosa del genere). Inoltre il ritardo di 2 secondi è poco (meglio 4 secondi): un paio di immagini infatti sono state saltate. lo testerò meglio, ma comunque è ottimo
draleo

La soluzione più semplice è un messaggio nella barra di stato del tipo:
"Link 1 di 3 in elaborazione"
che si aggiorna ad ogni link elaborato.

Vedi sempre lo stesso file al link precedente dove ho aggiunto le dichiarazioni:
Dim NumLink As Long, iLink As Long

Dopo l'istruzione:
Set rngLink = wsLink.Range("A1").CurrentRegion.Columns(1)
ho aggiunto:
NumLink = rngLink.Rows.Count


Dopo l'istruzione:
For Each r In rngLink.Cells
ho aggiunto:
iLink = iLink + 1
Application.StatusBar = "Link " & iLink & " di " & NumLink & " in elaborazione."

e, infine, per ripristinare la barra di stato dopo l'istruzione:
RiprendiErrore:
ho inserito:
Application.StatusBar = False


ciao

ho aggiunto:

[draleo]

chiedo venia, ma ho un problema che non dipende dalla tua procedura, ma dai miei links:
nel mio foglio Excel , da A1 in giù, sono scritti così
http://colnect.com/stamps/stamp/1424 (cioè in nero e senza sottolineatura)
ma con questo formato non funzionano. Per farli funzionare devo posizionarmi col cursore dopo l’ultima cifra e dare invio; in questo modo diventano azzurri con la sottolineatura (tipica dei links)
e tutto torna a funzionare. Ma fare questa operazione manualmente su centinaia di links, sarebbe abbastanza faticoso. C’è un modo per correggerli tutti in blocco ?
draleo

[casanmaner]

Prova ad attivare questa istruzione disattivando quella immediatamente precedente:

'sUrl = r.Value 'prende il valore nella cella _ 
                       (da usare se le celle non presentano un link _
                       ma il valore della cella corrisponde all'intera URL) 

[draleo]

Post by casanmaner
'sUrl = r.Value 'prende il valore nella cella _ 
                       (da usare se le celle non presentano un link _
                       ma il valore della cella corrisponde all'intera URL) 

Di nuovo pardon (evidentemente il gran caldo mi ha dato alla testa).E' semplice: ne sistemo uno a mano e poi copia-incolla speciale formato- su tutti gli altri, e tutti assumono il formato giusto e funzionante
grazie
draleo

[draleo]

Dopo una lunga fase di prove, finalmente ho provato a caricare un num elevato di immagini (1000) nella stessa seduta. Purtroppo ogni tanto segnala qualche errore, di vario genere, interrompendo la procedura. Spesso l’errore è : errore nel metodo paste special, in questo punto
With WsTmp
With .Range("A1")
.PasteSpecial xlPasteAll
End With
Ma ogni tanto compaiono anche altri errori di altro tipo
e che credo dipendano più dalla impostazione della Pagina Web (e quindi difficili da prevedere e correggere tutti)
Allora Visto che le cose stanno così, si può fare in modo che ad ogni errore la procedura NON si interrompa ma passi al prossimo Link ? (on errore resume Next ?)
Se si potesse fare sarebbe utile aggiungere un foglio (Link Falliti), in cui vengano riportati i link dove si è verificato l’errore (in modo da riprovare successivamente, magari uno per uno)
draleo

[casanmaner]

Ciao,
prova a vedere questa terza versione:
https://www.dropbox.com/s/jos1g4urvscp6o1/Importare%20dati%20da%20pagina%20WEB%20%233.xlsm?dl=0

Ho aggiunto un foglio nominato "Link_Falliti" dove sono presenti tre campi:
Link Falliti
Numero Errore
Descrizione Errore

Nel VBA ho modificato la routine "ImportaImmagini" in modo che, in caso di errori successivi al caricamento della pagina web, il ciclo venga continuato per la URL successiva.
In caso di errore nel foglio Link_Falliti vengono inseriti i dati della URL, il numero di errore e la descrizione dell'errore.
Alla URL viene automaticamente impostato il collegamento ipertestuale (questa cosa ora viene fatta anche per le URL nel foglio immagini).
Ho aggiunto una routine per pulire il foglio "Link_Falliti" e una routine per aggiungere i collegamenti iptertestuali.
Riporto di seguito l'intero codice presente nel Modulo1:

'---
Option Explicit

'N.B. tra i riferimenti ho inserito il riferimento a Microsoft Forms 2.0 Object Library
'Un modo veloce per aggiungere il riferimento è, se non già presente, inserire una UserForm _
e nel caso eliminarla se non utilizzata


Sub ImportaImmagini()
Dim Wb As Workbook
Dim wsLink As Worksheet
Dim WsTmp As Worksheet
Dim wsImmagini As Worksheet
Dim rngLink As Range
Dim DataObj As New DataObject
Dim IEobj As Object
Dim sURL As String
Dim sp As Shape
Dim iLeft As Double
Dim sName As String
Dim r As Range
Dim iStep As Long
Dim NumLink As Long, iLink As Long
Const DeltaStep = 25 'numero di celle tra una immagine di una Url e l'altra
Const DeltaLeft = 5 'numero di celle di lato nel caso di due immagini in una Url

Set Wb = ThisWorkbook
With Wb
Set wsLink = .Worksheets("Link")
Set WsTmp = .Worksheets("Tmp_Immagini")
Set wsImmagini = .Worksheets("Immagini")
End With
Set rngLink = wsLink.Range("A1").CurrentRegion.Columns(1)
NumLink = rngLink.Rows.Count
Set IEobj = CreateObject("InternetExplorer.Application")
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo Errore
Call CancellaWsImmagini
Call CancellaLinkFalliti
For Each r In rngLink.Cells
iLink = iLink + 1
Application.StatusBar = "Link " & iLink & " di " & NumLink & " in elaborazione."
sURL = r.Hyperlinks(1).Address 'prende l'indirizzo del link _
(da usare se le celle presentano un link)
'sUrl = r.Value 'prende il valore nella cella _
(da usare se le celle non presentano un link _
ma il valore della cella corrisponde all'intera URL)
With IEobj
.Navigate sURL
Do Until .ReadyState = 4: TimerDelay (2): Loop
On Error Resume Next
With .Document
Do Until .ReadyState = "complete": TimerDelay: Loop
sName = .getElementById("name").InnerHtml
DataObj.SetText .DocumentElement.InnerHtml
End With
Err.Clear
On Error GoTo Errore
DataObj.PutInClipboard
End With
With wsImmagini
With .Range("A1")
With .Offset(iStep)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(iStep + 1) = sName
End With
End With
With WsTmp
With .Range("A1")
.PasteSpecial xlPasteAll
End With
For Each sp In .Shapes
With sp
Select Case Left(.Name, Len("Picture"))
Case Is <> "Picture"
.Delete
Case Else
If Not .Visible Then
.Delete
Else
.Cut
wsImmagini.Range("A1").Offset(iStep + 2, iLeft).PasteSpecial
iLeft = iLeft + DeltaLeft
End If
End Select
End With
Next sp
End With
RiprendiErrore:
iStep = iStep + DeltaStep
iLeft = 0
Next r
Application.StatusBar = False
Call CancellaWsTemp
With wsImmagini
.Activate
.Range("A1").Activate
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
Call RinominaImmagini
IEobj.Quit
Set IEobj = Nothing
Exit Sub
Errore:
With ThisWorkbook.Worksheets("Link_Falliti")
With .Cells(.Rows.Count, 1).End(xlUp)
With .Offset(1, 0)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(1, 1).Value = "Errore n. " & Err.Number
.Offset(1, 2).Value = Err.Description
End With
End With
Err.Clear
Resume RiprendiErrore
End Sub

Sub CancellaWsTemp()
Dim sp As Shape
With ThisWorkbook.Worksheets("Tmp_Immagini")
.Cells.Clear
End With
End Sub

Sub CancellaWsImmagini()
Dim sp As Shape
With ThisWorkbook.Worksheets("Immagini")
.Cells.Clear
For Each sp In .Shapes
sp.Delete
Next
End With
End Sub

Sub RinominaImmagini()
Dim sp As Shape
Dim cont As Long
With ThisWorkbook.Worksheets("Immagini")
For Each sp In .Shapes
cont = cont + 1
sp.Name = "Immagine " & cont
Next
End With
End Sub

Sub CancellaLinkFalliti()
With ThisWorkbook.Worksheets("Link_Falliti").Range("A1").CurrentRegion
If .Rows.Count > 1 Then
.Offset(1).Resize(.Rows.Count - 1, 3).Clear
End If
End With
End Sub

Sub AddHyperLink(sURL As String, r As Range)
r.Parent.Hyperlinks.Add r, sURL, , , sURL
End Sub

Private Function TimerDelay(Optional Delay As Double)
Const vDelay As Double = 0.25
Dim vTimer As Double
If Delay = 0 Then Delay = vDelay
vTimer = Timer
Do While Timer < vTimer + Delay: Loop
End Function
'---

[draleo]

Post by casanmaner
Ciao,
https://www.dropbox.com/s/jos1g4urvscp6o1/Importare%20dati%20da%20pagina%20WEB%20%233.xlsm?dl=0
Link Falliti
Numero Errore
Descrizione Errore
Nel VBA ho modificato la routine "ImportaImmagini" in modo che, in caso di errori successivi al caricamento della pagina web, il ciclo venga continuato per la URL successiva.
In caso di errore nel foglio Link_Falliti vengono inseriti i dati della URL, il numero di errore e la descrizione dell'errore.
Alla URL viene automaticamente impostato il collegamento ipertestuale (questa cosa ora viene fatta anche per le URL nel foglio immagini).
Ho aggiunto una routine per pulire il foglio "Link_Falliti" e una routine per aggiungere i collegamenti iptertestuali.
'---
Option Explicit
'N.B. tra i riferimenti ho inserito il riferimento a Microsoft Forms 2.0 Object Library
'Un modo veloce per aggiungere il riferimento è, se non già presente, inserire una UserForm _
e nel caso eliminarla se non utilizzata
Sub ImportaImmagini()
Dim Wb As Workbook
Dim wsLink As Worksheet
Dim WsTmp As Worksheet
Dim wsImmagini As Worksheet
Dim rngLink As Range
Dim DataObj As New DataObject
Dim IEobj As Object
Dim sURL As String
Dim sp As Shape
Dim iLeft As Double
Dim sName As String
Dim r As Range
Dim iStep As Long
Dim NumLink As Long, iLink As Long
Const DeltaStep = 25 'numero di celle tra una immagine di una Url e l'altra
Const DeltaLeft = 5 'numero di celle di lato nel caso di due immagini in una Url
Set Wb = ThisWorkbook
With Wb
Set wsLink = .Worksheets("Link")
Set WsTmp = .Worksheets("Tmp_Immagini")
Set wsImmagini = .Worksheets("Immagini")
End With
Set rngLink = wsLink.Range("A1").CurrentRegion.Columns(1)
NumLink = rngLink.Rows.Count
Set IEobj = CreateObject("InternetExplorer.Application")
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo Errore
Call CancellaWsImmagini
Call CancellaLinkFalliti
For Each r In rngLink.Cells
iLink = iLink + 1
Application.StatusBar = "Link " & iLink & " di " & NumLink & " in elaborazione."
sURL = r.Hyperlinks(1).Address 'prende l'indirizzo del link _
(da usare se le celle presentano un link)
'sUrl = r.Value 'prende il valore nella cella _
(da usare se le celle non presentano un link _
ma il valore della cella corrisponde all'intera URL)
With IEobj
.Navigate sURL
Do Until .ReadyState = 4: TimerDelay (2): Loop
On Error Resume Next
With .Document
Do Until .ReadyState = "complete": TimerDelay: Loop
sName = .getElementById("name").InnerHtml
DataObj.SetText .DocumentElement.InnerHtml
End With
Err.Clear
On Error GoTo Errore
DataObj.PutInClipboard
End With
With wsImmagini
With .Range("A1")
With .Offset(iStep)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(iStep + 1) = sName
End With
End With
With WsTmp
With .Range("A1")
.PasteSpecial xlPasteAll
End With
For Each sp In .Shapes
With sp
Select Case Left(.Name, Len("Picture"))
Case Is <> "Picture"
.Delete
Case Else
If Not .Visible Then
.Delete
Else
.Cut
wsImmagini.Range("A1").Offset(iStep + 2, iLeft).PasteSpecial
iLeft = iLeft + DeltaLeft
End If
End Select
End With
Next sp
End With
iStep = iStep + DeltaStep
iLeft = 0
Next r
Application.StatusBar = False
Call CancellaWsTemp
With wsImmagini
.Activate
.Range("A1").Activate
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
Call RinominaImmagini
IEobj.Quit
Set IEobj = Nothing
Exit Sub
With ThisWorkbook.Worksheets("Link_Falliti")
With .Cells(.Rows.Count, 1).End(xlUp)
With .Offset(1, 0)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(1, 1).Value = "Errore n. " & Err.Number
.Offset(1, 2).Value = Err.Description
End With
End With
Err.Clear
Resume RiprendiErrore
End Sub
Sub CancellaWsTemp()
Dim sp As Shape
With ThisWorkbook.Worksheets("Tmp_Immagini")
.Cells.Clear
End With
End Sub
Sub CancellaWsImmagini()
Dim sp As Shape
With ThisWorkbook.Worksheets("Immagini")
.Cells.Clear
For Each sp In .Shapes
sp.Delete
Next
End With
End Sub
Sub RinominaImmagini()
Dim sp As Shape
Dim cont As Long
With ThisWorkbook.Worksheets("Immagini")
For Each sp In .Shapes
cont = cont + 1
sp.Name = "Immagine " & cont
Next
End With
End Sub
Sub CancellaLinkFalliti()
With ThisWorkbook.Worksheets("Link_Falliti").Range("A1").CurrentRegion
If .Rows.Count > 1 Then
.Offset(1).Resize(.Rows.Count - 1, 3).Clear
End If
End With
End Sub
Sub AddHyperLink(sURL As String, r As Range)
r.Parent.Hyperlinks.Add r, sURL, , , sURL
End Sub
Private Function TimerDelay(Optional Delay As Double)
Const vDelay As Double = 0.25
Dim vTimer As Double
If Delay = 0 Then Delay = vDelay
vTimer = Timer
Do While Timer < vTimer + Delay: Loop
End Function
'---

Ok. grazie. Ho appena lanciato la nuova procedura per circa 1500 link. Ma credo che potrò vederne gli esiti solo tra 5-6 ore. Nel frattempo però non posso fare altro col PC (la rotellina gira in continuazione e non posso usare il PC, o meglio, non ci voglio provare per timore di provocare qualche guaio e poi ricominciare tutto da capo). A proposito: se, in caso di qualche necessità , uno volesse interrompere anticipatamente la procedura, come si fa ?
draleo

[casanmaner]

Digita Esc.... Dovrebbe azionarsi, magari con un po' di ritardo, la finestra del debug con la quale viene chiesto se terminare la procedura.

[draleo]

Post by casanmaner
Digita Esc.... Dovrebbe azionarsi, magari con un po' di ritardo, la finestra del debug con la quale viene chiesto se terminare la procedura.

Conclusioni:ho prima lanciato 200 link e tutto è filato liscio (4-5 errori riportati , che però non costituiscono un problema).Ho quindi tentato il colpo grosso:1500 link. Purtroppo però, la procedura è arrivata al num 1375 dove si è bloccata per più di 30 minuti e non c’è stato modo di continuare; sono stato costretto ad uscire, ma ho perso tutto quello che era stato fatto. Quindi va comunque bene- mille grazie ancora- ma bisogna avere l’avvertenza di non esagerare con il num dei Link, e procedere per gruppi non eccessivamente grandi. Certo se si riuscisse a salvare automaticamente il workbook ogni 200-250 link, in caso di blocco gran parte del lavoro non andrebbe perso... e potrei far lavorare il PC di notte, quando non mi serve perché...dormo
Buon Ferragosto
draleo

[casanmaner]

Ciao,
per impostare un salvataggio ogni tot link, prima di:
Next r

inserisci questo codice:

If iLink Mod 100 = 0 Then
ThisWorkbook.Save
End If

ogni 100 cicli viene effettuato un salvataggio della cartella di lavoro.
Modificando il numero successivo a Mod puoi modificare ogni quanti cicli eseguire il salvataggio.

[draleo]

Post by casanmaner
Ciao,
Next r
If iLink Mod 100 = 0 Then
ThisWorkbook.Save
End If
ogni 100 cicli viene effettuato un salvataggio della cartella di lavoro.
Modificando il numero successivo a Mod puoi modificare ogni quanti cicli eseguire il salvataggio.

OK. Il salvataggio automatico permette di evitare (o ridurre al minimo) i danni provocati dai blocchi della procedura, che ogni tanto si verificano (sui quali non si può far niente, perchè dipendono da fattori esterni).
E’ però subentrata una nuova esigenza che non avevo previsto: con centinaia (o migliaia) di immagini, è da certosini identificarle e classificarle basandosi solo sul relativo link.
1) Se io introducessi sulla colonna B del foglio Link, dei codici identificativi- che poi non sono altro che i num di catalogo delle immagini- (es 13,19B,35/I ecc.ecc), è possibile recuperare questi codici in fase di caricamento e metterli nel foglio immagini ? per es nella colonna E , accanto all’identificativo del link, che si trova nella col A , sulla stessa riga?
2) Un altro problema è dovuto al fatto che qualche pagina WEB ha 2 immagini (anziché una sola) e questa seconda-di solito si tratta della filigrana, quando c’è - viene collocata sullo stesso foglio immagini accanto alla immagine 1; ma, mi sono accorto solo ora, che avere 2 immagini per lo stesso link, sullo stesso foglio, mi scompagina tutto l’ordine delle immagini. Sarebbe possibile inviare la seconda immagine-quando c’è- in un altro foglio aggiuntivo ,chiamato per es Filigrane, con le stesse regole del foglio Immagini (del punto 1). In tal modo le immagini dei francobolli e quelle delle filgrane finirebbero in 2 fogli separati, con notevole beneficio.
se si potesse fare sarebbe ottimo, altrimenti...ciccia; va già bene così
draleo

[casanmaner]

Post by draleo
1) Se io introducessi sulla colonna B del foglio Link, dei codici identificativi- che poi non sono altro che i num di catalogo delle immagini- (es 13,19B,35/I ecc.ecc), è possibile recuperare questi codici in fase di caricamento e metterli nel foglio immagini ? per es nella colonna E , accanto all’identificativo del link, che si trova nella col A , sulla stessa riga?

Per caso questi numerdi di catalogo sono gli stessi che compaiono nella URL?
Es. 527899 per questo link https://colnect.com/it/stamps/stamp/527899-Queen_Elizabeth_II_-_Predecimal_Machin-Regina_Elisabetta_II_pre_decimali_Machins-Gran_Bretagna?

Post by draleo
2) Un altro problema è dovuto al fatto che qualche pagina WEB ha 2 immagini (anziché una sola) e questa seconda-di solito si tratta della filigrana, quando c’è - viene collocata sullo stesso foglio immagini accanto alla immagine 1; ma, mi sono accorto solo ora, che avere 2 immagini per lo stesso link, sullo stesso foglio, mi scompagina tutto l’ordine delle immagini. Sarebbe possibile inviare la seconda immagine-quando c’è- in un altro foglio aggiuntivo ,chiamato per es Filigrane, con le stesse regole del foglio Immagini (del punto 1). In tal modo le immagini dei francobolli e quelle delle filgrane finirebbero in 2 fogli separati, con notevole beneficio.

Ma la posizione dell'immagine della filigrata dovrebbe essere in corrispondenza della stessa "riga" dell'immagine principale presente nel foglio Immagini?

Oppure potrebbe essere consecutiva a prescindere dalla posizione dell'immagine principale nel foglio immagini?

Post by draleo
se si potesse fare sarebbe ottimo, altrimenti...ciccia; va già bene così
draleo

[draleo]

Post by casanmaner
Per caso questi numerdi di catalogo sono gli stessi che compaiono nella URL?
Es. 527899 per questo link https://colnect.com/it/stamps/stamp/527899-Queen_Elizabeth_II_-_Predecimal_Machin-Regina_Elisabetta_II_pre_decimali_Machins-Gran_Bretagna?

Meglio no. Quello è solo il num di uno (Stanley gibson) dei tanti cataloghi esistenti. Quindi considerare solo questo catalogo sarebbe limitativo. Io ho già un database in Excel con tutte le caratteristiche dei francobolli in questione (mancano solo le immagini); e accanto ad ogni link, ho anche altri codici identificativi. Quindi preferirei mettere nella colonna B del foglio Link, accanto ai rispettivi link, i codici che preferisco; per me sarebbe solo un copia incolla. in definitiva i codici identificativi per ciascun link (ognuno dei quali corrisponde ad un francobollo) preferisco metterli io e non estrarli

Post by casanmaner
Ma la posizione dell'immagine della filigrata dovrebbe essere in corrispondenza della stessa "riga" dell'immagine principale presente nel foglio Immagini?
Oppure potrebbe essere consecutiva a prescindere dalla posizione dell'immagine principale nel foglio immagini?

Meglio la prima ipotesi. Anche nel foglio Filigrana dovrebbero essere riportati il link e il codice identificativo, nella stessa riga dell'immagine principale presente nel foglio immagini. La differenza sarebbe che se la seconda immagine non c'è, allora basta scrivere, sul Foglio Filigrana, sulla stessa riga del link, per es colonna D, la dicitura "No filigrana"
draleo

[casanmaner]

Ciao prova questa quarta versione (alla quinta scatta il regalo Gronchi Rosa :D :D :D):
https://www.dropbox.com/s/xd9tquqj5w3fk8x/Importare%20dati%20da%20pagina%20WEB%20%234.xlsm?dl=0

Ho inserito un foglio "Filigrane" dove vengono riportati gli stessi dati presenti nel foglio "Immagini" (tra cui eventuali valori inseriti in colonna B del foglio "Link").
Ho modificato la procedura principale "ImportaImmagini" per riportare le figligrane nel relativo foglio e per aggiungere alle descrizioni l'eventuale numero di catalogo presente nella colonna B del foglio "Link".
Ho anche modificato le ruotine che cancellano le immagini per eseguire la cancellazione nel foglio "Filigrane" e la routina che rinomina le immagini per rinominare anche le immagini del suddetto foglio.

Questo il codice presente nel modulo VBA (riportato per intero):
'---
Option Explicit

'N.B. tra i riferimenti ho inserito il riferimento a Microsoft Forms 2.0 Object Library
'Un modo veloce per aggiungere il riferimento è, se non già presente, inserire una UserForm _
e nel caso eliminarla se non utilizzata


Sub ImportaImmagini()
Dim Wb As Workbook
Dim wsLink As Worksheet
Dim WsTmp As Worksheet
Dim wsImmagini As Worksheet
Dim wsFiligrane As Worksheet
Dim rngLink As Range
Dim DataObj As New DataObject
Dim IEobj As Object
Dim sURL As String, sNumCat As String
Dim sp As Shape
Dim sName As String
Dim r As Range
Dim iStep As Long
Dim NumLink As Long, iLink As Long
Dim bFiligrana As Boolean
Const DeltaStep = 25 'numero di celle tra una immagine di una Url e l'altra

Set Wb = ThisWorkbook
With Wb
Set wsLink = .Worksheets("Link")
Set WsTmp = .Worksheets("Tmp_Immagini")
Set wsImmagini = .Worksheets("Immagini")
Set wsFiligrane = .Worksheets("Filigrane")
End With
Set rngLink = wsLink.Range("A1").CurrentRegion.Columns(1)
NumLink = rngLink.Rows.Count
Set IEobj = CreateObject("InternetExplorer.Application")
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo Errore
Call CancellaWsImmagini
Call CancellaLinkFalliti
For Each r In rngLink.Cells
iLink = iLink + 1
Application.StatusBar = "Link " & iLink & " di " & NumLink & " in elaborazione."
sURL = r.Hyperlinks(1).Address 'prende l'indirizzo del link _
(da usare se le celle presentano un link)
'sUrl = r.Value 'prende il valore nella cella _
(da usare se le celle non presentano un link _
ma il valore della cella corrisponde all'intera URL)
sNumCat = r.Offset(, 1).Value
With IEobj
.Navigate sURL
Do Until .ReadyState = 4: TimerDelay (2): Loop
On Error Resume Next
With .Document
Do Until .ReadyState = "complete": TimerDelay: Loop
sName = .getElementById("name").InnerHtml
DataObj.SetText .DocumentElement.InnerHtml
End With
Err.Clear
On Error GoTo Errore
DataObj.PutInClipboard
End With
With wsImmagini
With .Range("A1")
With .Offset(iStep)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(iStep, 1) = sNumCat
.Offset(iStep + 1) = sName
End With
End With
With wsFiligrane
With .Range("A1")
With .Offset(iStep)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(iStep, 1) = sNumCat
.Offset(iStep + 1) = sName
End With
End With
With WsTmp
With .Range("A1")
.PasteSpecial xlPasteAll
End With
For Each sp In .Shapes
With sp
Select Case Left(.Name, Len("Picture"))
Case Is <> "Picture"
.Delete
Case Else
If Not .Visible Then
.Delete
Else
.Cut
If Not bFiligrana Then
wsImmagini.Range("A1").Offset(iStep + 2, 0).PasteSpecial
wsFiligrane.Range("A1").Offset(iStep + 2, 0).Value = "No Filigrana"
bFiligrana = True
Else
wsFiligrane.Range("A1").Offset(iStep + 2, 0).PasteSpecial
wsFiligrane.Range("A1").Offset(iStep + 2, 0).Value = Empty
End If
End If
End Select
End With
Next sp
End With
RiprendiErrore:
iStep = iStep + DeltaStep
'iLeft = 0
bFiligrana = False
If iLink Mod 100 = 0 Then
ThisWorkbook.Save
End If
Next r
Application.StatusBar = False
Call CancellaWsTemp
With wsImmagini
.Activate
.Range("A1").Activate
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
Call RinominaImmagini
IEobj.Quit
Set IEobj = Nothing
Exit Sub
Errore:
With ThisWorkbook.Worksheets("Link_Falliti")
With .Cells(.Rows.Count, 1).End(xlUp)
With .Offset(1, 0)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(1, 1).Value = "Errore n. " & Err.Number
.Offset(1, 2).Value = Err.Description
End With
End With
Err.Clear
Resume RiprendiErrore
End Sub

Sub CancellaWsTemp()
With ThisWorkbook
With .Worksheets("Tmp_Immagini")
.Cells.Clear
End With
End With
End Sub

Sub CancellaWsImmagini()
Dim sp As Shape
With ThisWorkbook
With .Worksheets("Immagini")
.Cells.Clear
For Each sp In .Shapes
sp.Delete
Next
End With
With .Worksheets("Filigrane")
.Cells.Clear
For Each sp In .Shapes
sp.Delete
Next
End With
End With
End Sub

Sub RinominaImmagini()
Dim sp As Shape
Dim cont As Long
With ThisWorkbook
With .Worksheets("Immagini")
For Each sp In .Shapes
cont = cont + 1
sp.Name = "Immagine " & cont
Next
End With
cont = 0
With .Worksheets("Filigrane")
For Each sp In .Shapes
cont = cont + 1
sp.Name = "Immagine " & cont
Next
End With
End With
End Sub

Sub CancellaLinkFalliti()
With ThisWorkbook.Worksheets("Link_Falliti").Range("A1").CurrentRegion
If .Rows.Count > 1 Then
.Offset(1).Resize(.Rows.Count - 1, 3).Clear
End If
End With
End Sub

Sub AddHyperLink(sURL As String, r As Range)
r.Parent.Hyperlinks.Add r, sURL, , , sURL
End Sub

Private Function TimerDelay(Optional Delay As Double)
Const vDelay As Double = 0.25
Dim vTimer As Double
If Delay = 0 Then Delay = vDelay
vTimer = Timer
Do While Timer < vTimer + Delay: Loop
End Function
'---

[draleo]

Post by casanmaner
https://www.dropbox.com/s/xd9tquqj5w3fk8x/Importare%20dati%20da%20pagina%20WEB%20%234.xlsm?dl=0
Ho inserito un foglio "Filigrane" dove vengono riportati gli stessi dati presenti nel foglio "Immagini" (tra cui eventuali valori inseriti in colonna B del foglio "Link").
Ho modificato la procedura principale "ImportaImmagini" per riportare le figligrane nel relativo foglio e per aggiungere alle descrizioni l'eventuale numero di catalogo presente nella colonna B del foglio "Link".
Ho anche modificato le ruotine che cancellano le immagini per eseguire la cancellazione nel foglio "Filigrane" e la routina che rinomina le immagini per rinominare anche le immagini del suddetto foglio.
'---
Option Explicit
'N.B. tra i riferimenti ho inserito il riferimento a Microsoft Forms 2.0 Object Library
'Un modo veloce per aggiungere il riferimento è, se non già presente, inserire una UserForm _
e nel caso eliminarla se non utilizzata
Sub ImportaImmagini()
Dim Wb As Workbook
Dim wsLink As Worksheet
Dim WsTmp As Worksheet
Dim wsImmagini As Worksheet
Dim wsFiligrane As Worksheet
Dim rngLink As Range
Dim DataObj As New DataObject
Dim IEobj As Object
Dim sURL As String, sNumCat As String
Dim sp As Shape
Dim sName As String
Dim r As Range
Dim iStep As Long
Dim NumLink As Long, iLink As Long
Dim bFiligrana As Boolean
Const DeltaStep = 25 'numero di celle tra una immagine di una Url e l'altra
Set Wb = ThisWorkbook
With Wb
Set wsLink = .Worksheets("Link")
Set WsTmp = .Worksheets("Tmp_Immagini")
Set wsImmagini = .Worksheets("Immagini")
Set wsFiligrane = .Worksheets("Filigrane")
End With
Set rngLink = wsLink.Range("A1").CurrentRegion.Columns(1)
NumLink = rngLink.Rows.Count
Set IEobj = CreateObject("InternetExplorer.Application")
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo Errore
Call CancellaWsImmagini
Call CancellaLinkFalliti
For Each r In rngLink.Cells
iLink = iLink + 1
Application.StatusBar = "Link " & iLink & " di " & NumLink & " in elaborazione."
sURL = r.Hyperlinks(1).Address 'prende l'indirizzo del link _
(da usare se le celle presentano un link)
'sUrl = r.Value 'prende il valore nella cella _
(da usare se le celle non presentano un link _
ma il valore della cella corrisponde all'intera URL)
sNumCat = r.Offset(, 1).Value
With IEobj
.Navigate sURL
Do Until .ReadyState = 4: TimerDelay (2): Loop
On Error Resume Next
With .Document
Do Until .ReadyState = "complete": TimerDelay: Loop
sName = .getElementById("name").InnerHtml
DataObj.SetText .DocumentElement.InnerHtml
End With
Err.Clear
On Error GoTo Errore
DataObj.PutInClipboard
End With
With wsImmagini
With .Range("A1")
With .Offset(iStep)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(iStep, 1) = sNumCat
.Offset(iStep + 1) = sName
End With
End With
With wsFiligrane
With .Range("A1")
With .Offset(iStep)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(iStep, 1) = sNumCat
.Offset(iStep + 1) = sName
End With
End With
With WsTmp
With .Range("A1")
.PasteSpecial xlPasteAll
End With
For Each sp In .Shapes
With sp
Select Case Left(.Name, Len("Picture"))
Case Is <> "Picture"
.Delete
Case Else
If Not .Visible Then
.Delete
Else
.Cut
If Not bFiligrana Then
wsImmagini.Range("A1").Offset(iStep + 2, 0).PasteSpecial
wsFiligrane.Range("A1").Offset(iStep + 2, 0).Value = "No Filigrana"
bFiligrana = True
Else
wsFiligrane.Range("A1").Offset(iStep + 2, 0).PasteSpecial
wsFiligrane.Range("A1").Offset(iStep + 2, 0).Value = Empty
End If
End If
End Select
End With
Next sp
End With
iStep = iStep + DeltaStep
'iLeft = 0
bFiligrana = False
If iLink Mod 100 = 0 Then
ThisWorkbook.Save
End If
Next r
Application.StatusBar = False
Call CancellaWsTemp
With wsImmagini
.Activate
.Range("A1").Activate
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
Call RinominaImmagini
IEobj.Quit
Set IEobj = Nothing
Exit Sub
With ThisWorkbook.Worksheets("Link_Falliti")
With .Cells(.Rows.Count, 1).End(xlUp)
With .Offset(1, 0)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(1, 1).Value = "Errore n. " & Err.Number
.Offset(1, 2).Value = Err.Description
End With
End With
Err.Clear
Resume RiprendiErrore
End Sub
Sub CancellaWsTemp()
With ThisWorkbook
With .Worksheets("Tmp_Immagini")
.Cells.Clear
End With
End With
End Sub
Sub CancellaWsImmagini()
Dim sp As Shape
With ThisWorkbook
With .Worksheets("Immagini")
.Cells.Clear
For Each sp In .Shapes
sp.Delete
Next
End With
With .Worksheets("Filigrane")
.Cells.Clear
For Each sp In .Shapes
sp.Delete
Next
End With
End With
End Sub
Sub RinominaImmagini()
Dim sp As Shape
Dim cont As Long
With ThisWorkbook
With .Worksheets("Immagini")
For Each sp In .Shapes
cont = cont + 1
sp.Name = "Immagine " & cont
Next
End With
cont = 0
With .Worksheets("Filigrane")
For Each sp In .Shapes
cont = cont + 1
sp.Name = "Immagine " & cont
Next
End With
End With
End Sub
Sub CancellaLinkFalliti()
With ThisWorkbook.Worksheets("Link_Falliti").Range("A1").CurrentRegion
If .Rows.Count > 1 Then
.Offset(1).Resize(.Rows.Count - 1, 3).Clear
End If
End With
End Sub
Sub AddHyperLink(sURL As String, r As Range)
r.Parent.Hyperlinks.Add r, sURL, , , sURL
End Sub
Private Function TimerDelay(Optional Delay As Double)
Const vDelay As Double = 0.25
Dim vTimer As Double
If Delay = 0 Then Delay = vDelay
vTimer = Timer
Do While Timer < vTimer + Delay: Loop
End Function
'---

Ok è tutto a posto. sto pensando a piccole modifiche (come rinominare le immagini in un altro modo , cioè assegnando ad esse un nome = al codice identificativo (sNumCat ) . Ma credo (spero) di poter fare da solo. In caso contrario è pronto il Gronchi rosa (quello buono, però; non uno di quelli falsi che si trovato in circolazione. Per ognuno buono ne circolano almeno 100 falsi, comprensivi di perizie di autenticità altrettanto false. Ciao
draleo

[Ammammata]

Il giorno Fri 17 Aug 2018 03:36:56p, *draleo* ha inviato su

Io ho già un database in Excel con tutte le caratteristiche dei
francobolli in questione (mancano solo le immagini); e accanto ad ogni
link, ho anche altri codici identificativi.

quindi, a degna conclusione di questo interessante thread, direi che
sarebbe bello e opportuno condividere il risultato di cotanta fatica,
quantomeno per avere una serie di immagini dei francobolli
italiani rinominate con il numero di catalogo p.e. del Bolaffi (a me
basterebbero e avanzerebbero)

http://www.catalogobolaffi.it/ws/get_emissione_detail/4079/Italia/

http://www.catalogobolaffi.it/ws/get_stamp_detail/2832/Italia/

[draleo]

Già...il problema ,che sto proprio tentando di risolvere -ci sono vicino- è proprio quello di dare alle immagini il num del catalogo. Altrimenti...è (quasi) fatica inutile. avere migliaia di immagini senza riuscire a classificarle con i rispettivi num di catalogo serve a ben poco. come fai a riconoscerle ? Inoltre per ora sono fermo a quelli della Gran Bretagna. Quando passerò all'Italia sarò ben felice di condividerle. Comunque il catalogo Bolaffi non so neanche se viene considerato sul sito da dove prelevo le immagini. Ti dovrai accontentare del Sassone( che è più professionale del Bolaffi). ma devo sbrigarmi, perché tra poco il sito passerà passerà a pagamento… e allora...ciao...
draleo

[casanmaner]

Il giorno lunedì 20 agosto 2018 18:55:03 UTC+2, draleo ha scritto:


Quali sono i problemi che riscontri?

[casanmaner]

Se vuoi prova a sostituire la routine "RinominaImmagini" con questa:

'---
Sub RinominaImmagini(NumeroLink As Long, DeltaStep As Long)
Dim i As Long, iDeltaStep As Long, ContFil As Long
For i = 1 To NumeroLink
With ThisWorkbook
With .Worksheets("Immagini")
.Shapes(i).Name = .Range("B1").Offset(iDeltaStep)
End With
With .Worksheets("Filigrane")
If .Range("A3").Offset(iDeltaStep).Value = "" Then
ContFil = ContFil + 1
.Shapes(ContFil).Name = .Range("B1").Offset(iDeltaStep)
End If
End With
iDeltaStep = iDeltaStep + DeltaStep
End With
Next i
End Sub
'---

E nella routine principale "ImportaImmagini" sostituiscie l'istruzione:

Call RinominaImmagini

con:

Call RinominaImmagini(iLink, DeltaStep)

Vedi la versione #5 (che in quanto non richiesta non fa scattare il Gronchi rosa :P :P :P :) ):
https://www.dropbox.com/s/44pzmf9ukco60ir/Importare%20dati%20da%20pagina%20WEB%20%235.xlsm?dl=0

[draleo]

Post by casanmaner
'---
Sub RinominaImmagini(NumeroLink As Long, DeltaStep As Long)
Dim i As Long, iDeltaStep As Long, ContFil As Long
For i = 1 To NumeroLink
With ThisWorkbook
With .Worksheets("Immagini")
.Shapes(i).Name = .Range("B1").Offset(iDeltaStep)
End With
With .Worksheets("Filigrane")
If .Range("A3").Offset(iDeltaStep).Value = "" Then
ContFil = ContFil + 1
.Shapes(ContFil).Name = .Range("B1").Offset(iDeltaStep)
End If
End With
iDeltaStep = iDeltaStep + DeltaStep
End With
Next i
End Sub
'---
Call RinominaImmagini
Call RinominaImmagini(iLink, DeltaStep)
https://www.dropbox.com/s/44pzmf9ukco60ir/Importare%20dati%20da%20pagina%20WEB%20%235.xlsm?dl=0

Hai anticipato la mia risposta che stavo scrivendo e che comunque propongo ugualmente. Stavo scrivendo:
Il problema è che vorrei rinominare le immagini (immagine1,immagine2, ecc) con i rispettivi num di catalogo (che sono già inseriti nel foglio LINK). Dal punto di vista del VBA avrei trovato la soluzione ,magari elementare - non sicuramente all’altezza di quelle di Casanamner o Norman o Bruno e altri- dai quali sono distante anni luce. Però nei test che ho fatto sembra funzionare bene . E se poi non funzionasse l’ottimo saprebbe ben consigliarmi. Quindi Il problema non è di codice VBA. Il problema è che quando si scaricano le immagini, qualcuna ne viene a mancare, credo per motivi di connessione . Se questo fatto viene segnalato nel foglio link falliti, non sarebbe un problema; purtroppo però capita –di rado, ma capita- che il link abbia funzionato, il num di catalogo è stato caricato, ma l’immagine non c’è. Allora la sequenza delle immagini non coincide più con la sequenza dei num di catalogo. Es: se la sequenza dei num di catalogo fosse: 1-2-3-4-5 mi aspetterei di scaricare 5 immagini; ma se invece ne scarica 4, allora le 2 sequenze sono diverse e la procedura per rinominarle, pur funzionando, da risultati errati. Ne basta una su 200 per vanificare tutto il lavoro. Allora il problema è : come identificare l’immagine mancante ?
ciao
draleo
PS: proverò la tua ulteriore soluzione, ma credo non sia un problema di VBA

[casanmaner]

Post by draleo
PS: proverò la tua ulteriore soluzione, ma credo non sia un problema di VBA

Se il problema è quello da te descritto anche la mia soluzione non funzionerebbe correttamente.

[casanmaner]

Considerata la problematica che hai esposta ho pensato di cambiare approcio per nominare le immagini cercando un "work around" al problema.
Non utilizzo più una distinta procedura per nominare le immagini ma sfruttando il fatto che una volta incollata, se è presente l'immagine, questa è selezionata assegno all'oggetto selezionato il nome in base alla variabile sNumCat.
Per fare ciò devo attivare il foglio di interesse (Immagini o Filigrane) di volta in volta e ogni volta, dopo aver assegnato il nome, selezionare anche una cella in modo da togliere quale seleziona attiva quella dell'utlima immagine copiata.
Questo potrebbe comportare un rallentamento.
Inoltre ho anche impostato ad 1 secondo - in precedenza non era indicato il tempo e quindi di defoult era di 0,25" - il tempo di ritardo in una riga di istruzione che verifica lo stato di aggiornamento del "documento web" caricato:
Do Until .ReadyState = "complete": TimerDelay (1): Loop
Magari questo maggior tempo potrebbe ridurre il numero di immagini non caricate.

Questa la versione #6 con le modifiche di cui ho detto:
https://www.dropbox.com/s/11gihklylj7br0j/Importare%20dati%20da%20pagina%20WEB%20%236.xlsm?dl=0

Questa la routine principale modificata:

'---

Sub ImportaImmagini()
Dim Wb As Workbook
Dim wsLink As Worksheet
Dim WsTmp As Worksheet
Dim wsImmagini As Worksheet
Dim wsFiligrane As Worksheet
Dim rngLink As Range
Dim DataObj As New DataObject
Dim IEobj As Object
Dim sURL As String, sNumCat As String
Dim sp As Shape
Dim sName As String
Dim r As Range
Dim iStep As Long
Dim NumLink As Long, iLink As Long
Dim bFiligrana As Boolean
Const DeltaStep = 25 'numero di celle tra una immagine di una Url e l'altra

Set Wb = ThisWorkbook
With Wb
Set wsLink = .Worksheets("Link")
Set WsTmp = .Worksheets("Tmp_Immagini")
Set wsImmagini = .Worksheets("Immagini")
Set wsFiligrane = .Worksheets("Filigrane")
End With
Set rngLink = wsLink.Range("A1").CurrentRegion.Columns(1)
NumLink = rngLink.Rows.Count
Set IEobj = CreateObject("InternetExplorer.Application")
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo Errore
Call CancellaWsImmagini
Call CancellaLinkFalliti
For Each r In rngLink.Cells
iLink = iLink + 1
Application.StatusBar = "Link " & iLink & " di " & NumLink & " in elaborazione."
sURL = r.Hyperlinks(1).Address 'prende l'indirizzo del link _
(da usare se le celle presentano un link)
'sUrl = r.Value 'prende il valore nella cella _
(da usare se le celle non presentano un link _
ma il valore della cella corrisponde all'intera URL)
sNumCat = r.Offset(, 1).Value
With IEobj
.Navigate sURL
Do Until .ReadyState = 4: TimerDelay (4): Loop
On Error Resume Next
With .Document
Do Until .ReadyState = "complete": TimerDelay (1): Loop
sName = .getElementById("name").InnerHtml
DataObj.SetText .DocumentElement.InnerHtml
End With
Err.Clear
On Error GoTo Errore
DataObj.PutInClipboard
End With
With wsImmagini
With .Range("A1")
With .Offset(iStep)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(iStep, 1) = sNumCat
.Offset(iStep + 1) = sName
End With
End With
With wsFiligrane
With .Range("A1")
With .Offset(iStep)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(iStep, 1) = sNumCat
.Offset(iStep + 1) = sName
End With
End With
With WsTmp
With .Range("A1")
.PasteSpecial xlPasteAll
End With
For Each sp In .Shapes
With sp
Select Case Left(.Name, Len("Picture"))
Case Is <> "Picture"
.Delete
Case Else
If Not .Visible Then
.Delete
Else
.Cut
If Not bFiligrana Then
With wsImmagini
.Activate
.Range("A1").Offset(iStep + 2, 0).PasteSpecial
If TypeName(Selection) = "Picture" Then
Selection.Name = sNumCat
Debug.Print Selection.Name
End If
.Range("A1").Select
End With
wsFiligrane.Range("A1").Offset(iStep + 2, 0).Value = "No Filigrana"
bFiligrana = True
Else
With wsFiligrane
.Activate
.Range("A1").Offset(iStep + 2, 0).PasteSpecial
If TypeName(Selection) = "Picture" Then
Selection.Name = sNumCat
Debug.Print Selection.Name
End If
.Range("A1").Select
.Range("A1").Offset(iStep + 2, 0).Value = Empty
End With
End If
End If
End Select
End With
Next sp
End With
RiprendiErrore:
iStep = iStep + DeltaStep
bFiligrana = False
If iLink Mod 100 = 0 Then
ThisWorkbook.Save
End If
Next r
Application.StatusBar = False
Call CancellaWsTemp
With wsImmagini
.Activate
.Range("A1").Activate
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
'Call RinominaImmagini(iLink, DeltaStep)
IEobj.Quit
Set IEobj = Nothing
Exit Sub
Errore:
With ThisWorkbook.Worksheets("Link_Falliti")
With .Cells(.Rows.Count, 1).End(xlUp)
With .Offset(1, 0)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(1, 1).Value = "Errore n. " & Err.Number
.Offset(1, 2).Value = Err.Description
End With
End With
Err.Clear
Resume RiprendiErrore
End Sub
'---

Facendo una prova con tempi ridotti, e dove in un caso non si è caricata nemmeno una immagine e in altri casi è saltata la prima, i nomi delle immagini caricate mi sono sembrate corrispondenti ai nomi di catalogo che nel file di prova ho inserito.

Vedi se in qualche modo risolve il problema.

[casanmaner]

p.s. nella versione del codice prensente nella cartella di lavoro excel ho eliminato le due istruzioni Debug.Print ...

[draleo]

Post by casanmaner
p.s. nella versione del codice prensente nella cartella di lavoro excel ho eliminato le due istruzioni Debug.Print ...

Si, credo proprio che stavolta sei riuscito a risolvere anche i problemi di rete…. L'ho letta senza provarla a fondo, perchè dove sono ho poca connessione; domani scaricherò qualche 100ia di link, ma l'impressione è comunque ottima.
E Potrò cominciare a lavorare sul serio.
Ti sei ampiamente meritato il Gronchi Rosa
Ti farò sapere
draleo

[Ammammata]

Il giorno Mon 20 Aug 2018 09:47:41p, *draleo* ha inviato su
microsoft.public.it.office.excel il messaggio news:716549d1-78aa-4338-9e3a-

Post by draleo
Ti sei ampiamente meritato il Gronchi Rosa

possibilmente uno dei pochi con il timbro di posta aerea del giorno
dell'emissione ;)

[draleo]

Post by Ammammata
Il giorno Mon 20 Aug 2018 09:47:41p, *draleo* ha inviato su
microsoft.public.it.office.excel il messaggio news:716549d1-78aa-4338-9e3a-

Post by draleo
Ti sei ampiamente meritato il Gronchi Rosa

possibilmente uno dei pochi con il timbro di posta aerea del giorno
dell'emissione ;)

Troppa grazia…Il Gronchi Rosa Nuovo è già una rarità; ma usato (con timbro del giorno di emissione 3/04//1961) è una mosca bianca. E' stato emesso il 03/04/1961 (giorno di Pasquetta !) e il giorno dopo era già stato ritirato e dichiarato non più utilizzabile (perché errato). Certo, se ne trovano molti in giro, ma il 99,99999 % sono falsi. E i pochissimi -non io- che hanno l' originale, se lo tengono ben stretto
draleo

[draleo]

Post by casanmaner
p.s. nella versione del codice prensente nella cartella di lavoro excel ho eliminato le due istruzioni Debug.Print ...

Ok. ottimo( e non lo dubitavo). ho scaricato un 1000io di Link (in 3-4 riprese)e non si sono verificati più i problemi riferiti ieri. Ora ho lo strumento adatto per scaricare tutte le immagini che voglio. Ma la storia infinita continua; perché adesso , per utilizzarle, devo trovare il modo di esportarle dal file Excel, in una nuova cartella, però MANTENENDO il NOME GIA' ASSEGNATO alle stesse. Ho già provato un Add In (extract images from document), ma questo mi cambia il nome delle immagini in Image1-Image2 ecc vanificando tutto il gran lavoro di Casanmaner. Quindi non è utilizzabile. se qualcuno conosce altri programmi, sono graditi suggerimenti
draleo

[casanmaner]

Post by draleo

Post by casanmaner
p.s. nella versione del codice prensente nella cartella di lavoro excel ho eliminato le due istruzioni Debug.Print ...

Ok. ottimo( e non lo dubitavo). ho scaricato un 1000io di Link (in 3-4 riprese)e non si sono verificati più i problemi riferiti ieri. Ora ho lo strumento adatto per scaricare tutte le immagini che voglio. Ma la storia infinita continua; perché adesso , per utilizzarle, devo trovare il modo di esportarle dal file Excel, in una nuova cartella, però MANTENENDO il NOME GIA' ASSEGNATO alle stesse. Ho già provato un Add In (extract images from document), ma questo mi cambia il nome delle immagini in Image1-Image2 ecc vanificando tutto il gran lavoro di Casanmaner. Quindi non è utilizzabile. se qualcuno conosce altri programmi, sono graditi suggerimenti
draleo

Forse si potrebbe adattare questa procedura che il buon Norman aveva scritto per te:

https://groups.google.com/forum/#!searchin/microsoft.public.it.office.excel/salvare$20immagini$20da$20file%7Csort:date/microsoft.public.it.office.excel/JMj6zp9u50Y/z2Z__9zcBwAJ

[draleo]

Post by casanmaner
https://groups.google.com/forum/#!searchin/microsoft.public.it.office.excel/salvare$20immagini$20da$20file%7Csort:date/microsoft.public.it.office.excel/JMj6zp9u50Y/z2Z__9zcBwAJ

Neanche mi ricordavo...Ma riguardandolo mi sembra che trasformi in immagine Jpg il contenuto 1 o più range. Ma nel nostro caso le immagini non sono dentro le celle, ma attaccate ad esse. dici che si può fare ?

draleo

[casanmaner]

Post by draleo

Post by casanmaner
https://groups.google.com/forum/#!searchin/microsoft.public.it.office.excel/salvare$20immagini$20da$20file%7Csort:date/microsoft.public.it.office.excel/JMj6zp9u50Y/z2Z__9zcBwAJ

Neanche mi ricordavo...Ma riguardandolo mi sembra che trasformi in immagine Jpg il contenuto 1 o più range. Ma nel nostro caso le immagini non sono dentro le celle, ma attaccate ad esse. dici che si può fare ?
draleo

Vedi questa versione #7:
https://www.dropbox.com/s/hhgent5amf41zah/Importare%20dati%20da%20pagina%20WEB%20%237.xlsm?dl=0

Quello che ottengo, per i francobolli e filigrane, sono queste immagini (c'è un po' di "bordino" del grafico):
Loading Image...
Loading Image...

Al file Excel ho aggiunto un foglio con un grafico in modo che nel grafico venga incollata l'immagine selezionata.
Così come per assegnare il nome dell'immagine selezionata eseguo una copia e la incollo nel grafico ed eseguo l'esportazione in due cartelle (che dovrai aver creato e indicato nelle due costanti:
Const sPathFrancobolli
Const sPathFiligrane As String

Ho quindi così modificato la routine "ImportaImmagini":

'---

Sub ImportaImmagini()
Dim Wb As Workbook
Dim wsLink As Worksheet
Dim WsTmp As Worksheet
Dim wsImmagini As Worksheet
Dim wsFiligrane As Worksheet
Dim WsChart As Worksheet
Dim oChart As ChartObject
Dim rngLink As Range
Dim DataObj As New DataObject
Dim IEobj As Object
Dim sURL As String, sNumCat As String
Dim sp As Shape
Dim sName As String
Dim r As Range
Dim iStep As Long
Dim NumLink As Long, iLink As Long
Dim bFiligrana As Boolean
Const DeltaStep = 25 'numero di celle tra una immagine di una Url e l'altra
Const sPathFrancobolli As String = "D:\Test\Francobolli\"
Const sPathFiligrane As String = "D:\Test\Filigrane\"

Set Wb = ThisWorkbook
With Wb
Set wsLink = .Worksheets("Link")
Set WsTmp = .Worksheets("Tmp_Immagini")
Set wsImmagini = .Worksheets("Immagini")
Set wsFiligrane = .Worksheets("Filigrane")
Set WsChart = .Worksheets("Grafico")
End With
Set rngLink = wsLink.Range("A1").CurrentRegion.Columns(1)
Set oChart = WsChart.ChartObjects("Grafico 1")
NumLink = rngLink.Rows.Count
Set IEobj = CreateObject("InternetExplorer.Application")
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo Errore
Call CancellaWsImmagini
Call CancellaLinkFalliti
For Each r In rngLink.Cells
iLink = iLink + 1
Application.StatusBar = "Link " & iLink & " di " & NumLink & " in elaborazione."
sURL = r.Hyperlinks(1).Address 'prende l'indirizzo del link _
(da usare se le celle presentano un link)
'sUrl = r.Value 'prende il valore nella cella _
(da usare se le celle non presentano un link _
ma il valore della cella corrisponde all'intera URL)
sNumCat = r.Offset(, 1).Value
With IEobj
.Navigate sURL
Do Until .ReadyState = 4: TimerDelay (4): Loop
On Error Resume Next
With .Document
Do Until .ReadyState = "complete": TimerDelay (1): Loop
sName = .getElementById("name").InnerHtml
DataObj.SetText .DocumentElement.InnerHtml
End With
Err.Clear
On Error GoTo Errore
DataObj.PutInClipboard
End With
With wsImmagini
With .Range("A1")
With .Offset(iStep)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(iStep, 1) = sNumCat
.Offset(iStep + 1) = sName
End With
End With
With wsFiligrane
With .Range("A1")
With .Offset(iStep)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(iStep, 1) = sNumCat
.Offset(iStep + 1) = sName
End With
End With
With WsTmp
With .Range("A1")
.PasteSpecial xlPasteAll
End With
For Each sp In .Shapes
With sp
Select Case Left(.Name, Len("Picture"))
Case Is <> "Picture"
.Delete
Case Else
If Not .Visible Then
.Delete
Else
.Cut
If Not bFiligrana Then
With wsImmagini
.Activate
.Range("A1").Offset(iStep + 2, 0).PasteSpecial
If TypeName(Selection) = "Picture" Then
With Selection
.Name = sNumCat
.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
With oChart.Chart
.Paste
.Export sPathFrancobolli & SostituisciCaratteriVietatiNomiFile(sNumCat) & ".jpg"
End With
End With
End If
.Range("A1").Select
End With
wsFiligrane.Range("A1").Offset(iStep + 2, 0).Value = "No Filigrana"
bFiligrana = True
Else
With wsFiligrane
.Activate
.Range("A1").Offset(iStep + 2, 0).PasteSpecial
If TypeName(Selection) = "Picture" Then
With Selection
.Name = sNumCat
.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
With oChart.Chart
.Paste
.Export sPathFiligrane & SostituisciCaratteriVietatiNomiFile(sNumCat) & ".jpg"
End With
End With
End If
.Range("A1").Select
.Range("A1").Offset(iStep + 2, 0).Value = Empty
End With
End If
End If
End Select
End With
Next sp
End With
RiprendiErrore:
iStep = iStep + DeltaStep
bFiligrana = False
If iLink Mod 100 = 0 Then
ThisWorkbook.Save
End If
Next r
Application.StatusBar = False
Call CancellaWsTemp
With wsImmagini
.Activate
.Range("A1").Activate
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
IEobj.Quit
Set IEobj = Nothing
Exit Sub
Errore:
With ThisWorkbook.Worksheets("Link_Falliti")
With .Cells(.Rows.Count, 1).End(xlUp)
With .Offset(1, 0)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(1, 1).Value = "Errore n. " & Err.Number
.Offset(1, 2).Value = Err.Description
End With
End With
Err.Clear
Resume RiprendiErrore
End Sub
'---

Nota che nel modulo1, alla fine, ho aggiunto una funzione "SostituisciCaratteriVietatiNomiFile" che sostituisce eventuali caratteri vietati per i nomi dei file presenti in "sNumCat".
Nella funzione i caratteri vietati vengono sostituiti con l'underscore "_" ma se tu volessi un altro carattere (es. il trattino "-") ti basterebbe modificare, nella funzione, la costante Const CarattereSostitutivo).

Questa la funzione aggiunta:

'---
Function SostituisciCaratteriVietatiNomiFile(str As String) As String
Dim i As Long
Dim ArrayCaratteriVietati As Variant
Const CarattereSostitutivo As String = "_"
ArrayCaratteriVietati = Array("\", "/", ":", "?", """", "<", ">", "|")
For i = LBound(ArrayCaratteriVietati) To UBound(ArrayCaratteriVietati)
str = Replace(str, ArrayCaratteriVietati(i), CarattereSostitutivo)
Next i
SostituisciCaratteriVietatiNomiFile = str
End Function
'---

Prova a vedere se così ottieni delle immagini accettabili

ciao

[casanmaner]

Ciao Draleo,
mi è venuto in mente che i francobolli potrebbero avere dimensioni differenti dai 3 del test e che quindi anche il grafico utilizzato al fine dell'esportazione dovrebbe essere impostato in base alle dimensioni del francobollo.
Inoltre le immagini copiate nel grafico si "accavallano" l'una sull'altra.
Ho quindi modificato la procedura "ImportaImmagini" per fare in modo che il grafico assuma le dimensioni dell'immagine di volta in volta caricata e che l'immagine copiata, dopo essere stata esportata nel file jpg, venga cancellata dal grafico.

Vedi una versione "b" del file precedente:
https://www.dropbox.com/s/9ejb55ema6r936b/Importare%20dati%20da%20pagina%20WEB%20%237b.xlsm?dl=0

Questo il codice della routine con le modifiche:
'---
Sub ImportaImmagini()
Dim Wb As Workbook
Dim wsLink As Worksheet
Dim WsTmp As Worksheet
Dim wsImmagini As Worksheet
Dim wsFiligrane As Worksheet
Dim WsChart As Worksheet
Dim oChart As ChartObject
Dim rngLink As Range
Dim DataObj As New DataObject
Dim IEobj As Object
Dim sURL As String, sNumCat As String
Dim sp As Shape
Dim sName As String
Dim r As Range
Dim iStep As Long
Dim NumLink As Long, iLink As Long
Dim bFiligrana As Boolean
Dim iWidth As Double, iHeight As Double
Const DeltaStep = 25 'numero di celle tra una immagine di una Url e l'altra
Const sPathFrancobolli As String = "D:\Test\Francobolli\"
Const sPathFiligrane As String = "D:\Test\Filigrane\"

Set Wb = ThisWorkbook
With Wb
Set wsLink = .Worksheets("Link")
Set WsTmp = .Worksheets("Tmp_Immagini")
Set wsImmagini = .Worksheets("Immagini")
Set wsFiligrane = .Worksheets("Filigrane")
Set WsChart = .Worksheets("Grafico")
End With
Set rngLink = wsLink.Range("A1").CurrentRegion.Columns(1)
Set oChart = WsChart.ChartObjects("Grafico 1")
NumLink = rngLink.Rows.Count
Set IEobj = CreateObject("InternetExplorer.Application")
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo Errore
Call CancellaWsImmagini
Call CancellaLinkFalliti
For Each r In rngLink.Cells
iLink = iLink + 1
Application.StatusBar = "Link " & iLink & " di " & NumLink & " in elaborazione."
sURL = r.Hyperlinks(1).Address 'prende l'indirizzo del link _
(da usare se le celle presentano un link)
'sUrl = r.Value 'prende il valore nella cella _
(da usare se le celle non presentano un link _
ma il valore della cella corrisponde all'intera URL)
sNumCat = r.Offset(, 1).Value
With IEobj
.Navigate sURL
Do Until .ReadyState = 4: TimerDelay (4): Loop
On Error Resume Next
With .Document
Do Until .ReadyState = "complete": TimerDelay (1): Loop
sName = .getElementById("name").InnerHtml
DataObj.SetText .DocumentElement.InnerHtml
End With
Err.Clear
On Error GoTo Errore
DataObj.PutInClipboard
End With
With wsImmagini
With .Range("A1")
With .Offset(iStep)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(iStep, 1) = sNumCat
.Offset(iStep + 1) = sName
End With
End With
With wsFiligrane
With .Range("A1")
With .Offset(iStep)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(iStep, 1) = sNumCat
.Offset(iStep + 1) = sName
End With
End With
With WsTmp
With .Range("A1")
.PasteSpecial xlPasteAll
End With
For Each sp In .Shapes
With sp
Select Case Left(.Name, Len("Picture"))
Case Is <> "Picture"
.Delete
Case Else
If Not .Visible Then
.Delete
Else
.Cut
If Not bFiligrana Then
With wsImmagini
.Activate
.Range("A1").Offset(iStep + 2, 0).PasteSpecial
If TypeName(Selection) = "Picture" Then
With Selection
.Name = sNumCat
.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
iWidth = .Width
iHeight = .Height
With oChart
.Height = iHeight
.Width = iWidth
With .Chart
.Paste
.Export sPathFrancobolli & SostituisciCaratteriVietatiNomiFile(sNumCat) & ".jpg"
.Shapes(1).Delete
End With
End With
End With
End If
.Range("A1").Select
End With
wsFiligrane.Range("A1").Offset(iStep + 2, 0).Value = "No Filigrana"
bFiligrana = True
Else
With wsFiligrane
.Activate
.Range("A1").Offset(iStep + 2, 0).PasteSpecial
If TypeName(Selection) = "Picture" Then
With Selection
.Name = sNumCat
.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
With oChart.Chart
.Paste
.Export sPathFiligrane & SostituisciCaratteriVietatiNomiFile(sNumCat) & ".jpg"
.Shapes(1).Delete
End With
End With
End If
.Range("A1").Select
.Range("A1").Offset(iStep + 2, 0).Value = Empty
End With
End If
End If
End Select
End With
Next sp
End With
RiprendiErrore:
iStep = iStep + DeltaStep
bFiligrana = False
If iLink Mod 100 = 0 Then
ThisWorkbook.Save
End If
Next r
Application.StatusBar = False
Call CancellaWsTemp
With wsImmagini
.Activate
.Range("A1").Activate
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
IEobj.Quit
Set IEobj = Nothing
Exit Sub
Errore:
With ThisWorkbook.Worksheets("Link_Falliti")
With .Cells(.Rows.Count, 1).End(xlUp)
With .Offset(1, 0)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(1, 1).Value = "Errore n. " & Err.Number
.Offset(1, 2).Value = Err.Description
End With
End With
Err.Clear
Resume RiprendiErrore
End Sub
'---

[casanmaner]

Post by casanmaner
If TypeName(Selection) = "Picture" Then
With Selection
.Name = sNumCat
.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
With oChart.Chart
.Paste
.Export sPathFiligrane & SostituisciCaratteriVietatiNomiFile(sNumCat) & ".jpg"
.Shapes(1).Delete
End With
End With
End If

Ops ... mi ero dimenticato di inserire le istruzioni per impostare le dimensioni del grafico per le filigrane.
Nel file il codice è stato correto.

[draleo]

Post by casanmaner

Post by casanmaner
If TypeName(Selection) = "Picture" Then
With Selection
.Name = sNumCat
.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
With oChart.Chart
.Paste
.Export sPathFiligrane & SostituisciCaratteriVietatiNomiFile(sNumCat) & ".jpg"
.Shapes(1).Delete
End With
End With
End If

Ops ... mi ero dimenticato di inserire le istruzioni per impostare le dimensioni del grafico per le filigrane.
Nel file il codice è stato correto.

Bravissimo. E’ tutto OK. La qualità delle immagini è buona. Le dimensioni rimangono quelle originali del sito (anche in fase di stampa).
Anche se , purtroppo, sul sito non hanno rispettato le dimensioni “reali” dei Francobolli. (sono più grandi). E non hanno neanche rispettato delle proporzioni di maggiorazione uniformi per tutti i francobolli: quelli più piccoli sono cica 3 volte quelli reali, mentre per quelli più grandi il rapporto è tra 1.5 e 2. Quindi non si possono neanche ridimensionare in un colpo solo . Comunque –salvo sorprese - siamo finalmente e ottimamente arrivati alla quadratura del cerchio.
Grazie. Ti contatto (dovrei avere la tua mail)
draleo
Ps: solo una curiosità. Perchè passando il mouse sulle immagini jpg esportate nella nuova cartella, vedo delle dimensioni diverse ? sono dimensioni in pixel, in pollici ? sicuramente non sono in cm, perché stampando l'immagine le dimensioni vengono poi uguali a quelle del file Excel e di quelle del sito

[Ammammata]

Il giorno Wed 08 Aug 2018 09:09:16p, *draleo* ha inviato su

Post by draleo
Grazie. Ti do 3 link. Sono centinaia. Per ciascuno dovrei estrarre
(copiare,salvare) dalla pagina le immagini Jpg, se possibile
;altrimenti l'intera pagina .troverò poi il modo per eliminare quello
che non Ú immagine Jpg
http://colnect.com/stamps/stamp/1443
http://colnect.com/stamps/stamp/1444
http://colnect.com/stamps/stamp/527899

ho notato che all'interno della pagina html che viene caricata ci sono in
chiaro sia i numeri di catalogo

<title>Francobollo: Queen Victoria (Gran Bretagna) (Regina Vittoria -
superficie stampata) Mi:GB 14,Sn:GB 27,Yt:GB 19,Sg:GB 69,AFA:GB 14</title>

che il link per recuperare l'immagine

<meta property="og:image"
content="//i.colnect.net/f/121/195/Queen_Victoria.jpg"/>

nota: prima di // ci va https:

però ho provato un paio di "mass downloader" (winwget, visualwget) senza
riuscire a salvare i vari html :(

[draleo]

Post by Ammammata
ho notato che all'interno della pagina html che viene caricata ci sono in
chiaro sia i numeri di catalogo

Si certo .c'è la scheda con tutte le caratteristiche del francobollo; comprese le numerazioni dei vari cataloghi internazionali
Mi= Michelle (Tedesco) Yt= Yvert Teller (Francese)
Sg= Stanley Gibbons (Inglese) ecc ecc. Ma questi dati io li ho già tutti scaricati in passato. L'unica cosa che mi mancava sono le immagini.
Per vederle basterebbe clikkare sul link (come facevo sempre prima). Ma avere l'intero DB nel proprio PC è molto più veloce, più economico e più performante (sono in grado di estrarre con pochi clik tutto quello che voglio)

Post by Ammammata
però ho provato un paio di "mass downloader" (winwget, visualwget) senza
riuscire a salvare i vari html :(

non capisco cosa volevi fare

draleo

[draleo]

Lavorandoci un piccolo bug l'ho trovato: ad ogni importazione la prima immagine della filigrana (e SOLO la prima) viene messa nella cartella delle immagini (e non in quella delle filigrane), sostituendo la prima immagine, che quindi viene a mancare
draleo

[casanmaner]

Post by draleo
Lavorandoci un piccolo bug l'ho trovato: ad ogni importazione la prima immagine della filigrana (e SOLO la prima) viene messa nella cartella delle immagini (e non in quella delle filigrane), sostituendo la prima immagine, che quindi viene a mancare
draleo

Ciao,
ho appena provato, con i sei link dell'ultimo file #7b, e io ottengo questo nei due distinti percorsi:
Loading Image...

Tu cosa fai esattamente?

[draleo]

Post by casanmaner

Post by draleo
Lavorandoci un piccolo bug l'ho trovato: ad ogni importazione la prima immagine della filigrana (e SOLO la prima) viene messa nella cartella delle immagini (e non in quella delle filigrane), sostituendo la prima immagine, che quindi viene a mancare
draleo

Ciao,
https://www.dropbox.com/s/ts42hvb381e5oiw/Screenshot%202018-08-23%2015.46.32.png?dl=0
Tu cosa fai esattamente?

Vedo le stesse immagini che vedi tu. cioè il problema con i 6 link di test non si presenta. Ma ieri avevo effettuato 2 massicci importazioni di circa 400 link
ciascuno e in entrambi i casi si era verificato. La prima volta avevo pensato a qualche mio errore; ma si era ripresentato anche la seconda volta. Non che sia importante, perché a sostituire una sola immagine (perché solo della prima si tratta)non ci vuole molto. Comunque ora provo con altri 400 link. Stasera riferisco
draleo

[casanmaner]

Ma tu come procedi esattamente?
Copi i link nel file e poi lanci la procedura dal pulsante?
Fai altri passaggi prima di far partire la macro.

[draleo]

Post by casanmaner
Ma tu come procedi esattamente?
Copi i link nel file e poi lanci la procedura dal pulsante?
Fai altri passaggi prima di far partire la macro.

Prima cancello i link precedenti con un altro pulsante inserito e collegato alla macro sotto e poi clikko sul pulsante Importaimmagini. ma non credo sia questa la causa. stasera vediamo se si ripresenta

Sub CancellaLink()
Dim r As Long
With ThisWorkbook
With .Worksheets("Link")
r = .Range("A65536").End(xlUp).Row
.Range("A1:B" & r).Clear
End With
End With
End Sub

[draleo]

Bohh.. Ho fatto un download di 500 link e tutto è andato a buon fine. Mi sono ricordato però che ieri il bug si era presentato dopo che io avevo sbagliato a scrivere il percorso delle 2 cartelle di destinazione. oggi ho volutamente ripetuto l' errore (inserendo 2 percorsi che non esistevano) e ho notato che:
la procedura va avanti ugualmente
le immagini naturalmente non vengono esportate
le immagini e le filigrane vengono mescolate alternativamente nel foglio immagini. e quindi effettivamente si verifica un po' di casino. Forse sarebbe meglio che, prima di partire con il download , si verificasse l'esistenza delle 2 cartelle e in caso negativo si esca dalla procedura (anche per guadagnar tempo, perché accorgersi di aver sbagliato a digitare dopo 2-3 ore di attesa, fa un po' incazzare con se stessi. Comunque domani farò altre verifiche per appurare se effettivamente è stata questa la causa

draleo

[casanmaner]

Vedi questa versione #8:
https://www.dropbox.com/s/g5584vdj6rci1h5/Importare%20dati%20da%20pagina%20WEB%20%238.xlsm?dl=0

Ho inserito una sezione, nella routine principale, per la gestione dei percorsi.
Le costanti sono state inserite in altro come prime "dichiarazioni" della routine.
Se i percorsi non contengono la barra finale questa viene aggiunta.
Viene fatto un controllo se esiste il Drive indicato nel percorso.
Se non esiste viene interrotta l'esecuzione.
Se il drive esiste viene verificato che non si tratti di un drive "sconosciuto" o cd-rom o un drive ram. In questi casi la procedura viene interrotta.
Come ultimo controllo viene verificato se i due percorsi esistono. Se non esistono vengono creati.
Alla fine della procedura vengon aperti i percorsi dove sono state salvate le immagini.

Questo è il testo della routine modificata:
'---

Sub ImportaImmagini()

Const DeltaStep = 25 'numero di celle tra una immagine di una Url e l'altra
Const sPathFrancobolli As String = "D:\Test\Francobolli\"
Const sPathFiligrane As String = "D:\Test\Filigrane\"

Dim Wb As Workbook
Dim wsLink As Worksheet
Dim WsTmp As Worksheet
Dim wsImmagini As Worksheet
Dim wsFiligrane As Worksheet
Dim WsChart As Worksheet
Dim oChart As ChartObject
Dim rngLink As Range
Dim DataObj As New DataObject
Dim IEobj As Object
Dim sURL As String, sNumCat As String
Dim sp As Shape
Dim sName As String
Dim r As Range
Dim iStep As Long
Dim NumLink As Long, iLink As Long
Dim bFiligrana As Boolean
Dim iWidth As Double, iHeight As Double
Dim sPath1 As String, sPath2 As String
Dim sDrive1 As String, sDrive2 As String

'<--- gestione percorsi salvataggio file immagini --->
sPath1 = sPathFrancobolli
If Right(sPath1, 1) <> "\" Then sPath1 = sPath1 & "\"
sPath2 = sPathFiligrane
If Right(sPath2, 1) <> "\" Then sPath2 = sPath2 & "\"
sDrive1 = Left(sPath1, 2)
sDrive2 = Left(sPath2, 2)
With CreateObject("Scripting.FileSystemObject")
If Not .DriveExists(Left(sPath1, 2)) Then Exit Sub
If Not .DriveExists(Left(sPath2, 2)) Then Exit Sub
Select Case .GetDrive(sDrive1).DriveType
Case 0, 4, 5
Exit Sub
End Select
Select Case .GetDrive(sDrive2).DriveType
Case 0, 4, 5
Exit Sub
End Select
If Not .FolderExists(sPath1) Then .CreateFolder sPath1
If Not .FolderExists(sPath2) Then .CreateFolder sPath2
End With
'</--- gestione percorsi salvataggio file immagini --->

Set Wb = ThisWorkbook
With Wb
Set wsLink = .Worksheets("Link")
Set WsTmp = .Worksheets("Tmp_Immagini")
Set wsImmagini = .Worksheets("Immagini")
Set wsFiligrane = .Worksheets("Filigrane")
Set WsChart = .Worksheets("Grafico")
End With
Set rngLink = wsLink.Range("A1").CurrentRegion.Columns(1)
Set oChart = WsChart.ChartObjects("Grafico 1")
NumLink = rngLink.Rows.Count
Set IEobj = CreateObject("InternetExplorer.Application")
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo Errore
Call CancellaWsImmagini
Call CancellaLinkFalliti
For Each r In rngLink.Cells
iLink = iLink + 1
Application.StatusBar = "Link " & iLink & " di " & NumLink & " in elaborazione."
sURL = r.Hyperlinks(1).Address 'prende l'indirizzo del link _
(da usare se le celle presentano un link)
'sUrl = r.Value 'prende il valore nella cella _
(da usare se le celle non presentano un link _
ma il valore della cella corrisponde all'intera URL)
sNumCat = r.Offset(, 1).Value
With IEobj
.Navigate sURL
Do Until .ReadyState = 4: TimerDelay (4): Loop
On Error Resume Next
With .Document
Do Until .ReadyState = "complete": TimerDelay (1): Loop
sName = .getElementById("name").InnerHtml
DataObj.SetText .DocumentElement.InnerHtml
End With
Err.Clear
On Error GoTo Errore
DataObj.PutInClipboard
End With
With wsImmagini
With .Range("A1")
With .Offset(iStep)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(iStep, 1) = sNumCat
.Offset(iStep + 1) = sName
End With
End With
With wsFiligrane
With .Range("A1")
With .Offset(iStep)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(iStep, 1) = sNumCat
.Offset(iStep + 1) = sName
End With
End With
With WsTmp
With .Range("A1")
.PasteSpecial xlPasteAll
End With
For Each sp In .Shapes
With sp
Select Case Left(.Name, Len("Picture"))
Case Is <> "Picture"
.Delete
Case Else
If Not .Visible Then
.Delete
Else
.Cut
If Not bFiligrana Then
With wsImmagini
.Activate
.Range("A1").Offset(iStep + 2, 0).PasteSpecial
If TypeName(Selection) = "Picture" Then
With Selection
.Name = sNumCat
.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
iWidth = .Width
iHeight = .Height
With oChart
.Height = iHeight
.Width = iWidth
With .Chart
.Paste
.Export sPathFrancobolli & SostituisciCaratteriVietatiNomiFile(sNumCat) & ".jpg"
.Shapes(1).Delete
End With
End With
End With
End If
.Range("A1").Select
End With
wsFiligrane.Range("A1").Offset(iStep + 2, 0).Value = "No Filigrana"
bFiligrana = True
Else
With wsFiligrane
.Activate
.Range("A1").Offset(iStep + 2, 0).PasteSpecial
If TypeName(Selection) = "Picture" Then
With Selection
.Name = sNumCat
.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
iWidth = .Width
iHeight = .Height
With oChart
.Height = iHeight
.Width = iWidth
With .Chart
.Paste
.Export sPathFiligrane & SostituisciCaratteriVietatiNomiFile(sNumCat) & ".jpg"
.Shapes(1).Delete
End With
End With
End With
End If
.Range("A1").Select
.Range("A1").Offset(iStep + 2, 0).Value = Empty
End With
End If
End If
End Select
End With
Next sp
End With
RiprendiErrore:
iStep = iStep + DeltaStep
bFiligrana = False
If iLink Mod 100 = 0 Then
ThisWorkbook.Save
End If
Next r
Call CancellaWsTemp
With wsImmagini
.Activate
.Range("A1").Activate
End With
With Application
.StatusBar = False
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
IEobj.Quit
Shell "Explorer.exe /n," & sPath1, vbMaximizedFocus
Shell "Explorer.exe /n," & sPath2, vbMaximizedFocus
Set IEobj = Nothing
Exit Sub
Errore:
With ThisWorkbook.Worksheets("Link_Falliti")
With .Cells(.Rows.Count, 1).End(xlUp)
With .Offset(1, 0)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(1, 1).Value = "Errore n. " & Err.Number
.Offset(1, 2).Value = Err.Description
End With
End With
Err.Clear
Resume RiprendiErrore
End Sub
'---

[draleo]

Post by casanmaner
https://www.dropbox.com/s/g5584vdj6rci1h5/Importare%20dati%20da%20pagina%20WEB%20%238.xlsm?dl=0
Ho inserito una sezione, nella routine principale, per la gestione dei percorsi.
Le costanti sono state inserite in altro come prime "dichiarazioni" della routine.
Se i percorsi non contengono la barra finale questa viene aggiunta.
Viene fatto un controllo se esiste il Drive indicato nel percorso.
Se non esiste viene interrotta l'esecuzione.
Se il drive esiste viene verificato che non si tratti di un drive "sconosciuto" o cd-rom o un drive ram. In questi casi la procedura viene interrotta.
Come ultimo controllo viene verificato se i due percorsi esistono. Se non esistono vengono creati.
Alla fine della procedura vengon aperti i percorsi dove sono state salvate le immagini.
'---
Sub ImportaImmagini()
Const DeltaStep = 25 'numero di celle tra una immagine di una Url e l'altra
Const sPathFrancobolli As String = "D:\Test\Francobolli\"
Const sPathFiligrane As String = "D:\Test\Filigrane\"
Dim Wb As Workbook
Dim wsLink As Worksheet
Dim WsTmp As Worksheet
Dim wsImmagini As Worksheet
Dim wsFiligrane As Worksheet
Dim WsChart As Worksheet
Dim oChart As ChartObject
Dim rngLink As Range
Dim DataObj As New DataObject
Dim IEobj As Object
Dim sURL As String, sNumCat As String
Dim sp As Shape
Dim sName As String
Dim r As Range
Dim iStep As Long
Dim NumLink As Long, iLink As Long
Dim bFiligrana As Boolean
Dim iWidth As Double, iHeight As Double
Dim sPath1 As String, sPath2 As String
Dim sDrive1 As String, sDrive2 As String
'<--- gestione percorsi salvataggio file immagini --->
sPath1 = sPathFrancobolli
If Right(sPath1, 1) <> "\" Then sPath1 = sPath1 & "\"
sPath2 = sPathFiligrane
If Right(sPath2, 1) <> "\" Then sPath2 = sPath2 & "\"
sDrive1 = Left(sPath1, 2)
sDrive2 = Left(sPath2, 2)
With CreateObject("Scripting.FileSystemObject")
If Not .DriveExists(Left(sPath1, 2)) Then Exit Sub
If Not .DriveExists(Left(sPath2, 2)) Then Exit Sub
Select Case .GetDrive(sDrive1).DriveType
Case 0, 4, 5
Exit Sub
End Select
Select Case .GetDrive(sDrive2).DriveType
Case 0, 4, 5
Exit Sub
End Select
If Not .FolderExists(sPath1) Then .CreateFolder sPath1
If Not .FolderExists(sPath2) Then .CreateFolder sPath2
End With
'</--- gestione percorsi salvataggio file immagini --->
Set Wb = ThisWorkbook
With Wb
Set wsLink = .Worksheets("Link")
Set WsTmp = .Worksheets("Tmp_Immagini")
Set wsImmagini = .Worksheets("Immagini")
Set wsFiligrane = .Worksheets("Filigrane")
Set WsChart = .Worksheets("Grafico")
End With
Set rngLink = wsLink.Range("A1").CurrentRegion.Columns(1)
Set oChart = WsChart.ChartObjects("Grafico 1")
NumLink = rngLink.Rows.Count
Set IEobj = CreateObject("InternetExplorer.Application")
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo Errore
Call CancellaWsImmagini
Call CancellaLinkFalliti
For Each r In rngLink.Cells
iLink = iLink + 1
Application.StatusBar = "Link " & iLink & " di " & NumLink & " in elaborazione."
sURL = r.Hyperlinks(1).Address 'prende l'indirizzo del link _
(da usare se le celle presentano un link)
'sUrl = r.Value 'prende il valore nella cella _
(da usare se le celle non presentano un link _
ma il valore della cella corrisponde all'intera URL)
sNumCat = r.Offset(, 1).Value
With IEobj
.Navigate sURL
Do Until .ReadyState = 4: TimerDelay (4): Loop
On Error Resume Next
With .Document
Do Until .ReadyState = "complete": TimerDelay (1): Loop
sName = .getElementById("name").InnerHtml
DataObj.SetText .DocumentElement.InnerHtml
End With
Err.Clear
On Error GoTo Errore
DataObj.PutInClipboard
End With
With wsImmagini
With .Range("A1")
With .Offset(iStep)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(iStep, 1) = sNumCat
.Offset(iStep + 1) = sName
End With
End With
With wsFiligrane
With .Range("A1")
With .Offset(iStep)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(iStep, 1) = sNumCat
.Offset(iStep + 1) = sName
End With
End With
With WsTmp
With .Range("A1")
.PasteSpecial xlPasteAll
End With
For Each sp In .Shapes
With sp
Select Case Left(.Name, Len("Picture"))
Case Is <> "Picture"
.Delete
Case Else
If Not .Visible Then
.Delete
Else
.Cut
If Not bFiligrana Then
With wsImmagini
.Activate
.Range("A1").Offset(iStep + 2, 0).PasteSpecial
If TypeName(Selection) = "Picture" Then
With Selection
.Name = sNumCat
.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
iWidth = .Width
iHeight = .Height
With oChart
.Height = iHeight
.Width = iWidth
With .Chart
.Paste
.Export sPathFrancobolli & SostituisciCaratteriVietatiNomiFile(sNumCat) & ".jpg"
.Shapes(1).Delete
End With
End With
End With
End If
.Range("A1").Select
End With
wsFiligrane.Range("A1").Offset(iStep + 2, 0).Value = "No Filigrana"
bFiligrana = True
Else
With wsFiligrane
.Activate
.Range("A1").Offset(iStep + 2, 0).PasteSpecial
If TypeName(Selection) = "Picture" Then
With Selection
.Name = sNumCat
.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
iWidth = .Width
iHeight = .Height
With oChart
.Height = iHeight
.Width = iWidth
With .Chart
.Paste
.Export sPathFiligrane & SostituisciCaratteriVietatiNomiFile(sNumCat) & ".jpg"
.Shapes(1).Delete
End With
End With
End With
End If
.Range("A1").Select
.Range("A1").Offset(iStep + 2, 0).Value = Empty
End With
End If
End If
End Select
End With
Next sp
End With
iStep = iStep + DeltaStep
bFiligrana = False
If iLink Mod 100 = 0 Then
ThisWorkbook.Save
End If
Next r
Call CancellaWsTemp
With wsImmagini
.Activate
.Range("A1").Activate
End With
With Application
.StatusBar = False
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
IEobj.Quit
Shell "Explorer.exe /n," & sPath1, vbMaximizedFocus
Shell "Explorer.exe /n," & sPath2, vbMaximizedFocus
Set IEobj = Nothing
Exit Sub
With ThisWorkbook.Worksheets("Link_Falliti")
With .Cells(.Rows.Count, 1).End(xlUp)
With .Offset(1, 0)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(1, 1).Value = "Errore n. " & Err.Number
.Offset(1, 2).Value = Err.Description
End With
End With
Err.Clear
Resume RiprendiErrore
End Sub
'---

Si, questi controlli sui percorsi di destinazione ci volevano proprio; perché dovendo continuamente creare nuove cartelle e sottocartelle, il rischio di errori di digitazione è alto. Anche se non sono certo che il bug rilevato precedentemente potesse dipendere da questo. Comunque, al momento, non si è più ripresentato
ancora grazie
draleo

[b***@gmail.com]

Post by draleo

Post by casanmaner
https://www.dropbox.com/s/g5584vdj6rci1h5/Importare%20dati%20da%20pagina%20WEB%20%238.xlsm?dl=0
Ho inserito una sezione, nella routine principale, per la gestione dei percorsi.
Le costanti sono state inserite in altro come prime "dichiarazioni" della routine.
Se i percorsi non contengono la barra finale questa viene aggiunta.
Viene fatto un controllo se esiste il Drive indicato nel percorso.
Se non esiste viene interrotta l'esecuzione.
Se il drive esiste viene verificato che non si tratti di un drive "sconosciuto" o cd-rom o un drive ram. In questi casi la procedura viene interrotta.
Come ultimo controllo viene verificato se i due percorsi esistono. Se non esistono vengono creati.
Alla fine della procedura vengon aperti i percorsi dove sono state salvate le immagini.
'---
Sub ImportaImmagini()
Const DeltaStep = 25 'numero di celle tra una immagine di una Url e l'altra
Const sPathFrancobolli As String = "D:\Test\Francobolli\"
Const sPathFiligrane As String = "D:\Test\Filigrane\"
Dim Wb As Workbook
Dim wsLink As Worksheet
Dim WsTmp As Worksheet
Dim wsImmagini As Worksheet
Dim wsFiligrane As Worksheet
Dim WsChart As Worksheet
Dim oChart As ChartObject
Dim rngLink As Range
Dim DataObj As New DataObject
Dim IEobj As Object
Dim sURL As String, sNumCat As String
Dim sp As Shape
Dim sName As String
Dim r As Range
Dim iStep As Long
Dim NumLink As Long, iLink As Long
Dim bFiligrana As Boolean
Dim iWidth As Double, iHeight As Double
Dim sPath1 As String, sPath2 As String
Dim sDrive1 As String, sDrive2 As String
'<--- gestione percorsi salvataggio file immagini --->
sPath1 = sPathFrancobolli
If Right(sPath1, 1) <> "\" Then sPath1 = sPath1 & "\"
sPath2 = sPathFiligrane
If Right(sPath2, 1) <> "\" Then sPath2 = sPath2 & "\"
sDrive1 = Left(sPath1, 2)
sDrive2 = Left(sPath2, 2)
With CreateObject("Scripting.FileSystemObject")
If Not .DriveExists(Left(sPath1, 2)) Then Exit Sub
If Not .DriveExists(Left(sPath2, 2)) Then Exit Sub
Select Case .GetDrive(sDrive1).DriveType
Case 0, 4, 5
Exit Sub
End Select
Select Case .GetDrive(sDrive2).DriveType
Case 0, 4, 5
Exit Sub
End Select
If Not .FolderExists(sPath1) Then .CreateFolder sPath1
If Not .FolderExists(sPath2) Then .CreateFolder sPath2
End With
'</--- gestione percorsi salvataggio file immagini --->
Set Wb = ThisWorkbook
With Wb
Set wsLink = .Worksheets("Link")
Set WsTmp = .Worksheets("Tmp_Immagini")
Set wsImmagini = .Worksheets("Immagini")
Set wsFiligrane = .Worksheets("Filigrane")
Set WsChart = .Worksheets("Grafico")
End With
Set rngLink = wsLink.Range("A1").CurrentRegion.Columns(1)
Set oChart = WsChart.ChartObjects("Grafico 1")
NumLink = rngLink.Rows.Count
Set IEobj = CreateObject("InternetExplorer.Application")
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo Errore
Call CancellaWsImmagini
Call CancellaLinkFalliti
For Each r In rngLink.Cells
iLink = iLink + 1
Application.StatusBar = "Link " & iLink & " di " & NumLink & " in elaborazione."
sURL = r.Hyperlinks(1).Address 'prende l'indirizzo del link _
(da usare se le celle presentano un link)
'sUrl = r.Value 'prende il valore nella cella _
(da usare se le celle non presentano un link _
ma il valore della cella corrisponde all'intera URL)
sNumCat = r.Offset(, 1).Value
With IEobj
.Navigate sURL
Do Until .ReadyState = 4: TimerDelay (4): Loop
On Error Resume Next
With .Document
Do Until .ReadyState = "complete": TimerDelay (1): Loop
sName = .getElementById("name").InnerHtml
DataObj.SetText .DocumentElement.InnerHtml
End With
Err.Clear
On Error GoTo Errore
DataObj.PutInClipboard
End With
With wsImmagini
With .Range("A1")
With .Offset(iStep)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(iStep, 1) = sNumCat
.Offset(iStep + 1) = sName
End With
End With
With wsFiligrane
With .Range("A1")
With .Offset(iStep)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(iStep, 1) = sNumCat
.Offset(iStep + 1) = sName
End With
End With
With WsTmp
With .Range("A1")
.PasteSpecial xlPasteAll
End With
For Each sp In .Shapes
With sp
Select Case Left(.Name, Len("Picture"))
Case Is <> "Picture"
.Delete
Case Else
If Not .Visible Then
.Delete
Else
.Cut
If Not bFiligrana Then
With wsImmagini
.Activate
.Range("A1").Offset(iStep + 2, 0).PasteSpecial
If TypeName(Selection) = "Picture" Then
With Selection
.Name = sNumCat
.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
iWidth = .Width
iHeight = .Height
With oChart
.Height = iHeight
.Width = iWidth
With .Chart
.Paste
.Export sPathFrancobolli & SostituisciCaratteriVietatiNomiFile(sNumCat) & ".jpg"
.Shapes(1).Delete
End With
End With
End With
End If
.Range("A1").Select
End With
wsFiligrane.Range("A1").Offset(iStep + 2, 0).Value = "No Filigrana"
bFiligrana = True
Else
With wsFiligrane
.Activate
.Range("A1").Offset(iStep + 2, 0).PasteSpecial
If TypeName(Selection) = "Picture" Then
With Selection
.Name = sNumCat
.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
iWidth = .Width
iHeight = .Height
With oChart
.Height = iHeight
.Width = iWidth
With .Chart
.Paste
.Export sPathFiligrane & SostituisciCaratteriVietatiNomiFile(sNumCat) & ".jpg"
.Shapes(1).Delete
End With
End With
End With
End If
.Range("A1").Select
.Range("A1").Offset(iStep + 2, 0).Value = Empty
End With
End If
End If
End Select
End With
Next sp
End With
iStep = iStep + DeltaStep
bFiligrana = False
If iLink Mod 100 = 0 Then
ThisWorkbook.Save
End If
Next r
Call CancellaWsTemp
With wsImmagini
.Activate
.Range("A1").Activate
End With
With Application
.StatusBar = False
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
IEobj.Quit
Shell "Explorer.exe /n," & sPath1, vbMaximizedFocus
Shell "Explorer.exe /n," & sPath2, vbMaximizedFocus
Set IEobj = Nothing
Exit Sub
With ThisWorkbook.Worksheets("Link_Falliti")
With .Cells(.Rows.Count, 1).End(xlUp)
With .Offset(1, 0)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(1, 1).Value = "Errore n. " & Err.Number
.Offset(1, 2).Value = Err.Description
End With
End With
Err.Clear
Resume RiprendiErrore
End Sub
'---

Si, questi controlli sui percorsi di destinazione ci volevano proprio; perché dovendo continuamente creare nuove cartelle e sottocartelle, il rischio di errori di digitazione è alto. Anche se non sono certo che il bug rilevato precedentemente potesse dipendere da questo. Comunque, al momento, non si è più ripresentato
ancora grazie
draleo

Ho trovato molto interessante il tema e il lavoro fatto da Casanmaner. Ho qualche perplessità sull'architettura scelta. Se ho ben compreso Draleo ha necessità di scaricare immagini con uno nome file univoco e significativo su un disco del PC. Non mi è chiara viceversa la necessità di scaricare le immagini su un file Excel. Costruirei un elenco con:
1) i link che puntano alle pagine WEB con tutte le informazioni e la bella utilità dello zoom sui francobolli
2) i link che puntano sulle immagini jpg.
3) nome catalogo
4) nome immagine
Ciò è possibile con tecnica di web-scraping grazie alle potenti funzioni di filtro che offre l'interfaccia di Internet Explorer del VBA.
I tag immagine delle immagini delle pagine indicate da Draleo sono incassati in tag div con nome di classe 'item.item_z_pic' e pertanto sono recuperabili con un'istruzione del tipo:
Set ElementCol = html.querySelectorAll("div.item_z_pic>img")
oppure se si vogliono recuperare informazioni da tutti gli elementi immagini con
Set ElementCol = html.getElementsByTagName("img")
Dove ElementCol è dichiarabile come Object oppure tipizzato come IHTMLElementCollection
Le immagini si possono salvare su disco fisso direttamente dal server senza la necessità di scaricare la pagina web in Excel durante l'eplorazione della pagina oppure in secondo momento acquisito il link della risorsa immagine ( ho testato con successo 3 tecniche: scrittura di file binario, stream di ADODB, API: tutte presenti nel file proposto).
L'inserimento delle immagini su un file excel si può effettuare con import dal disco fisso
Trattandosi di un vero e complesso applicativo non ho la pretesa di coprire ogni aspetto del problema ( link falliti, nome file invalidi, ecc) e pertanto mi limito a proporvi il file allegato come spunto di discussione. Mi pare che ad un benchmarking dei tempi la procedura sia più veloce di quella di Casanmaner ( non ho fatto un test che confronti la disabilitazione delle immagini in Internet Explorer rispetto a navigazione completa).
So che forse il mio intervento è un poco tardivo ma la verifica di ogni singolo aspetto ha richiesto almeno per me molto tempo. In particolare nella navigazione tra le pagine mi sono imbattutto nell'errore 462 e non ne sono venuto a capo se non distruggendo la variabile ie per poi reinstanziarla ad ogni ciclo (suggerimenti?).
File disponile a:
https://www.dropbox.com/s/47dgbdlk4gjhnho/test%20Web%20Scraping.xlsm?dl=0

[casanmaner]

Rispondo dal mare :)
Premetto che non sono un programmatore e che non conosco tutte le proprietà dell'oggetto IE.
La procedura da me proposta si è sviluppata per step in base alle richieste fatte da Draleo.
In prima battuta la sua richiesta è stata di riportare sul file Excel le immagini presenti nei vari link, che in qualche modo lui avrebbe "classificato".
Poi, visto che la fame vien mangiando, dalla semplice importazione c'è stata l'esigenza di "classificare" in automatico le immagini, con una gestione parallela di eventuali link problematici. Infine ha prospettato l'esigenza del salvataggio delle immagini in un percorso del pc.
Fatte queste premesse con piacere guarderò il tuo file perché non si finisce mai di imparare e tutto può tornare utile un giorno ;)

[draleo]

Post by b***@gmail.com

Post by draleo

Post by casanmaner
https://www.dropbox.com/s/g5584vdj6rci1h5/Importare%20dati%20da%20pagina%20WEB%20%238.xlsm?dl=0
Ho inserito una sezione, nella routine principale, per la gestione dei percorsi.
Le costanti sono state inserite in altro come prime "dichiarazioni" della routine.
Se i percorsi non contengono la barra finale questa viene aggiunta.
Viene fatto un controllo se esiste il Drive indicato nel percorso.
Se non esiste viene interrotta l'esecuzione.
Se il drive esiste viene verificato che non si tratti di un drive "sconosciuto" o cd-rom o un drive ram. In questi casi la procedura viene interrotta.
Come ultimo controllo viene verificato se i due percorsi esistono. Se non esistono vengono creati.
Alla fine della procedura vengon aperti i percorsi dove sono state salvate le immagini.
'---
Sub ImportaImmagini()
Const DeltaStep = 25 'numero di celle tra una immagine di una Url e l'altra
Const sPathFrancobolli As String = "D:\Test\Francobolli\"
Const sPathFiligrane As String = "D:\Test\Filigrane\"
Dim Wb As Workbook
Dim wsLink As Worksheet
Dim WsTmp As Worksheet
Dim wsImmagini As Worksheet
Dim wsFiligrane As Worksheet
Dim WsChart As Worksheet
Dim oChart As ChartObject
Dim rngLink As Range
Dim DataObj As New DataObject
Dim IEobj As Object
Dim sURL As String, sNumCat As String
Dim sp As Shape
Dim sName As String
Dim r As Range
Dim iStep As Long
Dim NumLink As Long, iLink As Long
Dim bFiligrana As Boolean
Dim iWidth As Double, iHeight As Double
Dim sPath1 As String, sPath2 As String
Dim sDrive1 As String, sDrive2 As String
'<--- gestione percorsi salvataggio file immagini --->
sPath1 = sPathFrancobolli
If Right(sPath1, 1) <> "\" Then sPath1 = sPath1 & "\"
sPath2 = sPathFiligrane
If Right(sPath2, 1) <> "\" Then sPath2 = sPath2 & "\"
sDrive1 = Left(sPath1, 2)
sDrive2 = Left(sPath2, 2)
With CreateObject("Scripting.FileSystemObject")
If Not .DriveExists(Left(sPath1, 2)) Then Exit Sub
If Not .DriveExists(Left(sPath2, 2)) Then Exit Sub
Select Case .GetDrive(sDrive1).DriveType
Case 0, 4, 5
Exit Sub
End Select
Select Case .GetDrive(sDrive2).DriveType
Case 0, 4, 5
Exit Sub
End Select
If Not .FolderExists(sPath1) Then .CreateFolder sPath1
If Not .FolderExists(sPath2) Then .CreateFolder sPath2
End With
'</--- gestione percorsi salvataggio file immagini --->
Set Wb = ThisWorkbook
With Wb
Set wsLink = .Worksheets("Link")
Set WsTmp = .Worksheets("Tmp_Immagini")
Set wsImmagini = .Worksheets("Immagini")
Set wsFiligrane = .Worksheets("Filigrane")
Set WsChart = .Worksheets("Grafico")
End With
Set rngLink = wsLink.Range("A1").CurrentRegion.Columns(1)
Set oChart = WsChart.ChartObjects("Grafico 1")
NumLink = rngLink.Rows.Count
Set IEobj = CreateObject("InternetExplorer.Application")
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo Errore
Call CancellaWsImmagini
Call CancellaLinkFalliti
For Each r In rngLink.Cells
iLink = iLink + 1
Application.StatusBar = "Link " & iLink & " di " & NumLink & " in elaborazione."
sURL = r.Hyperlinks(1).Address 'prende l'indirizzo del link _
(da usare se le celle presentano un link)
'sUrl = r.Value 'prende il valore nella cella _
(da usare se le celle non presentano un link _
ma il valore della cella corrisponde all'intera URL)
sNumCat = r.Offset(, 1).Value
With IEobj
.Navigate sURL
Do Until .ReadyState = 4: TimerDelay (4): Loop
On Error Resume Next
With .Document
Do Until .ReadyState = "complete": TimerDelay (1): Loop
sName = .getElementById("name").InnerHtml
DataObj.SetText .DocumentElement.InnerHtml
End With
Err.Clear
On Error GoTo Errore
DataObj.PutInClipboard
End With
With wsImmagini
With .Range("A1")
With .Offset(iStep)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(iStep, 1) = sNumCat
.Offset(iStep + 1) = sName
End With
End With
With wsFiligrane
With .Range("A1")
With .Offset(iStep)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(iStep, 1) = sNumCat
.Offset(iStep + 1) = sName
End With
End With
With WsTmp
With .Range("A1")
.PasteSpecial xlPasteAll
End With
For Each sp In .Shapes
With sp
Select Case Left(.Name, Len("Picture"))
Case Is <> "Picture"
.Delete
Case Else
If Not .Visible Then
.Delete
Else
.Cut
If Not bFiligrana Then
With wsImmagini
.Activate
.Range("A1").Offset(iStep + 2, 0).PasteSpecial
If TypeName(Selection) = "Picture" Then
With Selection
.Name = sNumCat
.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
iWidth = .Width
iHeight = .Height
With oChart
.Height = iHeight
.Width = iWidth
With .Chart
.Paste
.Export sPathFrancobolli & SostituisciCaratteriVietatiNomiFile(sNumCat) & ".jpg"
.Shapes(1).Delete
End With
End With
End With
End If
.Range("A1").Select
End With
wsFiligrane.Range("A1").Offset(iStep + 2, 0).Value = "No Filigrana"
bFiligrana = True
Else
With wsFiligrane
.Activate
.Range("A1").Offset(iStep + 2, 0).PasteSpecial
If TypeName(Selection) = "Picture" Then
With Selection
.Name = sNumCat
.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
iWidth = .Width
iHeight = .Height
With oChart
.Height = iHeight
.Width = iWidth
With .Chart
.Paste
.Export sPathFiligrane & SostituisciCaratteriVietatiNomiFile(sNumCat) & ".jpg"
.Shapes(1).Delete
End With
End With
End With
End If
.Range("A1").Select
.Range("A1").Offset(iStep + 2, 0).Value = Empty
End With
End If
End If
End Select
End With
Next sp
End With
iStep = iStep + DeltaStep
bFiligrana = False
If iLink Mod 100 = 0 Then
ThisWorkbook.Save
End If
Next r
Call CancellaWsTemp
With wsImmagini
.Activate
.Range("A1").Activate
End With
With Application
.StatusBar = False
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
IEobj.Quit
Shell "Explorer.exe /n," & sPath1, vbMaximizedFocus
Shell "Explorer.exe /n," & sPath2, vbMaximizedFocus
Set IEobj = Nothing
Exit Sub
With ThisWorkbook.Worksheets("Link_Falliti")
With .Cells(.Rows.Count, 1).End(xlUp)
With .Offset(1, 0)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(1, 1).Value = "Errore n. " & Err.Number
.Offset(1, 2).Value = Err.Description
End With
End With
Err.Clear
Resume RiprendiErrore
End Sub
'---

Si, questi controlli sui percorsi di destinazione ci volevano proprio; perché dovendo continuamente creare nuove cartelle e sottocartelle, il rischio di errori di digitazione è alto. Anche se non sono certo che il bug rilevato precedentemente potesse dipendere da questo. Comunque, al momento, non si è più ripresentato
ancora grazie
draleo

1) i link che puntano alle pagine WEB con tutte le informazioni e la bella utilità dello zoom sui francobolli
2) i link che puntano sulle immagini jpg.
3) nome catalogo
4) nome immagine
Ciò è possibile con tecnica di web-scraping grazie alle potenti funzioni di filtro che offre l'interfaccia di Internet Explorer del VBA.
Set ElementCol = html.querySelectorAll("div.item_z_pic>img")
oppure se si vogliono recuperare informazioni da tutti gli elementi immagini con
Set ElementCol = html.getElementsByTagName("img")
Dove ElementCol è dichiarabile come Object oppure tipizzato come IHTMLElementCollection
Le immagini si possono salvare su disco fisso direttamente dal server senza la necessità di scaricare la pagina web in Excel durante l'eplorazione della pagina oppure in secondo momento acquisito il link della risorsa immagine ( ho testato con successo 3 tecniche: scrittura di file binario, stream di ADODB, API: tutte presenti nel file proposto).
L'inserimento delle immagini su un file excel si può effettuare con import dal disco fisso
Trattandosi di un vero e complesso applicativo non ho la pretesa di coprire ogni aspetto del problema ( link falliti, nome file invalidi, ecc) e pertanto mi limito a proporvi il file allegato come spunto di discussione. Mi pare che ad un benchmarking dei tempi la procedura sia più veloce di quella di Casanmaner ( non ho fatto un test che confronti la disabilitazione delle immagini in Internet Explorer rispetto a navigazione completa).
So che forse il mio intervento è un poco tardivo ma la verifica di ogni singolo aspetto ha richiesto almeno per me molto tempo. In particolare nella navigazione tra le pagine mi sono imbattutto nell'errore 462 e non ne sono venuto a capo se non distruggendo la variabile ie per poi reinstanziarla ad ogni ciclo (suggerimenti?).
https://www.dropbox.com/s/47dgbdlk4gjhnho/test%20Web%20Scraping.xlsm?dl=0

Prima di tutto grazie .Premesso che la soluzione di Casanmaner funziona bene e fa tutto quello che avevo chiesto, ogni altro suggerimento o soluzione è ben accetta.
Purtroppo le mie competenze non mi permettono di entrare nei discorsi tecnici che tu proponi.
Non rimane altro che provare il file, ma data la mia ignoranza in materia, ho incontrato subito delle difficoltà nell’utilizzarlo
1)Dove scrivere i percorsi di destinazione ? nel modulo 1, nel modulo M_test o in entrambi ?
2)Poco dopo averlo lanciato mi da Errore 1004. Errore nel metodo Select per la classe range, e proseguendo , nei percorsi di destinazione trovo una sola immagine (anziché 3 quanti erano i link)
3)Cosa sono i nuovi moduli Macro1 e macro2 e Foglio1?
4)Nella barra di stato trovo sempre (anche dopo 20 minuti) la scritta: mi sto connettendo al sito Web ecce cc. Come si fa a capire quando la connessione, e quindi ,la procedura è terminata?
Stanotte comunque riprovo con più calma , sperando di capirci di più. Ora il lavoro mi chiama…
Draleo
PS:Buone Vacanze per Casanmaner !

[draleo]

Post by draleo
2)Poco dopo averlo lanciato mi da Errore 1004. Errore nel metodo Select per la classe range,

Ho riprovato:
1) l'errore 1004 qualche volta si verificava anche nella versione di Casanmaner: ma, il download non si interrompeva, perchè lui aveva messo la procedura sotto riportata che permetteva di proseguire e segnalava il link fallito nel Foglio link Falliti.
Nella tua versione invece tutto si blocca al 1° errore. Se tu riesci ad inserire un qualcosa che permetta di proseguire ugualmente, allora potrò arrivare alla fine del test e vederne i risultati
2 )Non capisco cosa significhi questa parte
Sub TestInsertPicture()
InsertPicture "D:\Test\Francobolli\1444.jpg", Range("A3"), False, False
End Sub
e a cosa servano i fogli aggiunti Macro1 , macro2 e Foglio1
Fammi sapere che sono curioso
grazie
draleo
--------------------------------
RiprendiErrore:
iStep = iStep + DeltaStep
bFiligrana = False
If iLink Mod 100 = 0 Then
ThisWorkbook.Save
End If
Next r
Call CancellaWsTemp
With wsImmagini
.Activate
.Range("A1").Activate
End With
With Application
.StatusBar = False
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
IEobj.Quit
Shell "Explorer.exe /n," & sPath1, vbMaximizedFocus
Shell "Explorer.exe /n," & sPath2, vbMaximizedFocus
Set IEobj = Nothing
Exit Sub
Errore:
With ThisWorkbook.Worksheets("Link_Falliti")
With .Cells(.Rows.Count, 1).End(xlUp)
With .Offset(1, 0)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(1, 1).Value = "Errore n. " & Err.Number
.Offset(1, 2).Value = Err.Description
End With
End With
Err.Clear
Resume RiprendiErrore
End Sub

[b***@gmail.com]

Post by draleo

Post by draleo
2)Poco dopo averlo lanciato mi da Errore 1004. Errore nel metodo Select per la classe range,

1) l'errore 1004 qualche volta si verificava anche nella versione di Casanmaner: ma, il download non si interrompeva, perchè lui aveva messo la procedura sotto riportata che permetteva di proseguire e segnalava il link fallito nel Foglio link Falliti.
Nella tua versione invece tutto si blocca al 1° errore. Se tu riesci ad inserire un qualcosa che permetta di proseguire ugualmente, allora potrò arrivare alla fine del test e vederne i risultati
2 )Non capisco cosa significhi questa parte
Sub TestInsertPicture()
InsertPicture "D:\Test\Francobolli\1444.jpg", Range("A3"), False, False
End Sub
e a cosa servano i fogli aggiunti Macro1 , macro2 e Foglio1
Fammi sapere che sono curioso
grazie
draleo
--------------------------------
iStep = iStep + DeltaStep
bFiligrana = False
If iLink Mod 100 = 0 Then
ThisWorkbook.Save
End If
Next r
Call CancellaWsTemp
With wsImmagini
.Activate
.Range("A1").Activate
End With
With Application
.StatusBar = False
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
IEobj.Quit
Shell "Explorer.exe /n," & sPath1, vbMaximizedFocus
Shell "Explorer.exe /n," & sPath2, vbMaximizedFocus
Set IEobj = Nothing
Exit Sub
With ThisWorkbook.Worksheets("Link_Falliti")
With .Cells(.Rows.Count, 1).End(xlUp)
With .Offset(1, 0)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(1, 1).Value = "Errore n. " & Err.Number
.Offset(1, 2).Value = Err.Description
End With
End With
Err.Clear
Resume RiprendiErrore
End Sub

Avevo introdotto per ultime le righe di codice relative all'import delle immagini da disco fisso dopo averle testate solo in ambiente test senza verificarle di nuovo all'interno della routine principale. Da qui l'errore 1004 e altri problemi tra i quali errore nella sovrascrittura di file che penso aver risolto. Per 10 cicli la routine impiega circa 30 sec. Ho aggiunto anche il link all'immagine su disco fisso. Secondo me, potendo avere le immagini su disco fisso un'evoluzione dell'applicazione potrebbe prevedere la non importazione delle immagini e la costruzione di un semplice database con tutti i link necessari compresi quelli che puntano alle immagini su disco. Qui il file.
https://www.dropbox.com/s/ot4st4urwddpx7v/test%20Web%20Scraping%232.xlsm?dl=0
Per le domande di Draleo:
<2 )Non capisco cosa significhi questa parte...>
È una chiamata di test alla routine che inserisce le immagini e le posiziona. Non centra con l'applicazione principale. Foglio1 pure era un foglio sul quale fare prove (ora eliminato).
Comunque tengo a precisare che non intendo proporre un intero applicativo ma solo proporre ipotesi di miglioramento sul lavoro di Casanmaner
Per Casanmaner:
<Premetto che non sono un programmatore...>
Neanche io e ho imparato cose interessanti da te.
Elio

[draleo]

Post by b***@gmail.com

Post by draleo

Post by draleo
2)Poco dopo averlo lanciato mi da Errore 1004. Errore nel metodo Select per la classe range,

1) l'errore 1004 qualche volta si verificava anche nella versione di Casanmaner: ma, il download non si interrompeva, perchè lui aveva messo la procedura sotto riportata che permetteva di proseguire e segnalava il link fallito nel Foglio link Falliti.
Nella tua versione invece tutto si blocca al 1° errore. Se tu riesci ad inserire un qualcosa che permetta di proseguire ugualmente, allora potrò arrivare alla fine del test e vederne i risultati
2 )Non capisco cosa significhi questa parte
Sub TestInsertPicture()
InsertPicture "D:\Test\Francobolli\1444.jpg", Range("A3"), False, False
End Sub
e a cosa servano i fogli aggiunti Macro1 , macro2 e Foglio1
Fammi sapere che sono curioso
grazie
draleo
--------------------------------
iStep = iStep + DeltaStep
bFiligrana = False
If iLink Mod 100 = 0 Then
ThisWorkbook.Save
End If
Next r
Call CancellaWsTemp
With wsImmagini
.Activate
.Range("A1").Activate
End With
With Application
.StatusBar = False
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
IEobj.Quit
Shell "Explorer.exe /n," & sPath1, vbMaximizedFocus
Shell "Explorer.exe /n," & sPath2, vbMaximizedFocus
Set IEobj = Nothing
Exit Sub
With ThisWorkbook.Worksheets("Link_Falliti")
With .Cells(.Rows.Count, 1).End(xlUp)
With .Offset(1, 0)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(1, 1).Value = "Errore n. " & Err.Number
.Offset(1, 2).Value = Err.Description
End With
End With
Err.Clear
Resume RiprendiErrore
End Sub

Avevo introdotto per ultime le righe di codice relative all'import delle immagini da disco fisso dopo averle testate solo in ambiente test senza verificarle di nuovo all'interno della routine principale. Da qui l'errore 1004 e altri problemi tra i quali errore nella sovrascrittura di file che penso aver risolto. Per 10 cicli la routine impiega circa 30 sec. Ho aggiunto anche il link all'immagine su disco fisso. Secondo me, potendo avere le immagini su disco fisso un'evoluzione dell'applicazione potrebbe prevedere la non importazione delle immagini e la costruzione di un semplice database con tutti i link necessari compresi quelli che puntano alle immagini su disco. Qui il file.
https://www.dropbox.com/s/ot4st4urwddpx7v/test%20Web%20Scraping%232.xlsm?dl=0
<2 )Non capisco cosa significhi questa parte...>
È una chiamata di test alla routine che inserisce le immagini e le posiziona. Non centra con l'applicazione principale. Foglio1 pure era un foglio sul quale fare prove (ora eliminato).
Comunque tengo a precisare che non intendo proporre un intero applicativo ma solo proporre ipotesi di miglioramento sul lavoro di Casanmaner
<Premetto che non sono un programmatore...>
Neanche io e ho imparato cose interessanti da te.
Elio

Ok. Funziona bene; è un altro ottimo lavoro. L’ho testato con una 20ina di link e non ho avuto problemi. L’unica perplessità che ho è dovuta al fatto che, al momento, non ho visto nel codice righe che gestiscano gli errori e che permettano di continuare il lavoro anche quando questi si verifichino. In questi pochi link testati non si sono verificati errori, ma l’esperienza mi dice che almeno il 2-3% di essi fallisce (vattelapesca per quali motivi). Una altra cosa che ho notato, ma non è che sia molto importante, è che molte immagini presenti nei fogli -non tutte- sono parecchio più piccole di quelle reali .Sono state ridimensionate ? Per quando riguarda le differenze tecniche tra i 2 sistemi adottati (il tuo e quello di Casanmaner), io da profano, non sono in grado di interloquire.
Molte Grazie
Draleo

[casanmaner]

Ciao,
ho fatto una prova veloce.
Un errore dato dal copia/incolla in fase di dichiarazione della funzione GetTickCount dove nella parte della condizione per versioni VB6 sono rimasti i riferimenti a PtrSave e LongPtr.

Altro errore dovuto al fatto che la variabile iLink è stata disabilitata ma non anche le istruzioni utilizzate nella procedura.

Ma questi sono errori ovviamente aggiustabili.

Piuttosto io ho rilevato che ad ogni successivo ciclo di "Link" nel mio pc Internet Explorer va in "crash":
Vedi questi due screenshot:
Loading Image...

Loading Image...

E vengono create diverse istanze di IE tante quanti sono i link elaborati.
Ho lanciato 2 volte la procedura per i primi tre link e ho 6 istanze (prima di lanciare la seconda volta ne avevo tre). Vedi lo screenshot:
Loading Image...

Quando ho un po' più di tempo vedo se riesco a capire il motivo.

ciao

[draleo]

Post by casanmaner
Ciao,
ho fatto una prova veloce.
Un errore dato dal copia/incolla in fase di dichiarazione della funzione GetTickCount dove nella parte della condizione per versioni VB6 sono rimasti i riferimenti a PtrSave e LongPtr.
Altro errore dovuto al fatto che la variabile iLink è stata disabilitata ma non anche le istruzioni utilizzate nella procedura.
Ma questi sono errori ovviamente aggiustabili.
https://www.dropbox.com/s/180jt3tx669rkv6/Screenshot%202018-08-29%2021.30.27.png?dl=0
https://www.dropbox.com/s/ds0h1g6ahaastvs/Screenshot%202018-08-29%2021.30.21.png?dl=0
E vengono create diverse istanze di IE tante quanti sono i link elaborati.
https://www.dropbox.com/s/rz2etwla2pusjsy/Screenshot%202018-08-29%2021.36.25.png?dl=0
Quando ho un po' più di tempo vedo se riesco a capire il motivo.
ciao

Vedo. ma io con la tua seconda versione, non ho avuto questi problemi. comunque , se ti riesce a farla funzionare senza perderci troppo tempo,va bene; altrimenti...ciccia...non succede niente
Comunque sia grazie
draleo

[draleo]

Post by draleo

Post by casanmaner
Ciao,
ho fatto una prova veloce.
Un errore dato dal copia/incolla in fase di dichiarazione della funzione GetTickCount dove nella parte della condizione per versioni VB6 sono rimasti i riferimenti a PtrSave e LongPtr.
Altro errore dovuto al fatto che la variabile iLink è stata disabilitata ma non anche le istruzioni utilizzate nella procedura.
Ma questi sono errori ovviamente aggiustabili.
https://www.dropbox.com/s/180jt3tx669rkv6/Screenshot%202018-08-29%2021.30.27.png?dl=0
https://www.dropbox.com/s/ds0h1g6ahaastvs/Screenshot%202018-08-29%2021.30.21.png?dl=0
E vengono create diverse istanze di IE tante quanti sono i link elaborati.
https://www.dropbox.com/s/rz2etwla2pusjsy/Screenshot%202018-08-29%2021.36.25.png?dl=0
Quando ho un po' più di tempo vedo se riesco a capire il motivo.
ciao

Vedo. ma io con la tua seconda versione, non ho avuto questi problemi. comunque , se ti riesce a farla funzionare senza perderci troppo tempo,va bene; altrimenti...ciccia...non succede niente
Comunque sia grazie
draleo

Pardon, non avevo letto che il post di risposta era di Casanmaner; ho risposto pensando di rispondere a buonocchiocciolaecc. Comunque la risposta è valida per entrambi
Ciao
draleo

[draleo]

Post by draleo

Post by draleo

Post by casanmaner
Ciao,
ho fatto una prova veloce.
Un errore dato dal copia/incolla in fase di dichiarazione della funzione GetTickCount dove nella parte della condizione per versioni VB6 sono rimasti i riferimenti a PtrSave e LongPtr.
Altro errore dovuto al fatto che la variabile iLink è stata disabilitata ma non anche le istruzioni utilizzate nella procedura.
Ma questi sono errori ovviamente aggiustabili.
https://www.dropbox.com/s/180jt3tx669rkv6/Screenshot%202018-08-29%2021.30.27.png?dl=0
https://www.dropbox.com/s/ds0h1g6ahaastvs/Screenshot%202018-08-29%2021.30.21.png?dl=0
E vengono create diverse istanze di IE tante quanti sono i link elaborati.
https://www.dropbox.com/s/rz2etwla2pusjsy/Screenshot%202018-08-29%2021.36.25.png?dl=0
Quando ho un po' più di tempo vedo se riesco a capire il motivo.
ciao

Vedo. ma io con la tua seconda versione, non ho avuto questi problemi. comunque , se ti riesce a farla funzionare senza perderci troppo tempo,va bene; altrimenti...ciccia...non succede niente
Comunque sia grazie
draleo

Pardon, non avevo letto che il post di risposta era di Casanmaner; ho risposto pensando di rispondere a buonocchiocciolaecc. Comunque la risposta è valida per entrambi
Ciao
draleo

Io avevo aggiunto, perché era disattivata
Dim iLink As Long
e così funzionava
draleo

[casanmaner]

Internet Explorer invece non va in crash se utilizzo l'istruzione:

Set ElementCol = html.getElementsByTagName("img")

invece che:

'Set ElementCol = html.querySelectorAll("div.item_z_pic>img")

Sempre utilizzando la suddetta istruzione non ottengo l'errore 462 anche eliminado l'istruzione Set ie = Nothing ad ogni ciclo Link.
Risulta quindi non necessario aprire diverse istanze ie e alla fine basta chiudere l'unica istanza con ie.Quit.

Ho notato anche io che le immagini sono ridotte (alcune per i francobolli e tutte per le filigrane).
Le immagini nel foglio non vengono nominate in base al numero di catalogo.

[b***@gmail.com]

Post by b***@gmail.com
Set ElementCol = html.getElementsByTagName("img")
'Set ElementCol = html.querySelectorAll("div.item_z_pic>img")
Sempre utilizzando la suddetta istruzione non ottengo l'errore 462 anche eliminado l'istruzione Set ie = Nothing ad ogni ciclo Link.
Risulta quindi non necessario aprire diverse istanze ie e alla fine basta chiudere l'unica istanza con ie.Quit.
Ho notato anche io che le immagini sono ridotte (alcune per i francobolli e tutte per le filigrane).
Le immagini nel foglio non vengono nominate in base al numero di catalogo.

Credo che sia una problema di versione del browser per querySelectorAll
https://www.w3schools.com/jsref/met_document_queryselectorall.asp
che peraltro con la stringa filtro proposta nel mio codice restituisce selettivamente solo i jpg nei tag div con nome di classe indicato, altrimenti si tirano dentro tutte le immagini anche png. Purtroppo c'è il problem afastidioso dell'errore 462 al sucecssivo ciclo come hai fatto notare. Inoltre è possibile che i jpg siano più di 2 come è possibile verificare interrogando il link
https://colnect.com/it/stamps/stamp/527899-Queen_Elizabeth_II_-_Predecimal_Machin-Regina_Elisabetta_II_pre_decimali_Machins-Gran_Bretagna

che al momento in cui scrivo presenta un inserimento 'Inserzioni nell'Area di Vendita' con tanto di immagine jpg che determina risultati errati con il tuo codice.
Anche la gestione dei link falliti è problematica in quanto basta inserire un https://pippo perchè appaia una finestra di Internet Explorer con scritto pagina non raggiungibile e il codice si blocca
Resto dell'idea che è meglio effettuare lo 'scraping' del HTLM della pagine e trovare i tag di interesse. Il codice della pagina lo si può ottenere con WinRequest. Sfruttando gli errori generati dal metodo Send si può sapere in anticipo se la pagina esiste e/o raggiungibile, oltre che a settare un timeout. Se il metodo fallisce si può allora rinunciare ad utilizzare il metodo navigate di InternetExplorer e passare al successivo link.
Non l'ho ancora testato ma si può anche utilizzare il ResponseText di WinRequest per populare l'oggetto document di ie senza che vi sia navigazione alla pagina. In sostanza con una richiesta si sa se il sito e raggiungibile e se lo è si ha anche il contenuto della pagina. In questa in head e metadata vi sono pure le stringhe di ulteriore interesse per Draleo come 'Mi:GB 15,Sn:GB 28,Yt:GB 20,Sg:GB 72,AFA:GB 15'
Qui quello che sono riuscito ad elaborare. Hai suggerimenti?
https://www.dropbox.com/s/wlntyx8z8r4c14e/test%20Web%20Scraping%233%20.xlsm?dl=0
dove ho risolto il problema della dimensione delle immagini e della denominazione delle stesse

[casanmaner]

Post by b***@gmail.com
Credo che sia una problema di versione del browser per querySelectorAll
https://www.w3schools.com/jsref/met_document_queryselectorall.asp

Al momento è installata la versione 11:
Loading Image...

Post by b***@gmail.com
che peraltro con la stringa filtro proposta nel mio codice restituisce selettivamente solo i jpg nei tag div con nome di classe indicato, altrimenti si tirano dentro tutte le immagini anche png. Purtroppo c'è il problem afastidioso dell'errore 462 al sucecssivo ciclo come hai fatto notare. Inoltre è possibile che i jpg siano più di 2 come è possibile verificare interrogando il link
https://colnect.com/it/stamps/stamp/527899-Queen_Elizabeth_II_-_Predecimal_Machin-Regina_Elisabetta_II_pre_decimali_Machins-Gran_Bretagna

Considerato che con questo errore, per evitarlo, occorra richimare diverse istanze di IE ritengo poco opportuno riempire la memoria del pc da centinaia se non migliaia istanze.
Meglio quindi la seconda soluzione che avevi proposto dove viene caricata una sola istanza che poi può essere chiusa.

Post by b***@gmail.com
che al momento in cui scrivo presenta un inserimento 'Inserzioni nell'Area di Vendita' con tanto di immagine jpg che determina risultati errati con il tuo codice.

Ho appena provato e anche con quella iserzione in basso a destra mi viene restituita correttamente l'immagine del francobollo.

Post by b***@gmail.com
Anche la gestione dei link falliti è problematica in quanto basta inserire un https://pippo perchè appaia una finestra di Internet Explorer con scritto pagina non raggiungibile e il codice si blocca

In realtà i codice non si blocca ma continua inserendo il link nel foglio immagini ma senza immagine.
Piuttosto, poiché non avevo "svuotato" la variabile sNome ad ogni ciclo, inserisce il nome del precedente link.
Cosa evitabile inserendo sNome=vbnullstring al termine di ciascun ciclo r.

Post by b***@gmail.com
Resto dell'idea che è meglio effettuare lo 'scraping' del HTLM della pagine e trovare i tag di interesse. Il codice della pagina lo si può ottenere con WinRequest. Sfruttando gli errori generati dal metodo Send si può sapere in anticipo se la pagina esiste e/o raggiungibile, oltre che a settare un timeout. Se il metodo fallisce si può allora rinunciare ad utilizzare il metodo navigate di InternetExplorer e passare al successivo link.
Non l'ho ancora testato ma si può anche utilizzare il ResponseText di WinRequest per populare l'oggetto document di ie senza che vi sia navigazione alla pagina. In sostanza con una richiesta si sa se il sito e raggiungibile e se lo è si ha anche il contenuto della pagina. In questa in head e metadata vi sono pure le stringhe di ulteriore interesse per Draleo come 'Mi:GB 15,Sn:GB 28,Yt:GB 20,Sg:GB 72,AFA:GB 15'

Non conosco WinRequest e quindi non saprei dire.

Post by b***@gmail.com
Qui quello che sono riuscito ad elaborare. Hai suggerimenti?
https://www.dropbox.com/s/wlntyx8z8r4c14e/test%20Web%20Scraping%233%20.xlsm?dl=0
dove ho risolto il problema della dimensione delle immagini e della denominazione delle stesse

Con calma lo studio e se mai ne dovessi avere scrivo :)

ciao

[casanmaner]

Post by casanmaner

Post by b***@gmail.com
Qui quello che sono riuscito ad elaborare. Hai suggerimenti?
https://www.dropbox.com/s/wlntyx8z8r4c14e/test%20Web%20Scraping%233%20.xlsm?dl=0
dove ho risolto il problema della dimensione delle immagini e della denominazione delle stesse

Con calma lo studio e se mai ne dovessi avere scrivo :)

Mi sembra che funzioni tutto correttamente e molto velocemente.
L'unica accortezza che adotterei è nel verificare, con la funzione che avevo introdotto, eventuali caratteri vietati per i nomi dei file (es. un codice 1234/a non sarebbe ammesso come nome file) ed eventualmente sostituirli con un carattere standard.
Per il resto non mi vengono in mente altri suggerimenti :)

[draleo]

Post by casanmaner

Post by casanmaner

Post by b***@gmail.com
Qui quello che sono riuscito ad elaborare. Hai suggerimenti?
https://www.dropbox.com/s/wlntyx8z8r4c14e/test%20Web%20Scraping%233%20.xlsm?dl=0
dove ho risolto il problema della dimensione delle immagini e della denominazione delle stesse

Con calma lo studio e se mai ne dovessi avere scrivo :)

Mi sembra che funzioni tutto correttamente e molto velocemente.
L'unica accortezza che adotterei è nel verificare, con la funzione che avevo introdotto, eventuali caratteri vietati per i nomi dei file (es. un codice 1234/a non sarebbe ammesso come nome file) ed eventualmente sostituirli con un carattere standard.
Per il resto non mi vengono in mente altri suggerimenti :)

Se vi servissero altri link realistici da utilizzare per le prove, al file allegato ce ne sono un 100io
https://www.dropbox.com/s/gstbevzhrm94u6g/Cartel5.xlsx?dl=0
draleo

[draleo]

.azz..E' velocissimo : 1000 link in meno di 1 ora e senza errori. A voler essere pignoli L'unico punto un po' debole sono la dimensione delle immagini, che sono più grandi e un po' sgranate. Nel file allegato appaiono le differenze: a sin le immagini estratte con "Importare Immaginida pagina Web #8"; a dx quelle estratte con "Test WebScraping3"
https://www.dropbox.com/s/tqu3pomcit9vs7h/Cartel6.xlsx?dl=0

draleo

[b***@gmail.com]

Post by draleo
.azz..E' velocissimo : 1000 link in meno di 1 ora e senza errori. A voler essere pignoli L'unico punto un po' debole sono la dimensione delle immagini, che sono più grandi e un po' sgranate. Nel file allegato appaiono le differenze: a sin le immagini estratte con "Importare Immaginida pagina Web #8"; a dx quelle estratte con "Test WebScraping3"
https://www.dropbox.com/s/tqu3pomcit9vs7h/Cartel6.xlsx?dl=0
draleo
A voler essere pignoli L'unico punto un po' debole sono la dimensione delle >immagini, che sono più grandi e un po' sgranate.

Nel Modulo M_Utilities cerca la routine InsertPicture e sostituisci il valore di Height bell'istruzione Windows(1).Selection.ShapeRange(1).Height = 300
con l'altezza in points che desideri ( per es 200 ); la larghezza si adatterà in automatico in quanto il rapporto altezza e larghezza è tenuto fisso dalla precedente istruzione Windows(1).Selection.ShapeRange(1).LockAspectRatio = msoTrue
E comunque si può fare una routine a parte per ridimensionare le immagini in blocco secondo le dimensioni desiderate. L'ingrandimento a 300 avviene, peraltro con l'importazione dell'immagine dal disco D che è a sua volta quella scaricata dal WEB. Se infatti attivi il link che punta a D hai l'immagine non 'sgranata'. Peraltro continuo a pensare che la struttura più pulita è quella che prevede solo dati e non immagini. L'utente se vuole può attivare i link che puntano alle Pagini/immagini sul WEB piuttosto che attivare i link che puntano alle immagini su disco.

[Ammammata]

Il giorno Wed 22 Aug 2018 11:05:19p, *draleo* ha inviato su
microsoft.public.it.office.excel il messaggio news:23456680-114d-45e8-924b-

Post by draleo

però ho provato un paio di "mass downloader" (winwget, visualwget) s

enza

riuscire a salvare i vari html :(

non capisco cosa volevi fare

partendo dai millemila link che hai nel foglio excel, salvati come testo,
si possono (potrebbero) scaricare tutte le millemila pagine

poi, con qualche riga di codice p.e. vbs o grep o altri barbatrucchi,
pulisci i file isolando i numeri di catalogo e il nome

infine scarichi tutti i jpg rinominandoli come preferisci

questa era l'idea :)

[draleo]

Post by Ammammata
partendo dai millemila link che hai nel foglio excel, salvati come testo,
si possono (potrebbero) scaricare tutte le millemila pagine
poi, con qualche riga di codice p.e. vbs o grep o altri barbatrucchi,
pulisci i file isolando i numeri di catalogo e il nome
infine scarichi tutti i jpg rinominandoli come preferisci
questa era l'idea :)

Forse è fatica inutile. Per scaricare i dati di qualsiasi francobollo di qualsiasi Nazione del mondo (sono milioni), basta iscriversi al sito di Colnet, versione Premium, che è a pagamento, ma gratuita, in prova, per i primi 15 gg. Dopo esserti iscritto, scegli la Nazione che ti aggrada, scegli le annate che ti interessano (Tutte) e puoi scaricare nel tuo PC tutti i files prescelti in formato csv. Poi è un giochetto riunirli in un unico file in formato Excel. Ma non ci sono le immagini, per le quali occorre utilizzare la procedura ideata da casanmaner
draleo

[Ammammata]

Il giorno Thu 23 Aug 2018 10:38:27a, *draleo* ha inviato su
microsoft.public.it.office.excel il messaggio news:7907b986-d0db-4d4b-acd1-

Post by draleo
puoi scaricare nel tuo PC tutti i files prescelti in formato csv

nel csv c'è l'informazione sul nome del file e sulla sua posizione sul
server?

questo, per capirci:

"//i.colnect.net/f/121/195/Queen_Victoria.jpg"

o quantomeno le due voci 121 e 195 (nel caso in esempio)

c'è anche Queen_Victoria ?

[Ammammata]

Il giorno Thu 23 Aug 2018 11:49:16a, *Ammammata* ha inviato su

Post by Ammammata

Post by draleo
puoi scaricare nel tuo PC tutti i files prescelti in formato csv

nel csv c'è l'informazione sul nome del file e sulla sua posizione sul
server?

provo a iscrivermi come hai suggerito e verifico di persona...

[draleo]

Post by Ammammata
nel csv c'è l'informazione sul nome del file e sulla sua posizione sul
server?

Nei files csv scaricati c'è tutto: Nome,serie,num catalogo, data, dentellatura, dimensioni ecc ecc. Quel sito è una vera miniera per i collezionisti di tutto il mondo. certo... il file csv va trasformato in xls, ma credo non avrai problemi a farlo
draleo

[casanmaner]

Ciao Draleo e Elio,
prendendo spunto dall'ultima versione del file di Elio ho voluto provare a non utilizzare, come diceva appunto Elio stesso, IE ma MSXML2.ServerXMLHTTP per eseguire lo scraping.
N.B. ho utilizzato la versione "server" perché i link forniti da Draleo hanno come indirizzo http ma poi vengono reindirizzati in https. Utilizzando MSXML2.XMLHTTP l'accesso viene negato restituendo un errore.

Ho quindi inserito nel modulo due una seconda versione della routine elaborata da Elio (getSrcAttributeImgTag2) che esegue l'estrazione delle immagini tramite il codice html.
Ho anche modificato la routine InsertPicture aggiugendo due argomenti.
L'altezza e la largezza in centimetri delle immagini.
Ho quindi fatto in modo che se l'altezza è maggiore della larghezza è questa che viene impostata in base alla misura in cm dell'argomento cmHeight. In caso contrario è la larghezza ad essere impostata in base alla misura in cm dell'argomento cmWidth.
Per le misure dell'altezza e larghezza ho preso come valori quelli delle immagini create con la mia procedura dove le immagini vengono copiate con le stesse dimensioni del sito.
Volendo, magari modificando ulteriormente la routine di inserimento, si potrebbe inserire il paramentro dell'altezza originario (basta solo quel valore eventualmente) nel "db" e fare in modo che le immagini vengano impostate in base a quel valore.

Utilizzando la "navigazione" con l'oggetto MSXML2.ServerXMLHTTP, per elaborare 114 link, dal mio portatile, si impiegano circa 45".
Con la procedura originaria di Elio, e la navigazione tramite IE, si impiegano circa 160" (sempre dallo stesso computer).

Una particolarità è che l'elento src restituisce come testo il link con atenposto "about" e questo fa sì che il file non venga creato nel percorso di destinazione.
Ho quindi eseguito una sostituzione tra "about" e "https".

Altra cosa che ho notato, sul mio pc, è che excel nel titolo della finestra avvisa che il file "non risponde" e anche il conteggio nella barra di stato si blocca non mostrando più i numeri successivi.
Però alla fine la procedura viene portata a termine regolarmente.
Ho quindi modificato il testo della barra di stato in un più generico:
"Elaborazioni in corso. Attendere prego ...".
Ma magari è solo un problema del mio pc.

Se volete verificare questo è il file nella versione "B":
https://www.dropbox.com/s/c031ew3y1s855y2/test%20Web%20Scraping%233B.xlsm?dl=0

Riporto il testo delle due routine modificate:


Sub getSrcAttributeImgTag2()

Const DeltaStep = 25 'numero di celle tra una immagine di una Url e l'altra
Const sPathFrancobolli As String = "D:\Test\Francobolli\"
Const sPathFiligrane As String = "D:\Test\Filigrane\"

Const ImgCmHeight As Double = 7.96
Const ImgCmWidth As Double = 7.98

Dim iTimer As Long
Dim fTimer As Long
Dim result As Long
Dim objHTTP As Object
Dim htmlDoc As Object
Dim ElementCol As Object
Dim Link As Object
Dim sPath As String
Dim cTime As Date
Dim Wb As Workbook
Dim wsLink As Worksheet
Dim wsImmagini As Worksheet
Dim wsFiligrane As Worksheet
Dim wsLinkFalliti As Worksheet
Dim rngLink As Range
Dim sURL As String, sNumCat As String
Dim sURL_Response
Dim sName As String
Dim r As Range
Dim iStep As Long
Dim iLink As Long
Dim NumLink As Long
Dim sPath1 As String, sPath2 As String
Dim sDrive1 As String, sDrive2 As String

iTimer = Timer


'<--- gestione percorsi salvataggio file immagini --->
sPath1 = sPathFrancobolli
If Right(sPath1, 1) <> "\" Then sPath1 = sPath1 & "\"
sPath2 = sPathFiligrane
If Right(sPath2, 1) <> "\" Then sPath2 = sPath2 & "\"
sDrive1 = Left(sPath1, 2)
sDrive2 = Left(sPath2, 2)
With CreateObject("Scripting.FileSystemObject")
If Not .DriveExists(Left(sPath1, 2)) Then Exit Sub
If Not .DriveExists(Left(sPath2, 2)) Then Exit Sub
Select Case .GetDrive(sDrive1).DriveType
Case 0, 4, 5
Exit Sub
End Select
Select Case .GetDrive(sDrive2).DriveType
Case 0, 4, 5
Exit Sub
End Select
If Not .FolderExists(sPath1) Then .CreateFolder sPath1
If Not .FolderExists(sPath2) Then .CreateFolder sPath2
End With
'</--- gestione percorsi salvataggio file immagini --->

Set Wb = ThisWorkbook
With Wb
Set wsLink = .Worksheets("Link")
Set wsImmagini = .Worksheets("Immagini")
Set wsFiligrane = .Worksheets("Filigrane")
Set wsLinkFalliti = .Worksheets("Link_Falliti")
End With
Set rngLink = wsLink.Range("A1").CurrentRegion.Columns(1)
NumLink = rngLink.Rows.count
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

On Error GoTo ErrHandler

Call CancellaWsImmagini
Call CancellaLinkFalliti

Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
Set htmlDoc = CreateObject("htmlfile")

For Each r In rngLink.Cells
On Error GoTo ErrHandler
iLink = iLink + 1
Application.StatusBar = "Elaborazionie in corso. Attendere prego ... " '"Link " & iLink & " di " & NumLink & " in elaborazione."
'sURL = r.Hyperlinks(1).Address 'prende l'indirizzo del link _
(da usare se le celle presentano un link)
sURL = r.Value 'prende il valore nella cella _
(da usare se le celle non presentano un link _
ma il valore della cella corrisponde all'intera URL)

sNumCat = r.Offset(, 1).Value

With objHTTP
.Open "GET", sURL, False
.send
If .Status <> 200 Then GoTo Continua
Do While .readyState <> 4
DoEvents
Loop
End With

With htmlDoc
.body.innerHTML = objHTTP.responseText
sName = .getElementById("name").innerText
End With

'Set ElementCol = html.querySelectorAll("div.item_z_pic>img")'solleva un errore 462 al successivo ciclo
Set ElementCol = htmlDoc.getElementsByTagName("img")
For Each Link In ElementCol
If LCase(ExtFind2(Link.src)) = "jpg" Then
If InStr(1, Link.src, "none-stamps") > 0 Then
'Debug.Print Link.src
ElseIf InStr(1, Link.src, "-back") = 0 Then
With wsImmagini
With .Range("A1")
With .Offset(iStep)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(iStep, 1) = sNumCat
.Offset(iStep + 1) = Link.alt
With .Offset(iStep, 2)
.Value = Replace(Link.src, "about", "https")
'.Value = Link.src
Call AddHyperLink(.Value, .Item(1, 1))
result = DownloadFile2(.Value, sPath1, _
SostituisciCaratteriVietatiNomiFile(sNumCat)) 'metodo ADODB Stream. NB la routine è parametrata per la sovrascrittura in caso contario verrebbe sollevato errore 3024
If result = 1 Then
.Offset(0, 1) = sPath1 & sNumCat & ".jpg"
Call AddHyperLink(.Offset(0, 1).Value, .Offset(0, 1))
With wsImmagini
.Activate
InsertPicture sPath1 & sNumCat & ".jpg", .Range("A1").Offset(iStep), _
False, False, ImgCmHeight, ImgCmWidth, sNumCat
End With
End If
End With
End With
End With
Else
With wsFiligrane
With .Range("A1")
With .Offset(iStep)
.Value = sURL
Call AddHyperLink(.Value, .Item(1, 1))
End With
.Offset(iStep, 1) = sNumCat
.Offset(iStep + 1) = Link.alt
If LCase(ExtFind2(Link.src)) = "jpg" Then
With .Offset(iStep, 2)
.Value = Replace(Link.src, "about", "https")
Call AddHyperLink(.Value, .Item(1, 1))
result = DownloadFile2(.Value, sPath2, _
SostituisciCaratteriVietatiNomiFile(sNumCat)) 'metodo ADODB Stream NB la routine è parametrata per la sovrascrittura in caso contario verrebbe sollevato errore 3024
If result = 1 Then
.Offset(0, 1) = sPath2 & sNumCat & ".jpg"
Call AddHyperLink(.Offset(0, 1).Value, .Offset(0, 1))
With wsFiligrane
.Activate
InsertPicture sPath2 & sNumCat & ".jpg", .Range("A1").Offset(iStep), _
False, False, ImgCmHeight, ImgCmWidth, sNumCat
End With
End If
End With
End If
End With
End With
End If
End If
Next Link
Continua:
iStep = iStep + DeltaStep
result = 0
On Error GoTo ErrHandler
Next r
With wsFiligrane
.Activate
.Range("A1").Select
End With
With wsImmagini
.Activate
.Range("A1").Select
End With
fTimer = Timer
MsgBox "Tempo di esecuzione per l'elaborazione di " & iLink & " link: " & fTimer - iTimer & " secondi"
ExitProc:
With Application
.StatusBar = ""
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
Exit Sub
ErrHandler:
Select Case Err.Number
Case Is = -2147467259, -2147467259
On Error Resume Next
'Call LinkFalliti(wsLinkFalliti, r.Value, Err.Description)
Err.Clear
On Error GoTo 0
Resume Continua
Case Else
MsgBox "Errore n: " & Err.Number & vbCrLf & "Descrizione:" & vbCrLf & Err.Description
Resume ExitProc
End Select
End Sub


Sub InsertPicture(PictureFileName As String, _
TargetCell As Range, _
CenterH As Boolean, _
CenterV As Boolean, _
cmHeight As Double, _
cmWidth As Double, _
Optional PictureName As String)
'modificato da https://www.exceltip.com/general-topics-in-vba/insert-pictures-using-vba-in-microsoft-excel.html
'insert a picture at the topo left position of TargetCell
'the picture can be centered horizontally and/ore vertically
Dim p As Object, t As Double, l As Double, w As Double, H As Double, sExt As String

If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then
Debug.Print "Non trovato file con percorso: " & PictureFileName
Exit Sub
End If
'import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
'determine positions
With TargetCell.Offset(2, 0)
t = .Top
l = .Left
If CenterH Then
w = .Offset(0, 1).Left - .Left
l = l + w / 2 - p.Width / 2
If l < 1 Then l = 1
End If
If CenterV Then
H = .Offset(1, 0).Top - .Top
t = t + H / 2 - p.Height / 2
If t < 1 Then t = 1
End If
End With
'position and name picture
With p
If Len(PictureName) > 0 Then
.Name = PictureName
Else
.Name = PictureFileName
End If
.Top = t
.Left = l
.Select

With Windows(1).Selection.ShapeRange(1)
.LockAspectRatio = msoTrue
If .Height >= .Width Then
.Height = Application.CentimetersToPoints(cmHeight)
Else
.Width = Application.CentimetersToPoints(cmWidth)
End If

End With

End With
Set p = Nothing
End Sub

[casanmaner]

Post by casanmaner
Ciao Draleo e Elio,
prendendo spunto dall'ultima versione del file di Elio ho voluto provare a non ...

p.s. rispetto al codice postato ho fatto qualche aggiustamento nel modulo del file. poca cosa più che altro di forma o correzione dell'avviso della barra di stato.

ciao

[casanmaner]

Scusate ma provando il file su un altro PC mi sono reso conto che la "gestione" dei percorsi così come impostata non va bene (a meno che non sia solo l'ultima parte del percorso a non esistere).
Ho quindi pensato ad una function che da una parte mi restituisca vero o falso se un percorso è corretto e dall'altra in caso non sia presente lo crea, creando ogni subfolder.

Sempre nel file precedente (https://www.dropbox.com/s/c031ew3y1s855y2/test%20Web%20Scraping%233B.xlsm?dl=0), nel modulo M_Utilities ho inserito la seguente Function:
Function CreateFolders(sPath As String) As Boolean

Dim arrPercorsi As Variant
Dim bPercorsoCreato As Boolean
Dim Fso As Object
Dim sDrive As String
Dim UB As Long, i As Long

bPercorsoCreato = True
arrPercorsi = Split(sPath, "\")
UB = UBound(arrPercorsi)
If UB = -1 Then bPercorsoCreato = False
If bPercorsoCreato Then
sDrive = arrPercorsi(0)
If Right(sDrive, 1) <> ":" Then sDrive = sDrive & ":"
End If
If bPercorsoCreato Then
Set Fso = CreateObject("Scripting.FileSystemObject")
With Fso
If Not .DriveExists(sDrive) Then bPercorsoCreato = False
If bPercorsoCreato Then
Select Case .GetDrive(sDrive).DriveType
Case 0, 4, 5
bPercorsoCreato = False
End Select
End If
If bPercorsoCreato Then
sPath = sDrive
On Error Resume Next
For i = 1 To UB
sPath = sPath & "\" & arrPercorsi(i)
If Not .FolderExists(sPath) Then .CreateFolder sPath
If Err.Number <> 0 Then
bPercorsoCreato = False
Exit For
End If
Next i
On Error GoTo 0
End If
End With
End If
CreateFolders = bPercorsoCreato
Set Fso = Nothing

End Function


E nella routine getSrcAttributeImgTag2, presente nel modulo2, ho così modificato la parte della gestione dei percorsi:

'<--- gestione percorsi salvataggio file immagini --->
sPath1 = sPathFrancobolli
If Right(sPath1, 1) <> "\" Then sPath1 = sPath1 & "\"
sPath2 = sPathFiligrane
If Right(sPath2, 1) <> "\" Then sPath2 = sPath2 & "\"
If Not CreateFolders(sPath1) Then
MsgBox sPathFrancobolli & " non è un percorso valido!", vbCritical
Exit Sub
End If
If Not CreateFolders(sPath2) Then
MsgBox sPathFiligrane & " non è un percorso valido!", vbCritical
Exit Sub
End If
'</--- gestione percorsi salvataggio file immagini --->


Semre nella suddetta routine ho anche impostato a Nothing gli oggetti "esterni" in precedenza "settati".
In questa maniera il file mi sembra più completo.

N.B. i percorsi devono sempre trovarsi su un percorso in un disco fisso o nel caso di percorso di rete in un percorso comunque individuato come "unità di rete".

ciao

[draleo]

Quella di ieri sera è ancora più veloce (67 sec) della precedente (che era già veloce) ! Non credevo proprio che da Excel si potessero fare tutto questo .Ne è venuto fuori un applicativo che non ha nulla da invidiare ( anzi è anche meglio) di altri applicativi professionali ( tra l’altro molti a pagamento) dello stesso genere. Non sono un conoscitore del mondo informatico , ma penso che ci siano poche persone – e non solo in Italia- in grado di fare cose del genere (tra l’altro in breve tempo). Chapeau per entrambi !
Passiamo ai dettagli tecnici:
1) nella versione Importare Dati da pagina Web io avevo inserito una mia macro (che riporto sotto) che estraeva dal Foglio Tmp_immagini la descrizione in formato testo della filigrana (cioè corona,corona grande, piccola ecc) :cioè spazzolava alcune celle del foglio Tmp_immagini, alla ricerca della parola chiave “filigrana” e, se la trovava , riportava il contenuto della cella adiacente , nel foglio Filigrana. Era una macro elementare , ma efficace e riusciva a fare quanto richiesto. Ma ora che il metodo di estrazione è cambiato e non c’è più il Foglio Tmp_immagini, dove inserisco questa macro ? o comunque come si fa – se si può fare - a reperire questa informazione e portarla da qualche parte, in un qualche Foglio ?
2) Dimensioni immagini: la correzione suggerita da Elio (portare l’altezza da 300 a 200 points) migliora la situazione ( prima le immagini erano mastodontiche), ma comunque rimangono sempre parecchio più grandi del reale e anche la soluzione di Ermanno porta a delle immagini maggiorate.
Ermanno dice "Volendo, magari modificando ulteriormente la routine di inserimento, si potrebbe inserire il paramentro dell'altezza originario (basta solo quel valore eventualmente) nel "db" e fare in modo che le immagini vengano impostate in base a quel valore”.
Io in effetti ho le reali dimensioni (larghezza ed altezza in mm )di quasi tutti (circa l’80%) i francobolli in questione. Inserendo queste dimensioni reali nel foglio Link (per es colonna C e D), si possono ridimensionare le immagini portandole almeno vicine a quelle reali ?
3) Io non ho avuto malfunzionamenti, legati ai percorsi; ma se lo dici tu, scarico la nuova versione
Infine rispondo ad Elio
“Peraltro continuo a pensare che la struttura più pulita è quella che prevede solo dati e non immagini. L'utente se vuole può attivare i link che puntano alle Pagini/immagini sul WEB piuttosto che attivare i link che puntano alle immagini su disco”.
In realtà i dati ai quali ti riferisci io già li posseggo : dal sito in questione si può importare lecitamente tutto quello che si vuole, in formato csv (ma NON le immagini); bastano pochi clik del mouse e non servono programmi particolari. E ci sono anche i link , che puntano alle rispettive immagini.In effetti fino ad 1 mese fa era questo il metodo che seguivo. Ma...servono almeno 10-15 sec per linkare ogni immagine , mentre il link al mio HD è immediato; inoltre , tra poco, consultare quel sito diverrà a pagamento…
Comunque sia di nuovo Chapeau per entrambi !
draleo
-----------------------
Sub Estrai_Filig()
Dim WsTmp As Worksheet
Dim wsImmagini As Worksheet
Dim i As Long, CellFound As Range, FirstAddress As String
Dim DoveSono As Range, DoveLiMetto As Range
Set WsTmp = Worksheets("Tmp_Immagini")
Set wsImmagini = Worksheets("Filigrane")
Set DoveSono = WsTmp.Range("A120:A132")
Set DoveLiMetto = wsImmagini.Range("A65536").End(xlUp).Offset(-1, 2)
With DoveSono
Set CellFound = .Find( _
After:=DoveSono(DoveSono.Count), _
What:="Filigrana", _
MatchCase:=False, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
LookAt:=xlPart, _
LookIn:=xlValues)
If Not CellFound Is Nothing Then
FirstAddress = CellFound.Address
Do
i = i + 1
DoveLiMetto(i) = CellFound.Offset(1, 0)
Set CellFound = .FindNext(CellFound)
Loop While CellFound.Address <> FirstAddress
Else: DoveLiMetto = "Snz Fil"
End If
End With

End Sub

[casanmaner]

Ciao Draleo,
per quanto riguarda le dimensioni io mi sono basato sulle stesse dimensioni delle immagini importate con la procedura iniziale.
Se risultano maggiorate è perché già sono maggiorate quelle del sito.
Per alcuni francobolli vedo che ci sono le dimanzioni in mm (identificabili dalla voce "Dimensioni:" o "Size:" ma magari per altri francobolli l'indicazione è differente).
Per quanto riguarda la tua richiesta, che se non ho capito male richiede il "nome" del tipo di filigrana se presente. Es. "Emblemi araldici" per alcuni francobolli dei primi link di test che hai pubblicato.
Io non ho trovato altro modo che "ciclare" tutti gli elementi con tag dt, contando il numero di cicli, individuare, se presente, il testo "Filigrana:" e in base al numero contato estrarre tra tutti i tag dd quello che assume la stessa posizione del tag dd.
Magari c'è un altro modo più efficiente ma io questo sono riuscito a fare.
Nello stesso modo, per i francobolli per cui è presente la voce "Dimensioni" o "Size" sarebbe possibile estrarre quella stringa e estrarre dalla stessa le dimensioni da applicare alle immagini.
Rimarrebbe però il problema per quei francobolli per cui tale indicazione non è presente.

Comunque intanto vedi questa versione #4 del file "test Web Scraping" dove nel foglio filigrane ho inserito l'eventuale descrizione della filigrana o il testo "snz fil" se non presente.
https://www.dropbox.com/s/4tm2g8k7k4jl6g0/test%20Web%20Scraping%234.xlsm?dl=0

Ho inserto delle nuove dichiarazioni:

Dim cont As Long
Dim Tag_dt As Object
Dim Tag_dd As Object
Dim sFiligrana As String

e prima di "Set ElementCol = htmlDoc.getElementsByTagName("img")" ho inserito:

Set Tag_dt = htmlDoc.getElementsByTagName("dt")
Set Tag_dd = htmlDoc.getElementsByTagName("dd")
cont = 0
sFiligrana = "Snz Fil"
For Each Link In Tag_dt
If Link.innerText = "Filigrana:" Then
sFiligrana = Tag_dd(cont).innerText
End If
cont = cont + 1
Next Link


Nella parte di inserimento dati nel foglio WsFiligrane ho inserito questa istruzione:

.Offset(iStep + 1, 2) = sFiligrana

Verifica se è quello che ti interessava.

ciao

[casanmaner]

p.s. nel file in realtà ho modificato, rispetto a quanto detto prima, ulteriormente il codice vba per non ripetere più volte il riferimento a htmlDoc inserendo tutto sotto l'iniziale With htmlDoc:

With htmlDoc
.body.innerHTML = objHTTP.responseText
sName = .getElementById("name").innerText
Set Tag_dt = .getElementsByTagName("dt")
Set Tag_dd = .getElementsByTagName("dd")
Set ElementCol = .getElementsByTagName("img")
End With

[draleo]

io mi sono basato sulle stesse dimensioni delle immagini importate con la >procedura iniziale.
Se risultano maggiorate è perché già sono maggiorate quelle del sito.
Per alcuni francobolli vedo che ci sono le dimanzioni in mm (identificabili dalla voce "Dimensioni:" o "Size:" ma magari per altri francobolli l'indicazione è differente).

Vero. Comunque ho avuto l'impressione che nelle versioni precedenti, la pagina Web (che io vedevo interrompendo la procedura, nel foglio Tmp_immagini) non è la stessa di queste ultime versioni. Quella di prima era totalmente in Italiano e aveva immagini più piccole. Questa di adesso ,qualche volta è in lingua Inglese, qualche volta in Italiano e le immagini sono nettamente più grandi.

Io non ho trovato altro modo che "ciclare" tutti gli elementi con tag dt, >contando il numero di cicli, individuare, se presente, il testo "Filigrana:" e >in base al numero contato estrarre tra tutti i tag dd quello che assume la >stessa posizione del tag dd.

Hai capito benissimo. il nome della filigrana è quello individuato da te e credo non ci siano altri modi che ciclare i tag. Comunque con la tua ultima versione il nome della filigrana viene estratta correttamente (se c'è); Magari ho notato che quando la pagina è in Italiano la parola chiave è"Filigrana"; quando è in Inglese la dizione è "Watermark"

Nello stesso modo, per i francobolli per cui è presente la voce "Dimensioni" > o "Size" sarebbe possibile estrarre quella stringa e estrarre dalla stessa le > dimensioni da applicare alle immagini.

No, estrarre le dimensioni dalla striga,questo no. a parte che scomporre la stringa porterebbe una inutile complicazione; c'è anche il fatto che le dimensioni (o size ) indicate nella pagina Web si riferiscono alla vignetta (il vero francobollo è circa 3mm maggiore in altezza e larghezza);e altre volte le dimensioni riportate sono pure sbagliate; quindi se si possono utilizzare le dimensioni indicate dal sottoscritto , accanto a ciascun Link nella pagina Link, bene; altrimenti meglio lasciare le cose come stanno. Non è un problema rilevante e meglio non cercare complicazioni.

Rimarrebbe però il problema per quei francobolli per cui tale indicazione non > è presente.

se non sono indicate le dimensioni (e capita nel 20% dei casi circa), allora si lascerebbero le attuali dimensioni. Comunque, ripeto, se queste dimensioni comportano troppe complicazioni, meglio lascviar perdere. sono molto più importanti tutte le altre cose realizzate

Ciao
draleo

[casanmaner]

Ma la versione in italiano o in inglese dipende dal link?
Uno stesso link a volte propone la pagina web in italiano e altre in inglese?

[draleo]

Post by casanmaner
Ma la versione in italiano o in inglese dipende dal link?
Uno stesso link a volte propone la pagina web in italiano e altre in inglese?

Sembra sia così; ho fatto un po’ di prove e ho ottenuto dei risultati contraddittori; qualche volta viene fuori una pagina in Italiano, qualche altra volta in inglese . Non so da cosa dipenda. Forse dalla lingua in cui è scritto l’indirizzo
Nel mio Pc, questo link restituisce una pagina in Inglese
http://colnect.com/stamps/stamp/26724
http://colnect.com/stamps/stamp/1906

quest’altro restituisce una pagina in Italiano
https://colnect.com/it/stamps/stamp/1444-Queen_Victoria-Regina_Vittoria_-_superficie_stampata-Gran_Bretagna
Comunque per non sbagliarsi cerca sia “Filigrana” sia Watermark.
Questo fenomeno io nelle versioni precedenti non lo avevo mai notato . Le pagine che venivano caricate nel foglio Tmp_immagini erano tutte in Italiano (e ne ho provate molte)

[casanmaner]

Post by draleo
Sembra sia così; ho fatto un po’ di prove e ho ottenuto dei risultati contraddittori; qualche volta viene fuori una pagina in Italiano, qualche altra volta in inglese . Non so da cosa dipenda. Forse dalla lingua in cui è scritto l’indirizzo
Nel mio Pc, questo link restituisce una pagina in Inglese
http://colnect.com/stamps/stamp/26724
http://colnect.com/stamps/stamp/1906

Provando dal mio pc si viene reindirizzati a:
https://colnect.com/it/stamps/stamp/26724-Entrance_to_the_castle_of_Versailles_by_Maurice_Utrillo-Palazzo_di_Versailles-Francia
https://colnect.com/it/stamps/stamp/1906-Hamlet_contemplating_Yoricks_Skull-Festival_di_Shakespeare-Gran_Bretagna

se a questi indirizzi sostituisco "it" con "en" mi viene restituito il sito in inglese e fino a che non richiudo il browser e poi lo riapro mi viene proposto il sito inglese.

Ho comunque modificato in modo che la ricerca venga effettuata se trova "Filigrana:" o "Watermark:".

Ho fatto anche alcune modifiche per ripristinare l'inserimento di alcuni dati nel foglio Filigrane (URL principale, nome francobollo, numero catalogo) anche se la filigrana non è presente (inserendo in questo caso Senza filigrana ove questa dizione non sia presente nel sito stesso come accade per alcuni che riporta il tag Filigrana: e come testo Senza filigrana).

Per le dimensioni ho aggiunto una costante iRayio da applicare alle dimensioni "base" nel caso fosse opportuno ridurre o aumentare (ho impostato ad es. 0.95).

Per la gestione delle dimensioni non sarebbe una cosa impossibile ma ho notato che ciò comporterebbe una gestione differente per il francobollo e la filigrana, ove presente, in quanto sia che il fronte sia in verticale o orizzontale la filigrana è sempre in "verticale".
Quindi non si potrebbero usare sempre le stesse dimensioni del fronte pena avere l'immagine della filigrana "invertita" per alcuni francobolli.
Ad es. questo:
https://colnect.com/it/stamps/stamp/1906-Hamlet_contemplating_Yoricks_Skull-Festival_di_Shakespeare-Gran_Bretagna.

Questo il file a cui ho assegnato nuovamente il nome del topic con numerazione #9:

https://www.dropbox.com/s/xxoie3h0bayr6io/Importare%20dati%20da%20pagina%20WEB%20%239.xlsm?dl=0

[draleo]

Post by casanmaner

Post by draleo
Sembra sia così; ho fatto un po’ di prove e ho ottenuto dei risultati contraddittori; qualche volta viene fuori una pagina in Italiano, qualche altra volta in inglese . Non so da cosa dipenda. Forse dalla lingua in cui è scritto l’indirizzo
Nel mio Pc, questo link restituisce una pagina in Inglese
http://colnect.com/stamps/stamp/26724
http://colnect.com/stamps/stamp/1906

https://colnect.com/it/stamps/stamp/26724-Entrance_to_the_castle_of_Versailles_by_Maurice_Utrillo-Palazzo_di_Versailles-Francia
https://colnect.com/it/stamps/stamp/1906-Hamlet_contemplating_Yoricks_Skull-Festival_di_Shakespeare-Gran_Bretagna
se a questi indirizzi sostituisco "it" con "en" mi viene restituito il sito in inglese e fino a che non richiudo il browser e poi lo riapro mi viene proposto il sito inglese.
Ho comunque modificato in modo che la ricerca venga effettuata se trova "Filigrana:" o "Watermark:".
Ho fatto anche alcune modifiche per ripristinare l'inserimento di alcuni dati nel foglio Filigrane (URL principale, nome francobollo, numero catalogo) anche se la filigrana non è presente (inserendo in questo caso Senza filigrana ove questa dizione non sia presente nel sito stesso come accade per alcuni che riporta il tag Filigrana: e come testo Senza filigrana).
Per le dimensioni ho aggiunto una costante iRayio da applicare alle dimensioni "base" nel caso fosse opportuno ridurre o aumentare (ho impostato ad es. 0.95).
Per la gestione delle dimensioni non sarebbe una cosa impossibile ma ho notato che ciò comporterebbe una gestione differente per il francobollo e la filigrana, ove presente, in quanto sia che il fronte sia in verticale o orizzontale la filigrana è sempre in "verticale".
Quindi non si potrebbero usare sempre le stesse dimensioni del fronte pena avere l'immagine della filigrana "invertita" per alcuni francobolli.
https://colnect.com/it/stamps/stamp/1906-Hamlet_contemplating_Yoricks_Skull-Festival_di_Shakespeare-Gran_Bretagna.
https://www.dropbox.com/s/xxoie3h0bayr6io/Importare%20dati%20da%20pagina%20WEB%20%239.xlsm?dl=0

Si. Credo che meglio di così non si possa fare. Anche la soluzione di quella costante per ridurre o aumentare le dimensioni è ideale (non l'avevo proprio pensato). Può bastare così (anche per non essere bannato a forza dal gruppo, che probabilmente non ne può più...non credo che ci siano altri interessati all'argomento). Non ho parole per ringraziarti

draleo

[casanmaner]

Post by draleo

Post by casanmaner

Post by draleo
Sembra sia così; ho fatto un po’ di prove e ho ottenuto dei risultati contraddittori; qualche volta viene fuori una pagina in Italiano, qualche altra volta in inglese . Non so da cosa dipenda. Forse dalla lingua in cui è scritto l’indirizzo
Nel mio Pc, questo link restituisce una pagina in Inglese
http://colnect.com/stamps/stamp/26724
http://colnect.com/stamps/stamp/1906

https://colnect.com/it/stamps/stamp/26724-Entrance_to_the_castle_of_Versailles_by_Maurice_Utrillo-Palazzo_di_Versailles-Francia
https://colnect.com/it/stamps/stamp/1906-Hamlet_contemplating_Yoricks_Skull-Festival_di_Shakespeare-Gran_Bretagna
se a questi indirizzi sostituisco "it" con "en" mi viene restituito il sito in inglese e fino a che non richiudo il browser e poi lo riapro mi viene proposto il sito inglese.
Ho comunque modificato in modo che la ricerca venga effettuata se trova "Filigrana:" o "Watermark:".
Ho fatto anche alcune modifiche per ripristinare l'inserimento di alcuni dati nel foglio Filigrane (URL principale, nome francobollo, numero catalogo) anche se la filigrana non è presente (inserendo in questo caso Senza filigrana ove questa dizione non sia presente nel sito stesso come accade per alcuni che riporta il tag Filigrana: e come testo Senza filigrana).
Per le dimensioni ho aggiunto una costante iRayio da applicare alle dimensioni "base" nel caso fosse opportuno ridurre o aumentare (ho impostato ad es. 0.95).
Per la gestione delle dimensioni non sarebbe una cosa impossibile ma ho notato che ciò comporterebbe una gestione differente per il francobollo e la filigrana, ove presente, in quanto sia che il fronte sia in verticale o orizzontale la filigrana è sempre in "verticale".
Quindi non si potrebbero usare sempre le stesse dimensioni del fronte pena avere l'immagine della filigrana "invertita" per alcuni francobolli.
https://colnect.com/it/stamps/stamp/1906-Hamlet_contemplating_Yoricks_Skull-Festival_di_Shakespeare-Gran_Bretagna.
https://www.dropbox.com/s/xxoie3h0bayr6io/Importare%20dati%20da%20pagina%20WEB%20%239.xlsm?dl=0

Si. Credo che meglio di così non si possa fare. Anche la soluzione di quella costante per ridurre o aumentare le dimensioni è ideale (non l'avevo proprio pensato). Può bastare così (anche per non essere bannato a forza dal gruppo, che probabilmente non ne può più...non credo che ci siano altri interessati all'argomento). Non ho parole per ringraziarti
draleo

In verità questa mattina, visto che mi sono svegliato presto, ho impostato anche la possibilità di indicare le dimensioni (entrambe).
Vedi questa versione #10:
https://www.dropbox.com/s/3ko2nv55hvmowsh/Importare%20dati%20da%20pagina%20WEB%20%2310.xlsm?dl=0

Adesso ho da fare ma magari oggi a pausa pranzo spiego le modifiche.
Comunque se non sono presenti entrambe le dimensioni viene eseguito il dimensionamento "standard", con l'applicazione del "demoltiplicatore".

[casanmaner]

Ciao Draleo,
per concludere questo lavoro ti propongo questa versione #11 del file dove ho fatto un po' di pulizia nel progetto VBA per avere solo le procedure e le utility necessarie.
Ho anche cercato di "razionalizzare" le utility "DownloadFile" e "InserisciImmagine" (ex inserpicture) per renderle utilizzabili in generale in caso di futuri utilizzi.
In InserisciImmagine ad es. il dimensionamento deve essere fatto prima della fase di determinazione della posizione per sfruttare correttamente l'eventuale possibilità di centrare le immagini.
Per funzione "DownloadFile" ho fatto in modo che restituisca Vero/Falso (in luogo di un numero) e inoltre ho fatto in modo che anche in caso in cui lo "Status" non sia 200 venga restituito un errore in modo che la funzione restituisca Falso così da sapere se in effetti un file è stato scaricato dalla URL indicata.

Anche la procedura principale ha subito alcuni ritocchi, per adeguare alle modifiche alle due utility precedenti, e per "pulire" il codice da azioni non più necessarie.
Ad es. non è ora necessario attivare ogni volta e alternativamente i fogli Immagini e Filigrane.
Questo il link al file:
https://www.dropbox.com/s/woovprdzf6mwzj9/Importare%20dati%20da%20pagina%20WEB%20%2311.xlsm?dl=0

Con l'occasione ringrazio Elio per avermi dato l'opportunità di approndire la conoscenza di alcuni oggetti :)

[b***@gmail.com]

Post by casanmaner

Post by draleo

Post by casanmaner

Post by draleo
Sembra sia così; ho fatto un po’ di prove e ho ottenuto dei risultati contraddittori; qualche volta viene fuori una pagina in Italiano, qualche altra volta in inglese . Non so da cosa dipenda. Forse dalla lingua in cui è scritto l’indirizzo
Nel mio Pc, questo link restituisce una pagina in Inglese
http://colnect.com/stamps/stamp/26724
http://colnect.com/stamps/stamp/1906

https://colnect.com/it/stamps/stamp/26724-Entrance_to_the_castle_of_Versailles_by_Maurice_Utrillo-Palazzo_di_Versailles-Francia
https://colnect.com/it/stamps/stamp/1906-Hamlet_contemplating_Yoricks_Skull-Festival_di_Shakespeare-Gran_Bretagna
se a questi indirizzi sostituisco "it" con "en" mi viene restituito il sito in inglese e fino a che non richiudo il browser e poi lo riapro mi viene proposto il sito inglese.
Ho comunque modificato in modo che la ricerca venga effettuata se trova "Filigrana:" o "Watermark:".
Ho fatto anche alcune modifiche per ripristinare l'inserimento di alcuni dati nel foglio Filigrane (URL principale, nome francobollo, numero catalogo) anche se la filigrana non è presente (inserendo in questo caso Senza filigrana ove questa dizione non sia presente nel sito stesso come accade per alcuni che riporta il tag Filigrana: e come testo Senza filigrana).
Per le dimensioni ho aggiunto una costante iRayio da applicare alle dimensioni "base" nel caso fosse opportuno ridurre o aumentare (ho impostato ad es. 0.95).
Per la gestione delle dimensioni non sarebbe una cosa impossibile ma ho notato che ciò comporterebbe una gestione differente per il francobollo e la filigrana, ove presente, in quanto sia che il fronte sia in verticale o orizzontale la filigrana è sempre in "verticale".
Quindi non si potrebbero usare sempre le stesse dimensioni del fronte pena avere l'immagine della filigrana "invertita" per alcuni francobolli.
https://colnect.com/it/stamps/stamp/1906-Hamlet_contemplating_Yoricks_Skull-Festival_di_Shakespeare-Gran_Bretagna.
https://www.dropbox.com/s/xxoie3h0bayr6io/Importare%20dati%20da%20pagina%20WEB%20%239.xlsm?dl=0

Si. Credo che meglio di così non si possa fare. Anche la soluzione di quella costante per ridurre o aumentare le dimensioni è ideale (non l'avevo proprio pensato). Può bastare così (anche per non essere bannato a forza dal gruppo, che probabilmente non ne può più...non credo che ci siano altri interessati all'argomento). Non ho parole per ringraziarti
draleo

In verità questa mattina, visto che mi sono svegliato presto, ho impostato anche la possibilità di indicare le dimensioni (entrambe).
https://www.dropbox.com/s/3ko2nv55hvmowsh/Importare%20dati%20da%20pagina%20WEB%20%2310.xlsm?dl=0
Adesso ho da fare ma magari oggi a pausa pranzo spiego le modifiche.
Comunque se non sono presenti entrambe le dimensioni viene eseguito il dimensionamento "standard", con l'applicazione del "demoltiplicatore".

Porto ancora il mio contributo con queste osservazioni che derivano dalle nozioni sul webscraping che mano mano vado apprendendo (sono anche io un neofita). Visto che la struttura dei tag che hanno l'informazione dell'url dell'immagine del francobollo ed eventualmente della filigrana (non sempre presente ) è costante proporrei:
Set ElementCol = htmlDoc.getElementsByClassName("item_z_pic") ' 1 o 2 elementi
Set LinkFrancobollo = ElementCol(0).Children(0) 'Restituisce Tag img francobollo
Set LinkFiligrana = ElementCol(1).Children(0) 'restituisce nothing se non c'è, viceversa restituisce Tag img filigrana
l'url delle immagini è restituito da LinkFrancobollo.src oppure LinkFrancobollo.getAttribute("src")
in primo tentativo il metodo getElementsByClassName mi dava errore poi gloogando ho scoperto che funzionava se si istanziava htmlfile con early binding:
Dim htmlDoc As HTMLDocument
..........
Set htmlDoc = New HTMLDocument

https://stackoverflow.com/questions/23476502/getelementsbyclassname-open-ie-vs-msxml2-methods

Se l'assenza dell'immagine della filigrana comporta anche l'assenza degli innertext Filigrana: e Watermark si può ovviamente non solo risparmiare codice di loop per ogni tag img ma anche quello relativo alle dimensione delle filigrane

[casanmaner]

Ciao Elio (e Draleo),
alla luce del tuo contributo metto il link alla versione #12 dove ho sfruttato la precisa individuazione degli "link" alle immagini.
Quello che al momento non sono riuscito ad individuare è l'innerText della filigrana se non utilizzando comunque il ciclo dei "TagName", limitandomi a prevedere tale ciclo solo ove LinkFiligrana non restituisca Nothing.

https://www.dropbox.com/s/58l4lneqgtxqhy9/Importare%20dati%20da%20pagina%20WEB%20%2312.xlsm?dl=0

ciao

[casanmaner]

Post by casanmaner
Ciao Elio (e Draleo),
alla luce del tuo contributo metto il link alla versione #12 dove ho sfruttato la precisa individuazione degli "link" alle immagini.
Quello che al momento non sono riuscito ad individuare è l'innerText della filigrana se non utilizzando comunque il ciclo dei "TagName", limitandomi a prevedere tale ciclo solo ove LinkFiligrana non restituisca Nothing.
https://www.dropbox.com/s/58l4lneqgtxqhy9/Importare%20dati%20da%20pagina%20WEB%20%2312.xlsm?dl=0

Ciao Rispetto a questo file ho fatto una modifica in quanto, nell'opera di sistemazione, mi ero dimenticato di valorizzare un paio di variabili delle dimensioni delle filigrane con conseguente errato dimensionamento o anche mancanto riporto nel foglio filigrane.