Este fórum está sendo desativado

[RodrigoFetter]

Prezados, tudo bem?

Vem algum tempo que utilizo um código VBA, extraído da internet para importar imagens para uma planilha, conforme o código cadastrado. Caso, não localizava a imagem no diretório especifico, pulava para a próxima instrução, sem nenhuma mensagem de alerta que não tinha localizado o arquivo, até localizar ou chegar numa regra, com nome fixo. Porém, de uns meses prá essa função parou de funcionar, apresentando uma mensagem de alerta informando que houve um erro ao importa o arquivo, precisando clicar no enter a cada texte realizado na função, até chegar na regra, que valide a imagem solicitada.
Antes de tudo, muito obrigado por quem poder me ajudar.

Segue o exemplo do código:

Public Function getImage(ByVal sCode As String) As String

On Error Resume Next

Dim sFile As String
Dim oSheet As Worksheet
Dim oCell As Range
Dim oImage As Shape

Set oCell = Application.Caller
Set oSheet = oCell.Parent

Set oImage = Nothing
For i = 999 To oSheet.Shapes.Count

If oSheet.Shapes(i).Name = sCode Then
Set oImage = oSheet.Shapes(i)
Exit For
End If
Next i

If oImage Is Nothing Then
sFile = "\\10.0.0.7\c$\inetpub\wwwroot\Shopnow\Fotos\" & sCode & ".jpg"
Set oImage = oSheet.Shapes.AddPicture(sFile, msoCTrue, msoCTrue, oCell.Left, oCell.Top, oCell.Width, oCell.Height)

If oImage Is Nothing Then
sFile = "\\10.0.0.7\c$\inetpub\wwwroot\Shopnow\Fotos\" & Left$(sCode, 7) & "-c.jpg"
Set oImage = oSheet.Shapes.AddPicture(sFile, msoCTrue, msoCTrue, oCell.Left, oCell.Top, oCell.Width, oCell.Height)

End If
oImage.Name = sCode
Else
With oImage
.Left = oCell.Left
.Top = oCell.Top
.Width = oCell.Width
.Height = oCell.Height
End With
End If

getImage = ""

End Function

[Basole]

Acrescente a linha a baixo no seu codigo abaixo da linha sFile

Código: Selecionar todos

If VBA.Len(VBA.Dir(sFile, vbArchive)) = 0 Then MsgBox "Imagem Ñ encontrada", 16, "AT~": Exit Sub

[RodrigoFetter]

Prezado, em primeiro lugar muito obrigado por ter respondido meu post e peço desculpa a falta de um retorno breve.

Mas, infelizmente a solução passada não deu certo. Apresentou o seguinte erro:

"Erro de compilação: Exit Sub não permitido Fucntion or Property"

Acredito que isso ocorreu, pois o código é uma Public Function ou não?
Teria mais alguma solução para mim? Ficaria muito grato.

[Basole]

Ops, desculpem nossa falha, segue abaixo a correção:

Código: Selecionar todos

If VBA.Len(VBA.Dir(sFile, vbArchive)) = 0 Then MsgBox "Imagem Ñ encontrada", 16, "AT~": Exit Function

[RodrigoFetter]

Opa, capaz!

Fiz alteração que sugiriu:

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, sErro 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 = 999 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 = "\\10.0.0.7\c$\inetpub\wwwroot\Shopnow\Fotos\" & sCode & ".jpg"

If VBA.Len(VBA.Dir(sFile, vbArchive)) = 0 Then
MsgBox "Imagem Ñ encontrada", 16, "AT~":
Exit Function

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)

sErro = "\\10.0.0.7\c$\inetpub\wwwroot\Shopnow\Fotos\" & Left$(sCode, 7) & "-c.jpg"
Set oImage = oSheet.Shapes.AddPicture(sErro, msoCTrue, msoCTrue, oCell.Left, oCell.Top, oCell.Width, oCell.Height)

End If
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

Agora traz a mensagem nos item que não localiza a imagem, a ideia é de remover qualquer mensagem quando não localiza o arquivo.
No entando, sei que comentanto e/ou removendo o "MsgBox", já resolveria isso. Só que, agora com o código alterado, não está trazendo as imagens que o sistema localiza.

Por gentileza, poderia verificar o que estou fazendo de errado no código?

Muito obrigado pela sua ajuda, ela está sendo de grande valia.

[RodrigoFetter]

Ah, agora que eu vi, que na mensagem original esqueci de mencionar, que gostaria que não aparecer mensagem alguma, caso, não encontre os arquivos conforme a instrução nos IF.
Desculpe pelo equivoco. kkk

[Basole]

Fiz as alterações eliminando o alerta da msgbox
Mas deixei como opção de retornar a msg na respectiva celula
Para usar a opção coloque a função, a referencia da celula e VERDADEIRO
Exemplo:

=getImage(A1;VERDADEIRO)

Ou apenas

=getImage(A1)

Para nenhuma msg ou aviso:

Código: Selecionar todos

Public Function getImage(ByVal sCode As String, Optional nFound As Boolean) 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, sErro 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 = 999 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 = "\\10.0.0.7\c$\inetpub\wwwroot\Shopnow\Fotos\" & sCode & ".jpg"
          
If VBA.Len(VBA.Dir(sFile, vbArchive)) = 0 And nFound Then
getImage = "Imagem Ñ Encontrada!" ' altere a gosto
Exit Function
ElseIf VBA.Len(VBA.Dir(sFile, vbArchive)) = 0 Then
Exit Function
End If

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)

sErro = "\\10.0.0.7\c$\inetpub\wwwroot\Shopnow\Fotos\" & Left$(sCode, 7) & "-c.jpg"
Set oImage = oSheet.Shapes.AddPicture(sErro, msoCTrue, msoCTrue, oCell.Left, oCell.Top, oCell.Width, oCell.Height)

End If
'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

[RodrigoFetter]

Rapaz, resolveu como uma luva! Muito obrigado por sua ajuda! Está de parabéns, por sua dedicação disponibilizando seu tempo em ajudar um colega de profissão. Muito obrigado mesmo!