Guru do Excel e Power BI

Boa Tarde,
Alguém pode me ajudar com uma VBA para inserir imagem dentro de uma Forma Excel?
Tenho uma VBA mais ela insere dentro de uma célula.

Código:

"Sub Imagem_Foto_01A()
Dim sPathFigura As String
Dim sNomeFig As String
Dim sArrayRange
Dim sRgAddPic As Range
Dim sValor
Dim I As Integer
Dim arqAAbrir
Dim Msg, Style, Title, Response, MyString
Msg = "Deseja realmente limpar o formulário?" ' Define a mensagem.
Style = vbYesNo + vbCritical + vbDefaultButton1 ' Define o botão NÃO como padrão.
Title = "LIMPAR FORMULARIO" ' Define o título.
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then ' O usuário escolheu Sim.
' Executa alguma ação
'Abre a caixa para selecionar e pegar o Endereço (Caminho) onde estão as figuras
sPathFigura = Application.GetOpenFilename("Arquivos de imagens (*.jpg;*.jpeg;*.png;*.bmp;), *.jpg;*.jpeg;*.png;*.bmp")
' sPathFigura = Application.GetOpenFilename("Arquivos de imagens (*.jpg;*.jpeg), *.jpg;*.jpeg")
'Definimos o Range Nomeado onde será inserido a Imagem
Set sRgAddPic = ActiveSheet.Range("Foto_01A")
Application.ScreenUpdating = False

'Chamamos a função para inserção da figura
AddPicOverCell sPathFigura, sRgAddPic
Else ' O usuário escolheu Não.

Exit Sub
End If

Call Formatar_Imagens

End Sub"

coloquei para gravar macro e simulei colocar a imagem usando o caminho de preenchimento da forma, ele fez um pouco diferente do seu trecho

ActiveSheet.Shapes.Range(Array("Rounded Rectangle 1")).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.UserPicture "caminhodoarquivo"
.TextureTile = msoFalse
.RotateWithObject = msoTrue
End With

no meu caso ja existe a forma criada, na sua macro vc quer que crie a forma ou ela é existente ?

Tenho uns 4 retângulos e gostaria de inserir a imagens dentro deles via VBA. Planilha em anexo para entendimento.

obrigado ! acredito que o trecho que te mandei vai funcionar, vou testar e te falo

Deu certo, eu criei uma funcao chamada CarregarImage, vc vai passar o nome do shape e o caminho da foto


Private Sub CarregarImagem(ByVal NomeShape As String, ByVal CaminhoFoto As String)

ActiveSheet.Shapes.Range(Array(NomeShape)).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.UserPicture CaminhoFoto
.TextureTile = msoFalse
.RotateWithObject = msoTrue
End With
End Sub


vai chamar ela assim por exemplo

Call carregarimagem("Foto_03", "C:\foto.jpg")

veja se resolve por favor.

Bom dia,

o Cóodigo abaixo está apresentando erro nesses trecho "AddPicOverCell sPathFigura, sRgAddPic"

"Sub Imagem_Foto_01A()
Dim sPathFigura As String
Dim sNomeFig As String
Dim sArrayRange
Dim sRgAddPic As Range
Dim sValor
Dim I As Integer
Dim arqAAbrir
Dim Msg, Style, Title, Response, MyString
Msg = "Deseja realmente limpar o formulário?" ' Define a mensagem.
Style = vbYesNo + vbCritical + vbDefaultButton1 ' Define o botão NÃO como padrão.
Title = "LIMPAR FORMULARIO" ' Define o título.
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then ' O usuário escolheu Sim.
' Executa alguma ação
'Abre a caixa para selecionar e pegar o Endereço (Caminho) onde estão as figuras
sPathFigura = Application.GetOpenFilename("Arquivos de imagens (*.jpg;*.jpeg;*.png;*.bmp;), *.jpg;*.jpeg;*.png;*.bmp")
' sPathFigura = Application.GetOpenFilename("Arquivos de imagens (*.jpg;*.jpeg), *.jpg;*.jpeg")
'Definimos o Range Nomeado onde será inserido a Imagem
Set sRgAddPic = ActiveSheet.Range("Foto_01A")
Application.ScreenUpdating = False

'Chamamos a função para inserção da figura
AddPicOverCell sPathFigura, sRgAddPic
Else ' O usuário escolheu Não.

Exit Sub
End If

Call Formatar_Imagens

End Sub


Private Sub CarregarImagem(ByVal NomeShape As String, ByVal CaminhoFoto As String)

ActiveSheet.Shapes.Range(Array(NomeShape)).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.UserPicture CaminhoFoto
.TextureTile = msoFalse
.RotateWithObject = msoTrue
End With
End Sub"



A código inicia ele insere foto no intervalo aplicado. Uma de cada vez. No casa como tenho 4 retângulos tenho 4 macros para inserir uma em cada retângulo. Rodava a vba procurava a imagem selecionava e ela inseria. Gostaria dessa forma a macro fazer isso no retângulo.

oi, boa noite, com o codigo que vc mandou não vai rodar, pois nao existe essa função addpicovercell no vba, essa é uma função que alguem criou e precisa estar no seu código para funcionar

então, o que vc tem que fazer é substituir ela por outra, pode ser a minha

'AddPicOverCell sPathFigura, sRgAddPic
Call CarregarImagem("Foto_01", sPathFigura)

eu comentei a linha com erro e coloquei a minha função e deu certo aqui, espero que funcione pra vc também.

é importante que vc coloque um nome de shape que exista na planilha, em anexo estou enviando como ficou a planilha com a macro.

PS : de preferência sempre enviei a planilha completa com os códigos, fica mais fácil analisar.

CursiDeExcelGratis funcionou perfeitamente era isso mesmo que estava precisando, muito Obrigado.
Só aproveitando um pouco da sua inteligência, teria um macro para remover a imagem inserida e deixar o retângulo em branco? pq como sempre trabalho com relatórios sempre é necessários fazer isso.
Obrigado

que bom que deu certo ! vc sabe que eu pensei nisso também kkk, como tirar a foto , vou dar uma procurada para ver se acho algo e te falo

olha só, chutei e foi pro gol !! rs

Private Sub limparfoto(ByVal NomeShape As String)
ActiveSheet.Shapes.Range(Array(NomeShape)).Select
With Selection.ShapeRange.Fill
.Visible = msoFalse 'na outra funcao aqui é true
'e tirei o user picture
.TextureTile = msoFalse
.RotateWithObject = msoTrue
End With

End Sub

Perfeito,
Muito obrigado pelo apoio.