Este fórum está sendo desativado

[eduardobatistaadm]

Bom dia!

Estou com dificuldade numa macro de importação de imagens de uma pasta e para o Excel.

Estou com a seguintes dificuldades:

1) A primeira imagem "setada" na célula B2 não está redimensionando corretamente .Placement = 1 e deveria ser 2.

2) Ao fazer o Loop ele não esta buscando a próxima imagem da pasta.

3) As imagens devem ser posicionadas no Excel na seguinte ordem (Sequencia): B2 > D2 > B5 > D5 > B8 > D8 > B11 > D11.

4) Entrando em Loop Infinito.

Segue abaixo o código.

Código: Selecionar todos

Public Caminho As String
Public Quantidade As Long
Public fso As Object 'Scripting.FileSystemObject
Public fsoFolder As Object 'Scripting.Folder

Sub SelecionarPasta()
    
    With Application.FileDialog(msoFileDialogFolderPicker)

    .Show
        
        If .SelectedItems.Count > 0 Then
        Caminho = .SelectedItems(1)
        
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set fsoFolder = fso.GetFolder(Caminho) 'csDirectory
        Quantidade = fsoFolder.Files.Count
        
        End If

        'MsgBox "O diretório " & Caminho & " possui " & fsoFolder.Files.Count & " imagens.", vbInformation
        
    End With

    Worksheets("Fotos").Range("F1").Value = Caminho + "\"
    Worksheets("Fotos").Range("G1").Value = Quantidade
    
    ImportarFotos
    
    'MsgBox "Pasta selecionada! " & Caminho, vbInformation, "PASTA"
    
End Sub

Sub ImportarFotos()

Dim NomeDoArquivo As String
Dim Imagem As Picture
Dim rngCell As Range
Dim i As Integer
Dim e As Integer

Caminho = Worksheets("Fotos").Range("F1").Value
Quantidade = Worksheets("Fotos").Range("G1").Value

    Set rngCell = Range("B2")    'A primeira imagem "setada" na celula B2 não está redimensionando.
            
    NomeDoArquivo = Dir(Caminho & "*.jpg", vbNormal)    'Ao fazer o Loop ele não esta buscando a próxima imagem da pasta.
    
    Do While Len(Quantidade) > 0    'Limitar a 8 imagens ou ao valor da variavel Quantidade, o que for menor.
    
        If (i <= Quantidade) Then
        
         Set Imagem = Worksheets("Fotos").Pictures.Insert(Caminho & NomeDoArquivo)
           With Imagem
                .Left = rngCell.Left
                .Top = rngCell.Top          'As imagens não estão sendo redimensionadas.
                .Height = rngCell.Height
                .Placement = xlMoveAndSize
             End With
            
            Set rngCell = rngCell.Offset(3, 0)    'a ordem de preenchimento deve ser por linha. Sequencia B2 > D2 > B5 > D5 > B8 > D8 > B11 > D11.
            i = i + 1
        Else
            Set rngCell = rngCell.Offset(1, 0)
            i = 0
        End If
        
    Loop    'Entrando em Loop Infinito. Antes de executar, marcar ponto de interrupção.
    
    MsgBox "Imagens copiadas com sucesso!", vbInformation, "IMPORTAÇÃO"
    
End Sub

Grato!
Eduardo

[CursoDeExcelGratis]

boa tarde Eduardo, ainda está com problema com a macro ?

[eduardobatistaadm]

Boa tarde! Sim ainda estou. Não consegui solucionar o problema!

[CursoDeExcelGratis]

bom dia Eduardo, peço desculpas, não tinha visto sua resposta !
vamos la, o que falta para passar para a próxima foto é vc chamar novamente o DIR ()
eu mudei um pouco sua lógica, para fazer um looping enquanto não achava foto
ainda, fiz um tratamento para saber se tinha que dimensionar pela altura ou largura, so mexi mesmo na função importar fotos :

Código: Selecionar todos

Sub ImportarFotos()

Dim NomeDoArquivo As String
Dim Imagem As Picture
Dim rngCell As Range

Caminho = Worksheets("Fotos").Range("F1").Value
'Quantidade = Worksheets("Fotos").Range("G1").Value

'    Set rngCell = Range("B2") 'A primeira imagem "setada" na celula B2 não está redimensionando.
            
    NomeDoArquivo = Dir(Caminho & "*.png", vbNormal) 'Ao fazer o Loop ele não esta buscando a próxima imagem da pasta.
'    Do While Len(Quantidade) > 0 'Limitar a 8 imagens ou ao valor da variavel Quantidade, o que for menor.
    
    'curso de excel gratis, faz o looping enquanto encontra arquivo
    Dim cont As Integer
    
    Dim linha As Integer
    Dim coluna As Integer
    
    linha = 2
    coluna = 2
    cont = 1
    Do While NomeDoArquivo <> ""
    
        Set rngCell = Cells(linha, coluna)
        
       
         Set Imagem = Worksheets("Fotos").Pictures.Insert(Caminho & NomeDoArquivo)
         With Imagem
                .Left = rngCell.Left
                .Top = rngCell.Top          'As imagens não estão sendo redimensionadas.
                .Height = rngCell.Height
                .Width = rngCell.Width  'curso de excel gratis,
                'inclui isto aqui, mas na realidade teria que ter um esquema de saber se tem que ajustar a altura ou a largura
                'pode ser algo simples assim :
                If .Height > rngCell.Height Then
                    .Height = rngCell.Height
                End If
                .Placement = xlMoveAndSize
        End With
        'verifica a proxima linha
        cont = cont + 1
        If cont Mod 2 = 0 Then
            'a proxima vai ser na mesma linha porem na coluna D
            coluna = 4
        Else
            'volta para a primeira coluna e soma a linha
            coluna = 2
            linha = linha + 3
        End If
    
        'curso de excel gratis
        NomeDoArquivo = Dir() 'pega o proximo arquivo
        
    Loop 'Entrando em Loop Infinito. Antes de executar, marcar ponto de interrupção.
    
    MsgBox "Imagens copiadas com sucesso!", vbInformation, "IMPORTAÇÃO"
    
End Sub

Qualquer dúvida pode enviar