PowerPoint previsão do tempo - dentro powerpoint

Dirceu Soares · 25 de novembro de 2019

Bom dia !! Pessoal, gostaria de saber se é possível inserir a previsão do tempo ( em tempo real) dentro de uma apresentação do PowerPoint.

ThiagoLuiz · 25 de novembro de 2019

Bom dia!
Talvez até seja mas através do uso de VBA.

Não encontrei nenhuma solução "simples" para o Power Point nem para o Prezi.

Basole · 26 de novembro de 2019

Uma opcao é importar os dados online, para um arquivo Excel atraves do vba, e vincular a apresentacao Powerpoint ao arquivo.

Exemplo:

* Na Plan1, celula A2, insira o nome da cidade e a sigla do pais, ex. sao paulo,br ( sem acentos )

Sub Obtendo_a_Previsao()
Dim xmlhttp As Object
Dim url As String
Dim xmlresponse As Object

Set xmlhttp = CreateObject("MSXML2.serverXMLHTTP") '
Set xmlresponse = CreateObject("MSXML2.DOMDocument.6.0")

With ThisWorkbook.Sheets(1)

url = "http://api.openweathermap.org/data/2.5/weather?apikey=4a2360d14bf33378079d2e2d49e35ddb&mode=xml&units=metric&q=" & _
                                                                    VBA.Replace(.Range("A2").Value, " ", "%20")
xmlhttp.Open "GET", url, False
xmlhttp.Send
xmlresponse.LoadXML (xmlhttp.responseText)


    .[B2:C4].ClearContents
On Error Resume Next
    .[B2] = "Minima:": .[B3] = "Maxima: ": .[B4] = "Umidade: "
    .[C2] = xmlresponse.SelectNodes("//current/temperature/@min")(0).Text
    .[C3] = xmlresponse.SelectNodes("//current/temperature/@max")(0).Text
    .[C4] = xmlresponse.SelectNodes("//current/humidity/@value")(0).Text
On Error GoTo 0

End With

End Sub

Luan Teles · 28 de novembro de 2019

Funcionou direitinho , valeu

Se possivel como adicionar a Unidade de Medida junta ao valor da Temperatura?

Tipo 21ºC

Outra coisa adicionei xmlresponse.SelectNodes("//current/clouds/@name")(0).Text

Que mostra, Nublado, Poucas Nuvens, Céu Limpo, porém teria como traduzir para o portugues? apenas nessa linha, e o valor vem em minusculo e.g few clouds, como fazer para Few Clouds? e traduzir claro Poucas Nuvens?

o que eu fiz foi para por as unidades foi, colocar o valor para aparecer por exemplo na M3 e deixar o texto em branco e adicionar na formula onde quero a unidade

Eg: = "Umidade: " &(M3) &"%"

e =ARREDONDAR.PARA.CIMA(M6;0)&"ºC"

Agora para condição de tempo =SE(M4="few clouds";"Poucas Nuves";SE(M4="clear sky";"Céu Limpo";SE(M4="broken clouds";"Céu Encoberto";SE(M4="overcast clouds";"Nublado";SE(M4="scattered clouds";"Nuvens Dispersas"))))) to usando assim, assim que vai aparecendo tipos de clima diferente vou traduzindo em mundando

Mas seria Legal direto do VBA

E usar o TheWeatherChanel que tem em portugues acho que AccuWeather também?

--------------------------------------------------------------------------------------------------------------------------------

Não querendo abusar muito

Ao invés de escrevermos a cidade, teria como usar um serviço online, tipo alguma api do google de localização?

uma planilha compartilhada, mostraria a cidade e a temperatura da localização do PC que abriu a planilha

Basole · 28 de novembro de 2019

@Luan Teles como no PC nao vem com app de localizacao nativa, utilizei a api para localizar o ip externo e obter a cidade e pais, assim nao precisa mais informar a cidade.

Pelo que pesquisei TheWeatherChanel e AccuWeather tem api pagos.

Adicionei a Unidade de Medida junto ao valor da Temperatura °C (graus ceucius)

Traduzindo few clouds, clear sky, overcast clouds, scattered clouds, etc nao ida dar muito certo pois o google translate, traduz ao pé da letra.

Entao associei os termos em inglês, ao em portugues.

E tambem acrescentei % a umidade.

Ah..e tambem traz o icone (imagem), de acordo com o tempo.

Sub Obtendo_a_Previsao_c_Localizacao()
Dim xmlhttp         As Object
Dim url             As String
Dim xmlresponse     As Object
Dim FinHTTP         As Object
Dim cidLoc          As String
Dim FinCloudIn()    As String
Dim FinCloudOut()   As String
Dim outarr()        As String
Dim x               As Integer
Dim j               As Integer
Dim mPicture        As Picture
Dim ws              As Worksheet

Const sCloudIn As String = "clear sky,few clouds,scattered clouds, broken clouds,overcast clouds"
Const sCloudOut As String = "Céu Limpo,Poucas Nuves,Nuvens Dispersas,Céu Encoberto,Nublado"


Set FinHTTP = VBA.CreateObject("Microsoft.xmlHTTP")
Set xmlhttp = VBA.CreateObject("MSXML2.serverXMLHTTP") '
Set xmlresponse = VBA.CreateObject("MSXML2.DOMDocument.6.0")

Set ws = ThisWorkbook.Sheets(1)  ' PLan 1
With ws

    url = "http://extreme-ip-lookup.com/csv/"
    
    FinHTTP.Open "GET", url, False
    FinHTTP.send
    
    FinCloudIn = Split(FinHTTP.responseText, ",")
    ReDim outarr(UBound(FinCloudIn) - 1)
    
    For j = 0 To UBound(FinCloudIn) - 1
         outarr(j) = FinCloudIn(j)
    Next j
    
    cidLoc = VBA.Replace(outarr(10), """", "") & "," & _
                        outarr(7)

    url = "http://api.openweathermap.org/data/2.5/weather?apikey=4a2360d14bf33378079d2e2d49e35ddb&mode=xml&units=metric&q=" & _
                                                                                                              cidLoc
                                                                
        xmlhttp.Open "GET", url, False
        xmlhttp.send
        xmlresponse.LoadXML (xmlhttp.responseText)
        
                FinCloudIn = VBA.Split(sCloudIn, ",")
                FinCloudOut = VBA.Split(sCloudOut, ",")
                  
                For j = 0 To UBound(FinCloudIn)
                    If FinCloudIn(j) = xmlresponse.SelectNodes("//current/clouds/@name")(0).Text Then
                        x = j
                        Exit For
                   End If
                Next j
        
     .[A2:C8].ClearContents
    
On Error Resume Next
    .[A2] = xmlresponse.SelectNodes("//current/city/@name")(0).Text
    .[B2] = "Temperatura:": .[B3] = "Minima:": .[B4] = "Maxima: ": .[B5] = "Umidade: "
    .[B6] = "Céu:": .[B7] = "Vento:": .[B8] = "Última Atualização"
    .[C2] = Excel.Application.WorksheetFunction.RoundDown(VBA.Val(xmlresponse.SelectNodes("//current/temperature/@value")(0).Text), 0) & VBA.Chr(176) & _
            VBA.UCase(VBA.Left(xmlresponse.SelectNodes("//current/temperature/@unit")(0).Text, 1))
    .[C3] = Excel.Application.WorksheetFunction.RoundDown(VBA.Val(xmlresponse.SelectNodes("//current/temperature/@min")(0).Text), 0) & VBA.Chr(176) & _
            VBA.UCase(VBA.Left(xmlresponse.SelectNodes("//current/temperature/@unit")(0).Text, 1))
    .[C4] = Excel.Application.WorksheetFunction.RoundDown(VBA.Val(xmlresponse.SelectNodes("//current/temperature/@max")(0).Text), 0) & VBA.Chr(176) & _
            VBA.UCase(VBA.Left(xmlresponse.SelectNodes("//current/temperature/@unit")(0).Text, 1))
    .[C5] = xmlresponse.SelectNodes("//current/humidity/@value")(0).Text & xmlresponse.SelectNodes("//current/humidity/@unit")(0).Text
    .[C6] = FinCloudOut(x)
    .[C7] = Excel.Application.WorksheetFunction.RoundDown(VBA.Val(xmlresponse.SelectNodes("//wind/speed/@value")(0).Text) / 1000 * 3600, 0) & " Km/h"
    .[C8] = VBA.Replace(xmlresponse.SelectNodes("//current/lastupdate/@value")(0).Text, "T", " ")
    .[C8] = .[C8] - VBA.TimeSerial(3, 0, 0)
    
            x = VBA.IIf(FinCloudOut(x) = "Nublado", 3, x)
            
      'Insere o icone do Tempo:
     Set mPicture = .Pictures.Insert("https://openweathermap.org/img/wn/0" & x + 1 & "[email protected]")
                                      
            With mPicture
                .ShapeRange.LockAspectRatio = msoFalse
                '.Width = ws.[D3].Width
                '.Height = ws.[D3].Height
                .Top = Rows(ws.[D3].Row).Top
                .Left = Columns(ws.[D3].Column).Left
            End With
   
On Error GoTo 0

End With

End Sub

Luan Teles · 28 de novembro de 2019

@Basole Nossa, ficou incrivel, só tem um problema, quando recarregado ou abrir e fechar a planilha, a imagem vai ser gerada de novo e fica em cima da anterior.

Usei .CleanContents porém ele so apaga os textos e a imagem não

Basole · 29 de novembro de 2019

Acrescentei agora esta comando para deletar a imagem nomeada como Icone_Tempo e ao inserir a imagem renomea desta forma.

codigo:

Spoiler



Sub Obtendo_a_Previsao_c_Localizacao()
Dim xmlhttp         As Object
Dim url             As String
Dim xmlresponse     As Object
Dim FinHTTP         As Object
Dim cidLoc          As String
Dim FinCloudIn()    As String
Dim FinCloudOut()   As String
Dim outArr()        As String
Dim x               As Integer
Dim j               As Integer
Dim mPicture        As Object
Dim ws              As Worksheet
Dim shp             As Shape

Const sCloudIn As String = "clear sky,few clouds,scattered clouds, broken clouds,overcast clouds"
Const sCloudOut As String = "Céu Limpo,Poucas Nuves,Nuvens Dispersas,Céu Encoberto,Nublado"


Set FinHTTP = VBA.CreateObject("Microsoft.xmlHTTP")
Set xmlhttp = VBA.CreateObject("MSXML2.serverXMLHTTP") '
Set xmlresponse = VBA.CreateObject("MSXML2.DOMDocument.6.0")

Set ws = ThisWorkbook.Sheets(1)  ' PLan 1
With ws

    url = "http://extreme-ip-lookup.com/csv/"
    
    FinHTTP.Open "GET", url, False
    FinHTTP.send
    
    FinCloudIn = Split(FinHTTP.responseText, ",")
    ReDim outArr(UBound(FinCloudIn) - 1)
    
    For j = 0 To UBound(FinCloudIn) - 1
         outArr(j) = FinCloudIn(j)
    Next j
    
    cidLoc = VBA.Replace(outArr(10), """", "") & "," & _
                        outArr(7)

    url = "http://api.openweathermap.org/data/2.5/weather?apikey=4a2360d14bf33378079d2e2d49e35ddb&mode=xml&units=metric&q=" & _
                                                                                                              cidLoc
                                                                
        xmlhttp.Open "GET", url, False
        xmlhttp.send
        xmlresponse.LoadXML (xmlhttp.responseText)
        
                FinCloudIn = VBA.Split(sCloudIn, ",")
                FinCloudOut = VBA.Split(sCloudOut, ",")
                  
                For j = 0 To UBound(FinCloudIn)
                    If FinCloudIn(j) = xmlresponse.SelectNodes("//current/clouds/@name")(0).Text Then
                        x = j
                        Exit For
                   End If
                Next j
     
         ' DELETA o icone do Tempo:
        For Each shp In .Shapes
            If shp.Name = "Icone_Tempo" Then
                shp.Delete
            End If
         Next
               
      .[A2:C8].ClearContents
On Error Resume Next
    .[A2] = xmlresponse.SelectNodes("//current/city/@name")(0).Text
    .[B2] = "Temperatura:": .[B3] = "Minima:": .[B4] = "Maxima: ": .[B5] = "Umidade: "
    .[B6] = "Céu:": .[B7] = "Vento:": .[B8] = "Última Atualização"
    .[C2] = Excel.Application.WorksheetFunction.RoundDown(VBA.Val(xmlresponse.SelectNodes("//current/temperature/@value")(0).Text), 0) & VBA.Chr(176) & _
            VBA.UCase(VBA.Left(xmlresponse.SelectNodes("//current/temperature/@unit")(0).Text, 1))
    .[C3] = Excel.Application.WorksheetFunction.RoundDown(VBA.Val(xmlresponse.SelectNodes("//current/temperature/@min")(0).Text), 0) & VBA.Chr(176) & _
            VBA.UCase(VBA.Left(xmlresponse.SelectNodes("//current/temperature/@unit")(0).Text, 1))
    .[C4] = Excel.Application.WorksheetFunction.RoundDown(VBA.Val(xmlresponse.SelectNodes("//current/temperature/@max")(0).Text), 0) & VBA.Chr(176) & _
            VBA.UCase(VBA.Left(xmlresponse.SelectNodes("//current/temperature/@unit")(0).Text, 1))
    .[C5] = xmlresponse.SelectNodes("//current/humidity/@value")(0).Text & xmlresponse.SelectNodes("//current/humidity/@unit")(0).Text
    .[C6] = FinCloudOut(x)
    .[C7] = Excel.Application.WorksheetFunction.RoundDown(VBA.Val(xmlresponse.SelectNodes("//wind/speed/@value")(0).Text) / 1000 * 3600, 0) & " Km/h"
    .[C8] = VBA.Replace(xmlresponse.SelectNodes("//current/lastupdate/@value")(0).Text, "T", " ")
    .[C8] = .[C8] - VBA.TimeSerial(3, 0, 0)
    
            x = VBA.IIf(FinCloudOut(x) = "Nublado", 3, x)
            
      'Insere o icone do Tempo:
     Set mPicture = .Pictures.Insert("https://openweathermap.org/img/wn/0" & x + 1 & "[email protected]")
                                      
            With mPicture
                .Name = "Icone_Tempo"
                .ShapeRange.LockAspectRatio = False
                .Width = ws.[D3].Width
                .Height = ws.[D3].Width
                .Top = Rows(ws.[D3].Row).Top
                .Left = Columns(ws.[D3].Column).Left
            End With
   
On Error GoTo 0

End With

End Sub

Francyne · 5 de dezembro de 2019

@Basole Poderia me ajudar?

o código criado esta trazendo localização de Salvador, porém estou em Campinas.

No meu pc não tem como ativar a localização, poderia me ajudar alterar o código para localização fixa de Campinas?

Luan Teles · 5 de dezembro de 2019

@Basole O link do icone do tempo mudou agora é

https://openweathermap.org/img/wn/[email protected]

porém ele so fala das nuvens, mesmo se estiver chivendo vai falar ceu limpo e etc para tempo é

current/weather/@value

e teria como fazer ele ler a variação do icone nesse caso? pois não é fixo o link como nos das nuvens

olhe o exemplo do codigo atual, ele tem o icon"xxxx" que substitui uma unica parte do link.

nuvens https://openweathermap.org/img/wn/[email protected]

Por exemplo chuva fraca https://openweathermap.org/img/wn/[email protected] e etc

nesse caso ele teria que pegar esse icon"xxx" e colocar antes do @ pra trocar

<current>
<city id="3449344" name="Sao Bernardo do Campo">
<coord lon="-46.56" lat="-23.69"/>
<country>BR</country>
<timezone>-10800</timezone>
<sun rise="2019-12-05T08:11:22" set="2019-12-05T21:42:29"/>
</city>
<temperature value="27.24" min="25" max="29" unit="celsius"/>
<humidity value="61" unit="%"/>
<pressure value="1011" unit="hPa"/>
<wind>
<speed value="6.2" unit="m/s" name="Moderate breeze"/>
<gusts/>
<direction value="300" code="WNW" name="West-northwest"/>
</wind>
<clouds value="75" name="broken clouds"/>
<visibility value="9000"/>
<precipitation mode="no"/>
<weather number="500" value="light rain" icon="10d"/>
<lastupdate value="2019-12-05T18:59:20"/>
</current>

Basole · 5 de dezembro de 2019

@Francyne deve estar derretendo ai em campinas com 28 graus neste momento

Nao sei o que pode estar ocorrendo, pois pra mim e para o @Luan Teles a geo-localizacao,está funcionando certinho.

Bom, mas eu fiz uma alteracao no codigo e agora como alternativa, a macro pergunta em qual cidade se encontra

Para isso deixa a celula A2 em branco (vazia).

Para a macro buscar a respectiva localizacao automaticamente, clck no botao cancelar na janela que solicita a cidade.

@Luan Teles nao detectei nenhuma alteracao na UR da imagem (icone), o que acontece e que só tem disponivel,, pelo que percebi 4 imagens diferentes: openweathermap.org/img/wn/01[email protected] entao quando esta como "overcast clouds" aparece o mesmo icone de "broken clouds"

Eu fiz algumas alteracoes pois percebi que estava inconsitentes e pelos testes que fiz agora esta atualizando tudo ok.

.

Previsao Tempo_V2.zip

Luan Teles · 6 de dezembro de 2019

@Basole

assim fica melhor

Pois usando o /wind não mostra chuvas, e quando estiver chovendo ficaria com icone de chuva e texto de Céu encoberto igual estava aqui

        Select Case xmlresponse.SelectNodes("//current/weather/@value")(0).Text
             
             Case "heavy rain"
                 FinCloudOut = "Chuva Forte"
                 
             Case "light rain"
                 FinCloudOut = "Chuva Fraca"
            
             Case "clear sky"
                 FinCloudOut = "Céu Limpo"
                
             Case "few clouds"
                 FinCloudOut = "Poucas Nuves"
                
             Case "scattered clouds"
                 FinCloudOut = "Nuvens Dispersas"
               
             Case "broken clouds"
                 FinCloudOut = "Céu Encoberto"
                 
            Case "overcast clouds"
                 FinCloudOut = "Nublado"
             
             Case Else
                 FinCloudOut = "Só Jesus na Causa"
        End Select

Luan Teles · 9 de dezembro de 2019

@Basole

como trocar o provedor de localização para https://ipinfo.io/json esse informa com Acentos os nomes da cidade, como São Paulo, e o Open Weather suporta sim localizações com Acento.

E como fazer por exemplo

quando o id da imagem for tal por exemplo 03d ele aplicar um filtro na imagem acho ideal o temperatura 4700k

pois algumas imagens como nuvens são totalmente brancas, que não da pra ver na planilha

Basole · 9 de dezembro de 2019

@Luan Teles

Em 06/12/2019 às 16:41, Luan Teles disse:

assim fica melhor

Pois usando o /wind não mostra chuvas, e quando estiver chovendo ficaria com icone de chuva e texto de Céu encoberto igual estava aqui

Sim ficou bem melhor agora, ainda mais quando tiver... "Só Jesus na Causa"

Já incluir nas alteracoes.!!!

não tinha me observado. que a api aceitava acentos. valeu

Alterei para o provedor de localização, que você indicou

Quanto a imagem( icone ), no ambiente Excel, vb, vba nao da pra fazer como no ambiente html ajustar a "temperatura".

Mas tem algumas opções de efeito na forma (shape), entao eu acrescentei brilhos ao redor da imagem que acaba realcando, veja os resultados:

...

Codigo Atualizado:

Spoiler

Sub Obtendo_a_Previsao_c_Localizacao()
Dim xmlhttp As Object
Dim url As String
Dim xmlresponse As Object
Dim FinHTTP As Object
Dim cidLoc As String
Dim FinCloudOut As String
Dim mPicture As Object
Dim ws As Worksheet
Dim shp As Shape
Dim icon As String
Dim dados
Dim result
Dim i As Long
Dim j As Integer
Dim icoTemp As Long

Excel.Application.ScreenUpdating = False

Set FinHTTP = CreateObject("MSXML2.XMLHTTP")
Set xmlhttp = VBA.CreateObject("MSXML2.serverXMLHTTP") '
Set xmlresponse = VBA.CreateObject("MSXML2.DOMDocument.6.0")

Set ws = ThisWorkbook.Sheets(1) ' PLan 1
With ws

If .Range("A2") = Empty Then
cidLoc = InputBox("Cidade, sigla BR, *Sem acentos*: " & VBA.Chr(10) & "Exemplo: sao paulo,br", _
"Informe sua cidade e sigla do pais")
Else

cidLoc = .Range("A2")

End If

If cidLoc = Empty Then

FinHTTP.Open "GET", "http://ipinfo.io/json", False
FinHTTP.Send

result = Array()

dados = Split(FinHTTP.ResponseText, vbLf)

ReDim result(1 To UBound(dados) - 1, 1 To 2)

For i = 1 To UBound(dados) - 1
dados(i) = VBA.Trim$(dados(i))
j = VBA.InStr(dados(i), ":")
result(i, 1) = VBA.Trim$(VBA.Left$(dados(i), j - 1))
result(i, 2) = VBA.Trim$(VBA.Mid$(dados(i), j + 1))
Next
For i = 1 To UBound(result)
For j = 1 To 2
If VBA.Right$(result(i, j), 2) = """," Then
result(i, j) = VBA.Mid$(result(i, j), 2, VBA.Len(result(i, j)) - 3)
Else
result(i, j) = VBA.Mid$(result(i, j), 2, VBA.Len(result(i, j)) - 2)
End If
Next
Next

cidLoc = result(3, 2) & "," & result(5, 2)

End If

url = "http://api.openweathermap.org/data/2.5/weather?apikey=77d52dacd376716e1c74a5e83e31ddc6&mode=xml&units=metric&q=" & _
cidLoc
On Error GoTo trata_erro

xmlhttp.Open "GET", url, False
xmlhttp.Send
xmlresponse.LoadXML (xmlhttp.ResponseText)
icon = xmlresponse.SelectNodes("//current/weather/@icon")(0).Text

Select Case xmlresponse.SelectNodes("//current/weather/@value")(0).Text

Case "thunderstorm" ' * NOVO *
FinCloudOut = "Trovoada"
icoTemp = 1
Case "heavy rain"
FinCloudOut = "Chuva Forte"
icoTemp = 1
Case "light rain"
FinCloudOut = "Chuva Fraca"
icoTemp = 3
Case "clear sky"
FinCloudOut = "Céu Limpo"
'caso estiver anoitecido:
If VBA.InStr(icon, "d") > 0 Then
icoTemp = 8
Else
icoTemp = 14
End If
Case "few clouds"
FinCloudOut = "Poucas Nuves"
icoTemp = 9
Case "scattered clouds"
FinCloudOut = "Nuvens Dispersas"
icoTemp = 9
Case "broken clouds"
FinCloudOut = "Céu Encoberto"
icoTemp = 7
Case "overcast clouds"
FinCloudOut = "Nublado"
icoTemp = 7
Case Else
FinCloudOut = "Só Jesus na Causa"
icoTemp = 0
End Select

' DELETA o icone do Tempo:
For Each shp In .Shapes
If shp.Name = "Icone_Tempo" Then
shp.Delete
End If
Next

.[A2:C8].ClearContents
On Error Resume Next
.[A2] = cidLoc
.[B2] = "Temperatura:": .[B3] = "Minima:": .[B4] = "Maxima: ": .[B5] = "Umidade: "
.[B6] = "Céu:": .[B7] = "Vento:": .[B8] = "Última Atualização"
.[C2] = Excel.Application.WorksheetFunction.RoundDown(VBA.Val(xmlresponse.SelectNodes("//current/temperature/@value")(0).Text), 0) & VBA.Chr(176) & _
VBA.UCase(VBA.Left(xmlresponse.SelectNodes("//current/temperature/@unit")(0).Text, 1))
.[C3] = Excel.Application.WorksheetFunction.RoundDown(VBA.Val(xmlresponse.SelectNodes("//current/temperature/@min")(0).Text), 0) & VBA.Chr(176) & _
VBA.UCase(VBA.Left(xmlresponse.SelectNodes("//current/temperature/@unit")(0).Text, 1))
.[C4] = Excel.Application.WorksheetFunction.RoundDown(VBA.Val(xmlresponse.SelectNodes("//current/temperature/@max")(0).Text), 0) & VBA.Chr(176) & _
VBA.UCase(VBA.Left(xmlresponse.SelectNodes("//current/temperature/@unit")(0).Text, 1))
.[C5] = xmlresponse.SelectNodes("//current/humidity/@value")(0).Text & xmlresponse.SelectNodes("//current/humidity/@unit")(0).Text
.[C6] = FinCloudOut '(x)
.[C7] = Excel.Application.WorksheetFunction.RoundDown(VBA.Val(xmlresponse.SelectNodes("//wind/speed/@value")(0).Text) / 1000 * 3600, 0) & " Km/h"
.[c8] = VBA.Replace(xmlresponse.SelectNodes("//current/lastupdate/@value")(0).Text, "T", " ")
.[c8] = .[c8] - VBA.TimeSerial(3, 0, 0)

'Insere o icone do Tempo:
Set mPicture = .Pictures.Insert("https://openweathermap.org/img/wn/" & icon & "@2x.png")

With mPicture
.Name = "Icone_Tempo"
.ShapeRange.LockAspectRatio = False
.Width = ws.[D3].Width
.Height = ws.[D3].Width
.Top = Rows(ws.[D3].Row).Top
.Left = Columns(ws.[D3].Column).Left
With .ShapeRange.Glow
.Color.ObjectThemeColor = icoTemp
.Color.TintAndShade = 0
.Color.Brightness = 0
.Transparency = 0.6000000238
.Radius = 18
End With
End With

On Error GoTo 0

End With

Excel.Application.ScreenUpdating = True

Exit Sub

trata_erro:

Excel.Application.ScreenUpdating = True

MsgBox "Verifique o nome da sua cidade ou se esta sem conexao com a internet e tente novamente!", 64, "Aviso!!!"

End Sub

Luan Teles · 10 de dezembro de 2019

@Basole Otimo

Só estou tendo problemas para copiar seu código( APENAS NOVA API) no meu, eu ainda estou usando sem caixa de dialogo e com valor automatico, tentei adaptar para o modo antigo mas esta dando erro e como não sei nada de vba só o que observei nos seus codigos, to apanhando, to anexando minha planilha para dar uma olhada

Controle Planilhas - Luan.rar

adicionado 50 minutos depois

@Basole Eu coloquei para atualizar a cada 15 minutos, porém uma coisa que eu notei é se ele se atualiza enquanto eu estiver em outra aba da planilha o icone do tempo vai parar no lugar errado da primeira planilha, não onde defini.

Se ele se atualiza na primeira planilha ele fica no lugar certo

Basole · 10 de dezembro de 2019

3 horas atrás, Luan Teles disse:

Só estou tendo problemas para copiar seu código( APENAS NOVA API) no meu, eu ainda estou usando sem caixa de dialogo e com valor automatico, tentei adaptar para o modo antigo mas esta dando erro e como não sei nada de vba só o que observei nos seus codigos, to apanhando, to anexando minha planilha para dar uma olhada

@Luan Teles fiz as adaptacões no código conforme seu arquivo, veja se é isso..

No arredondamento da temperatura alterei para para cima, anteriormente estava para baixo.

Spoiler

Sub PrevisaoClima()
Dim xmlhttp As Object
Dim url As String
Dim xmlresponse As Object
Dim FinHTTP As Object
Dim cidLoc As String
Dim FinCloudOut As String
Dim FinWindOut As String
Dim outArr() As String
Dim j As Integer
Dim mPicture As Object
Dim ws As Worksheet
Dim shp As Shape
Dim icon As String
Dim dados
Dim result
Dim i As Long
Dim icoTemp As Long

Set FinHTTP = VBA.CreateObject("Microsoft.xmlHTTP")
Set xmlhttp = VBA.CreateObject("MSXML2.serverXMLHTTP") '
Set xmlresponse = VBA.CreateObject("MSXML2.DOMDocument.6.0")

On Error GoTo trata_erro

Set ws = ThisWorkbook.Sheets("Resumo Geral")

With ws

url = "http://ipinfo.io/json"

FinHTTP.Open "GET", url, False
FinHTTP.send

result = Array()

dados = Split(FinHTTP.ResponseText, vbLf)

ReDim result(1 To UBound(dados) - 1, 1 To 2)

For i = 1 To UBound(dados) - 1
dados(i) = VBA.Trim$(dados(i))
j = VBA.InStr(dados(i), ":")
result(i, 1) = VBA.Trim$(VBA.Left$(dados(i), j - 1))
result(i, 2) = VBA.Trim$(VBA.Mid$(dados(i), j + 1))
Next

For i = 1 To UBound(result)
For j = 1 To 2
If VBA.Right$(result(i, j), 2) = """," Then
result(i, j) = VBA.Mid$(result(i, j), 2, VBA.Len(result(i, j)) - 3)
Else
result(i, j) = VBA.Mid$(result(i, j), 2, VBA.Len(result(i, j)) - 2)
End If
Next
Next

For i = LBound(result) To UBound(result)
If result(i, 1) = "city" Then cidLoc = result(i, 2) & ","
If result(i, 1) = "country" Then cidLoc = cidLoc & result(i, 2)
Next

url = "http://api.openweathermap.org/data/2.5/weather?apikey=4a2360d14bf33378079d2e2d49e35ddb&mode=xml&units=metric&q=" & _
cidLoc
xmlhttp.Open "GET", url, False
xmlhttp.send
xmlresponse.LoadXML (xmlhttp.ResponseText)

icon = xmlresponse.SelectNodes("//current/weather/@icon")(0).Text

Select Case xmlresponse.SelectNodes("//current/weather/@value")(0).Text

Case "heavy intensity rain"
FinCloudOut = "Chuva Forte"
icoTemp = 1

Case "moderate rain"
FinCloudOut = "Chuva Moderada"
icoTemp = 1

Case "light rain"
FinCloudOut = "Chuva Fraca"
icoTemp = 3

Case "light intensity drizzle"
FinCloudOut = "Garoa"
icoTemp = 1

Case "clear sky"
FinCloudOut = "Céu Limpo"
'caso estiver anoitecido:
If VBA.InStr(icon, "d") > 0 Then
icoTemp = 8
Else
icoTemp = 14
End If

Case "few clouds"
FinCloudOut = "Poucas Nuves"
icoTemp = 9

Case "scattered clouds"
FinCloudOut = "Nuvens Dispersas"
icoTemp = 9

Case "broken clouds"
FinCloudOut = "Céu Encoberto"
icoTemp = 7

Case "overcast clouds"
FinCloudOut = "Nublado"
icoTemp = 7

Case "fog"
FinCloudOut = "Neblina"
icoTemp = 7
Case "mist"
FinCloudOut = "Névoa"
icoTemp = 7
Case "shower rain"
FinCloudOut = "Pancadas de Chuva"
icoTemp = 3
Case "snow"
FinCloudOut = "Neve"
icoTemp = 7
Case "thunderstorm"
FinCloudOut = "Tempestade"
icoTemp = 1
Case Else
FinCloudOut = "Só Jesus na Causa"
icoTemp = 0
End Select

Select Case xmlresponse.SelectNodes("current/wind/speed/@name")(0).Text

Case "Gentle Breeze"
FinWindOut = "Brisa Suave"

Case "Light breeze"
FinWindOut = "Brisa Leve"

Case "Calm"
FinWindOut = "Calmo"

Case "Fresh Breeze"
FinWindOut = "Brisa Fresca"

Case "High wind, near gale"
FinWindOut = "Vendaval"

Case "Moderate breeze"
FinWindOut = "Brisa Moderada"

Case "Strong breeze"
FinWindOut = "Brisa Forte"

'03d escurecer imagem
Case Else
FinWindOut = "Corram para as Colinas"
End Select

' DELETA o icone do Tempo:
For Each shp In .Shapes
If shp.Name = "Icone_Tempo" Then
shp.Delete
End If
Next

On Error Resume Next
.[M2] = xmlresponse.SelectNodes("//current/city/@name")(0).Text
'.[B2] = "Temperatura:": .[B3] = "Minima:": .[B4] = "Maxima: ": .[B5] = "Umidade: "
'.[B6] = "Céu:": .[B7] = "Vento:": .[B8] = "Última Atualização"
.[N6] = Excel.Application.WorksheetFunction.RoundUp(VBA.Val(xmlresponse.SelectNodes("//current/temperature/@value")(0).Text), 0) & VBA.Chr(176) & _
VBA.UCase(VBA.Left(xmlresponse.SelectNodes("//current/temperature/@unit")(0).Text, 1))
'.[C3] = Excel.Application.WorksheetFunction.RoundDown(VBA.Val(xmlresponse.SelectNodes("//current/temperature/@min")(0).Text), 0) & VBA.Chr(176) & _
VBA.UCase(VBA.Left(xmlresponse.SelectNodes("//current/temperature/@unit")(0).Text, 1))
' .[C4] = Excel.Application.WorksheetFunction.RoundDown(VBA.Val(xmlresponse.SelectNodes("//current/temperature/@max")(0).Text), 0) & VBA.Chr(176) & _
VBA.UCase(VBA.Left(xmlresponse.SelectNodes("//current/temperature/@unit")(0).Text, 1))
'.[N3] = "Umidade: " & xmlresponse.SelectNodes("//current/humidity/@value")(0).Text & xmlresponse.SelectNodes("//current/humidity/@unit")(0).Text
.[N3] = "Vento: " & FinWindOut

.[N4] = "Clima: " & FinCloudOut '(x)
' .[C7] = Excel.Application.WorksheetFunction.RoundDown(VBA.Val(xmlresponse.SelectNodes("//wind/speed/@value")(0).Text) / 1000 * 3600, 0) & " Km/h"
'.[C8] = VBA.Replace(xmlresponse.SelectNodes("//current/lastupdate/@value")(0).Text, "T", " ")
'.[C8] = .[C8] - VBA.TimeSerial(3, 0, 0)

'Insere o icone do Tempo:
Set mPicture = .Pictures.Insert("https://openweathermap.org/img/wn/" & icon & "@2x.png")

With mPicture
.Name = "Icone_Tempo"
.ShapeRange.LockAspectRatio = False
.Width = ws.[Q2:P2].Width
.Height = ws.[P1:Q8].Height
.Top = Rows(ws.[O1].Row).Top
.Left = Columns(ws.[P2].Column).Left
With .ShapeRange.Glow
.Color.ObjectThemeColor = icoTemp
.Color.TintAndShade = 0
.Color.Brightness = 0
.Transparency = 0.6000000238
.Radius = 18
End With
End With
Calculate
Application.OnTime Now + TimeValue("00:15:00"), "PrevisaoClima", , True
End With

Exit Sub

trata_erro:

MsgBox Err.Number & " " & Err.Description & VBA.vbNewLine & _
"Verifique o nome da sua cidade ou se esta sem conexao com a internet e tente novamente!", 64, "Aviso!!!"

End Sub

3 horas atrás, Luan Teles disse:

Eu coloquei para atualizar a cada 15 minutos, porém uma coisa que eu notei é se ele se atualiza enquanto eu estiver em outra aba da planilha o icone do tempo vai parar no lugar errado da primeira planilha, não onde defini.

Se ele se atualiza na primeira planilha ele fica no lugar certo

No Excel tem dessas coisas ! E nem Bill Gates explica

Bom mas eu contornei essa inconsistência, colocando uma rotina para posicionar corretamente de forma automática:

* No modulo da sua aba "Resumo Geral"`, cole o código abaixo.

E ai quando você ativar essa aba novamente, a macro vai corrigir esse problema.

Private Sub Worksheet_Activate()
  On Error Resume Next
    With ActiveSheet.Shapes("Icone_Tempo")
        
         .Width = [Q2:P2].Width
         .Height = [P1:Q8].Height
         .Top = Rows([O1].Row).Top
         .Left = Columns([P2].Column).Left
       
    End With
  On Error GoTo 0
End Sub

.

Luan Teles · 10 de dezembro de 2019

Muito obrigado esta sensacional

Pedro Lucas O Duarte · 11 de dezembro de 2019

@Basole você tem algum contato? Queria algum trabalho com Excel, não sei se presta serviço, mas ajudou muita gente. Estou com alguns problemas tmabém, se puder me chamar no whatsapp +34 600 37 6655 valeu

Luan Teles · 17 de janeiro de 2020

@Basole A formula parou de retornar o local com acento, porém no codigo vba, o servidor mostra o acento O.O

Basole · 18 de janeiro de 2020

@Luan Teles desculpe, mas não entendi.

No seu arquivo(exemplo) , não vi formula e está funcionando perfeitamente!

Luan Teles · 31 de janeiro de 2020

@Basole Lembra que você trocou o provedor de localização para mostrar o acento nas cidades? então, o codigo parou de retornar a cidade com acento, porém quando eu coloco o codigo do provedor no navegador ele me retorna com acento

Planilha.rar

Basole · 6 de fevereiro de 2020

@Luan Teles altere a linha abaixo no código:

 .[M2] = xmlresponse.SelectNodes("//current/city/@name")(0).Text

...por esta:

.[M2] = cidLoc

..ou se preferir sem o BR:

 .[M2] = VBA.Left(cidLoc, VBA.InStr(cidLoc, ",") - 1)

Entrar

PowerPoint previsão do tempo - dentro powerpoint

Posts recomendados

Link para o comentário

Compartilhar em outros sites

Link para o comentário

Compartilhar em outros sites

Link para o comentário

Compartilhar em outros sites

Link para o comentário

Compartilhar em outros sites

Link para o comentário

Compartilhar em outros sites

Link para o comentário

Compartilhar em outros sites

Link para o comentário

Compartilhar em outros sites

Link para o comentário

Compartilhar em outros sites

Link para o comentário

Compartilhar em outros sites

Link para o comentário

Compartilhar em outros sites

Link para o comentário

Compartilhar em outros sites

Link para o comentário

Compartilhar em outros sites

Link para o comentário

Compartilhar em outros sites

Link para o comentário

Compartilhar em outros sites

Link para o comentário

Compartilhar em outros sites

Link para o comentário

Compartilhar em outros sites

Link para o comentário

Compartilhar em outros sites

Link para o comentário

Compartilhar em outros sites

Link para o comentário

Compartilhar em outros sites

Link para o comentário

Compartilhar em outros sites

Link para o comentário

Compartilhar em outros sites

Crie uma conta ou entre para comentar

Criar uma conta

Entrar

Quem está navegando aqui 0 usuários estão online

Últimos tópicos

Livros

Cursos

Conteúdo recente

Sobre o Clube do Hardware

Direitos autorais

Mais