Macro Excel per creazione filmati timelapse

Mediante la macro Excel sotto riportata è possibile automatizzare lo scaricamento a intervalli regolari di immagini provenienti da webcam su internet.

Mettendo in sequenza le immagini tramite un programma tipo GifAnimator e intervallandole di pochi centesimi di secondo, si ottiene in riproduzione un filmato accelerato, che condensa in pochi secondi ore e ore di riprese effettive.

Questo filmato è composto da vari spezzoni, ognuno composto da circa 200 immagini scattate a intervalli di 5 minuti, per un totale di 1000 minuti (17 ore), condensati in 26 secondi, e si riferisce alla nevicata a roma del 10-11 febbraio 2012:

 

' Macro per la creazione di filmati timelapse.
' La macro scarica immagini da webcam pubbliche a intervalli
' regolari; è necessario successivamente utilizzare un programma
' per creazione di gif animate, per unire tutti i frame in un filmato.
'
' I file hanno nome "webcam_N_F.jpg":
' N = numero della webcam
' F = numero del frame relativo a quella webcam
'
' PROBLEMI NOTI:
' I file vengono salvati con suffisso .JPG qualunque sia il formato effettivo
' dell'immagine scaricata.
'
' Freeware - Jumpjack 2012

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

' ************** Richiede MICROSOFT HTML OBJECT LIBRARY (menu STRUMENTI-->RIFERIMENTI nell'editor VBA):
Public Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, _
ByVal szFileName As String, ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long

Dim WEBCAMS_NUMBER As Integer
Dim NUM_FRAMES As Integer
Dim WebcamURL(10) As String
Dim counter As Integer
Const MAXFILES = 10
Dim INTERVAL As Integer

Const MAX_Tentativi = 6
Dim path, strurl, nomefolder, nomefile(MAXFILES) As String

Sub InitVars()
'********************************************
    NUM_FRAMES = 500
    INTERVAL = 300 ' secondi
'********************************************

    WEBCAMS_NUMBER = 8 ' <<====   MODIFICARE IL NUMERO DI TELECAMERE SE SE NE AGGIUNGONO ALTRE!

' *********** INDICARE QUI GLI INDIRIZZI DELLE IMMAGINI DA SCARICARE *************************
    WebcamURL(1) = "http://93.67.98.178/record/current.jpg" ' Piazza Montecitorio
    WebcamURL(2) = "http://www.vaticanstate.va/images/webcam/radiovaticana.jpg" ' Vaticano 1
    WebcamURL(3) = "http://www2.alfa.it/italiawebcam/crop4.php?id=1552&w=800" ' Ostia
    WebcamURL(4) = "http://www.meteoaltatuscia.it/sanlorenzo/webcam.php"
    WebcamURL(5) = "http://www.vaticanstate.va/images/webcam/bracciocarlo.jpg" ' Vaticano 2
    WebcamURL(6) = "http://www.meteoaltatuscia.it/marta/webcam.php" ' Bolsena
    WebcamURL(7) = "http://www.meteoroccapriora.it/webcam/webcam.jpg" ' RoccaPriora
    WebcamURL(8) = "http://www.frosinonemeteo.it/webcam/webcam.php" ' Frosinone
    WebcamURL(9) = ""

' *********** CARTELLA IN  CUI VENGONO MEMORIZZATI I FILE *************
    nomefolder = "C:\temp\"
End Sub

Sub ScaricaFile()
    Call InitVars
    counter = 218 ' 1
    While counter <= NUM_FRAMES
        Tentativi = 0
        For x = 1 To WEBCAMS_NUMBER
            Scarica (x)
            Debug.Print "Scaricata cam " & Str(x) & "(" & strurl & " per " & Str(counter) & " volte."
            DoEvents
        Next
        counter = counter + 1
        SleepVBA (INTERVAL)
    Wend
    DoEvents
End Sub

Private Sub Scarica(x As Integer)
    strurl = WebcamURL(x) & "?dummy" & LTrim(Str$(counter))
    nomefile(x) = nomefolder & "\webcam_" & LTrim(Str(x)) & "_" & Str(counter) & ".jpg"
    Cells(10, 10) = "Scarico foglio " & Str(x) & "..."
    DoEvents
retry3:
        Tentativi = Tentativi + 1
        errcode = URLDownloadToFile(0, strurl, nomefile(x), 0, 0)
        If errcode = 0 Then
            'Debug.Print "OK"
        Else
            If Tentativi < MAX_Tentativi Then
                GoTo retry3:
            Else
                Debug.Print "############ Errore Scaricamento file  '" + nomefile(x) + " " + strurl                
                errcode = 0             
            End If
        End If
End Sub

Private Function zero(I As Integer) As String
    If I < 10 Then temp = "0" + LTrim(Str(I)) Else temp = LTrim(Str(I))
    zero = temp
End Function

Sub SleepVBA(secs As Integer)
Dim s As Integer
 For s = 1 To secs: Sleep 1000: DoEvents: Next
End Sub

La macro salva per ogni webcam una serie di file con nome webcam_X_Y, con X che identifica la webcam e Y il fotogramma.