Excel MACRO VBA para pesquisar imagem de uma pasta.

[Rangel Salomé]

Boa tarde, gostaria de verificar com vocês, se e possível criar um MACRO que faça uma consulta de imagens de uma pasta em rede (Z:\SGQ\1. Banco de Dados\Imagens) e já direccionar para uma planilha que tenho de consulta de imagem. Porém toda vez que uma nova consulta for feita ele deve substituir a foto anterior para que o usuário não confunda os objectos. E que a foto sempre abra ocupando todo o vão da célula mesclada. 

[Midori]

@Rangel Salomé Com Shape é só passar o caminho da imagem para o procedimento UserPicture, p.ex,

 

Dim Imagem  As Shape
    
Set Imagem = ActiveSheet.Shapes("Imagem")
    
Call Imagem.Fill.UserPicture("C:\Foto\" & [B3].Value & ".png")

 

Assim a imagem sempre será substituída.

[Rangel Salomé]

@Midori Oi Midori tudo bem? eu sou leigo no assunto de VBA. Hoje uso uma formula obtida da internet para essa funcionabilidade. Com esse trecho que você me encaminhou, eu devo substituir onde nessa macro? Além disso e possível fazer com que a macro puxe automaticamente a foto do produto, sem que o usuario precise apertar o campo de pesquisar? obrigado. 
 

Citação

Sub Teste()

'Definir intervalo onde estão os códigos das imagens
    Dim TodosCod, Cod As Range
        Set TodosCod = ActiveSheet.Range("B3:B3")

'Definir variáveis para o procedimento de inserção de fotos
    Dim Pasta, Ext, TxtCod As String
    Dim Fig As Shape
    Dim FigJaExist As Boolean
        Pasta = "Z:\SGQ\1. Banco de Dados\Imagens\"
        Ext = ".png"

'Inserir a imagem baseado no código da imagem
    For Each Cod In TodosCod
        TxtCod = Cod.Value
        FigJaExist = False

'Checar a existência do arquivo
        If Not Dir(Pasta & TxtCod & Ext) = "" Then

'Checar se há alguma foto na célula de destino
            For Each Fig In ActiveSheet.Shapes
                If Fig.TopLeftCell.Address = Cod.Offset(0, 1).Address Then FigJaExist = True
                Next Fig

'Se não houver foto na célula, inserir o arquivo
            If FigJaExist = False Then
                With ActiveSheet.Pictures.Insert(Pasta & TxtCod & Ext)
                    .Left = Cod.Offset(0, 1).Left
                    .Top = Cod.Offset(0, 1).Top
                '...caso queira determinar a largura e altura da imagem
                    .ShapeRange.LockAspectRatio = msoFalse
                    .ShapeRange.Width = 350
                    .ShapeRange.Height = 350
                
                    End With
                End If
            End If
        Next Cod

End Sub

 

[Midori]

@Rangel Salomé Acho mais simples fazer da forma como comentei, é só adicionar o Shape na planilha (Insert > Illustrations > Shapes > Rectangle) e carregar a imagem nele. Para carregar a imagem ao entrar com o código em B3, a macro pode ser ativada no evento Change da planilha assim,

 

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$B$3" Then
        Dim Arquivo As String
        
        Arquivo = "C:\Fotos\" & Target.Value & ".png"
        Call Me.Shapes("Imagem").Fill.UserPicture(Arquivo)
    End If
End Sub

 

Esse procedimento deve ficar no módulo da Planilha. Veja que o nome do Shape aí é Imagem e do diretório C:\Fotos, no seu caso de vem ser outros. Faça um teste e se der certo você pode adicionar On Error Resume Next para não mostrar uma mensagem no caso de um erro de digitação ou se uma imagem específica não for encontrada.

[Rangel Salomé]

@Midori Obrigado! deu certinho!