-1
Hello I’m new around here,
I have two codes, one that searches the image by code, which runs instantly simulating a procv. And a macro that is executed in the change of the cell, to erase the first image and not overlap in the search of the second image. However it seems that it generates conflict and the image is erased without the search for the new image being carried out.
P.S. The two individually executed codes work perfectly, only need to be executed in sequence. Someone can help me?
First Code
Public Function getImage(ByVal sCode As String) As String
On Error Resume Next ' Indica que no caso de erros de carregamento de imagem deve continuar executando a partir da próxima linha
Dim sFile As String
Dim oSheet As Worksheet
Dim oCell As Range
Dim oImage As Shape
Set oCell = Application.Caller ' Célula onde a função foi chamada
Set oSheet = oCell.Parent ' Planilha que chamou a função
' Procura por uma imagem existente identificada pelo código (que precisa ser único!)
Set oImage = Nothing
For i = 1 To oSheet.Shapes.Count
If oSheet.Shapes(i).Name = sCode Then
Set oImage = oSheet.Shapes(i)
Exit For
End If
Next i
' Se ainda não existir uma imagem com o código, carrega do arquivo e cria-a.
' A imagem já é posicionada na exata posição da célula onde a função foi chamada.
If oImage Is Nothing Then
sFile = "c:teste\" & sCode & ".jpg"
Set oImage = oSheet.Shapes.AddPicture(sFile, msoCTrue, msoCTrue, oCell.Left, oCell.Top, oCell.Width, oCell.Height)
If oImage Is Nothing Then ' Verifica se falhou o carregamento da imagem. Se falhou, adiciona a imagem genérica (com nome fixo)
Set oImage = oSheet.Shapes.AddPicture("c:teste\inexistente.jpg", msoCTrue, msoCTrue, oCell.Left, oCell.Top, oCell.Width, oCell.Height)
End If
oImage.Name = sCode
' Caso contrário, se a imagem já existir, garante que ela se posiciona e cabe exatamente dentro da célula
' (apenas para o caso do usuário ter movido ou redimensionado manualmente a imagem sem querer)
Else
With oImage
.Left = oCell.Left
.Top = oCell.Top
.Width = oCell.Width
.Height = oCell.Height
End With
End If
' Retorna nada para a célula (afinal, esta é somente uma função de auxílio)
getImage = ""
End Function
Second Code:
Sub ApagarImg1()
On Error Resume Next
Dim img As Object 'Era antes "As Shape"
For Each img In ActiveSheet.Pictures 'Era antes ".Shape"
If Not Application.Intersect(img.TopLeftCell, ActiveSheet.Range("c5")) Is Nothing Then 'seleciona a área da imagem
img.Delete
End If
Next
End Sub
Avoid using uppercase letters in sentences, as in the title for example. https://pt.meta.stackoverflow.com/questions/5483/manual-de-como-n%C3%83o-fazer-perguntas/5505#5505
– phduarte
did the editing...
– Eder Oliveira