Este fórum está sendo desativado

[Dalila1234]

Boa noite !!!
preciso de ajuda...
tenho uma planilha dada de uma backup de um software de uma empresa que fornece serviços para imobiliária, este backup veio todo em planilha com varias abas no Excel... tenho que baixar as fotos em pastas individuais para cada imóvel, e dentro da pasta criar um arquivo com os dados do imóvel... como faço isso?

na aba imoveis tem os dados dos imóveis e na aba imoveis_fotos tem as urls das fotos.

obrigada !!

[laennder]

Criei a rotina abaixo para fazer o que deseja.

Código: Selecionar todos

#If VBA7 Then
    Public Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As LongPtr _
      , ByVal szURL As String _
      , ByVal szFileName As String _
      , ByVal dwReserved As LongPtr _
    , ByVal lpfnCB As LongPtr) As Long
#Else
    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
#End If


'Primeira macro a ser executada
Sub CriarPastas()

Dim fso As Object
Dim path As String

    Set fso = CreateObject("Scripting.FileSystemObject")
    
    'cria a pasta imoveis junto desta planilha
    path = ThisWorkbook.path & Application.PathSeparator & "imoveis"
    
    If Not fso.FolderExists(path) Then
        fso.CreateFolder (path)
    End If
    
    'cria uma sub pasta para cada imovel na pasta imoveis
    For i = 2 To 21 'numero de imoveis
    
    path = ThisWorkbook.path & Application.PathSeparator & "imoveis" & Application.PathSeparator & ThisWorkbook.Worksheets("imoveis").Cells(i, 1)
    If Not fso.FolderExists(path) Then
    fso.CreateFolder (path)
    End If

    Next

End Sub

'cria arquivo com dados do imóvel na pasta criada anteriormente
Sub CriarArquivos()
 
    'variáveis
    Dim newBook As Workbook
    Dim sheet As Worksheet
    Dim i As Long
 
    'Desativa os avisos e atualiação da tela
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    For i = 2 To 21  'numero de imoveis
        'cria uma nova pasta de trabalho:
        Set newBook = Application.Workbooks.Add
        'cria a planilha
        Set sheet = newBook.Worksheets.Add
        sheet.Name = "Dados do Imóvel"
        
        'salva os dados
        
        For j = 1 To 7 'numero de colunas com os dados do imóvel
            sheet.Cells(j, 1) = Plan8.Cells(1, j)
            sheet.Cells(j, 2) = Plan8.Cells(i, j)
        
        Next j
        
        'remove as outras planilhas
        For k = 2 To newBook.Worksheets.Count
            newBook.Worksheets(2).Delete
        Next k
        
        'salva o arquivo
        newBook.SaveAs ThisWorkbook.path & Application.PathSeparator & "imoveis" & Application.PathSeparator & ThisWorkbook.Worksheets("imoveis").Cells(i, 1) & Application.PathSeparator & "Dados do Imóvel.xlsx"
        newBook.Close
    
    Next
 
End Sub

Sub BaixarFotos()

    'Declaração de variáveis
    Dim sURL As String
    Dim sDestino As String
    Dim blSucesso As Boolean
    
    For i = 2 To 203 ' número de fotos
    
    'url e destino
    sURL = ThisWorkbook.Worksheets("imoveis_fotos").Cells(i, 3)
    sDestino = ThisWorkbook.path & Application.PathSeparator & "imoveis" & Application.PathSeparator & _
               ThisWorkbook.Worksheets("imoveis_fotos").Cells(i, 2) & Application.PathSeparator & ThisWorkbook.Worksheets("imoveis_fotos").Cells(i, 1) & ".jpg"
    
    'baixa o arquivo da internet
    blSucesso = DownloadArquivo(sURL, sDestino)
    ThisWorkbook.Worksheets("imoveis_fotos").Cells(i, 4) = blSucesso
    
    Next i
End Sub

'função de apoio
Private Function DownloadArquivo(sURL As String, sDestino As String) As Boolean
    Dim l As Long
    l = URLDownloadToFile(0, sURL, sDestino, 0, 0)
    If l = 0 Then DownloadArquivo = True
End Function

Sub executa_tudo()

Call CriarPastas
Call CriarArquivos
Call BaixarFotos

MsgBox "Pronto! Foi criada uma pasta chamada imoveis no mesmo local deste arquivo"

End Sub

Referências:
http://www.ambienteoffice.com.br/office ... _arquivos/