Private Sub ListBox1_Click()
' Verifica se um item está selecionado na ListBox
If ListBox1.ListIndex >= 0 Then
' Atualiza o TextBox1 com o nome correspondente
TextBox1 = ListBox1.List(ListBox1.ListIndex, 1)
' Carrega a imagem associada ao nome selecionado
Call CarregarImagem
End If
End Sub
Sub CarregarImagem()
Dim nome As String
Dim imgShape As Shape
Dim imgRange As Range
Dim wsFotos As Worksheet
Dim tempPath As String
' Desativa atualizações visuais para evitar que a tela fique piscando
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error GoTo ErrorHandler
' Referência à planilha onde estão as imagens
Set wsFotos = ThisWorkbook.Worksheets("FOTO")
' Obtém o nome selecionado na ListBox (coluna 1)
nome = ListBox1.List(ListBox1.ListIndex, 1)
' Verifica se o nome existe na planilha "FOTO"
Set imgRange = wsFotos.Columns(1).Find(What:=nome, LookIn:=xlValues, LookAt:=xlWhole)
If Not imgRange Is Nothing Then
' Procura a imagem na mesma linha do nome encontrado
For Each imgShape In wsFotos.Shapes
If Not Intersect(imgShape.TopLeftCell, imgRange.Offset(0, 1)) Is Nothing Then
' Exporta a imagem temporariamente
tempPath = Environ("Temp") & "\" & nome & ".jpg"
imgShape.Copy
With wsFotos.ChartObjects.Add(1, 1, imgShape.Width, imgShape.Height)
.Activate
.Chart.Paste
.Chart.Export tempPath
.Delete
End With
' Carrega a imagem no controle Image1
Image1.Picture = LoadPicture(tempPath)
Exit Sub
End If
Next imgShape
Else
MsgBox "Imagem não encontrada para o nome: " & nome, vbExclamation, "Erro"
Image1.Picture = LoadPicture("") ' Limpa a imagem
End If
Exit Sub
ErrorHandler:
MsgBox "Erro ao carregar a imagem: " & Err.Description, vbCritical, "Erro"
Image1.Picture = LoadPicture("") ' Limpa a imagem
Finally:
' Restaura as configurações após a execução
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
Private Sub UserForm_Initialize()
' Limpa a imagem ao inicializar o formulário
Image1.Picture = LoadPicture("")
End Sub
Postado : 16/11/2024 10:39 am