Este fórum está sendo desativado

[refernande]

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"

[CursoDeExcelGratis]

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

[CursoDeExcelGratis]

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

[refernande]

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

[CursoDeExcelGratis]

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

[CursoDeExcelGratis]

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.

[refernande]

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.

[CursoDeExcelGratis]

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.

[refernande]

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

[CursoDeExcelGratis]

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

[CursoDeExcelGratis]

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

[refernande]

Perfeito,
Muito obrigado pelo apoio.