Tópicos relacionados a códigos VBA, gravação de macros, etc.
  • Avatar do usuário
Por refernande
#63843
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"
#63852
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
#63853
no meu caso ja existe a forma criada, na sua macro vc quer que crie a forma ou ela é existente ?
#63857
obrigado ! acredito que o trecho que te mandei vai funcionar, vou testar e te falo
#63858
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.
Por refernande
#63881
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.
#63891
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.
Você não está autorizado a ver ou baixar esse anexo.
Por refernande
#63897
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
#63925
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
#63931
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

:mrgreen:

Prezados boa noite, gostaria de saber se e poss&ia[…]

data EMPOLAMENTO PEDIDO ocupação[…]

Rastreabilidade de Dados

Boa Tarde! Funcionamento atual: Ao inserir dad[…]

#vba nao roda no excel online Pessoal Tenho uma p[…]

Boa tarde, pessoal. Preciso de ajuda para uma mac[…]

Boa tarde pessoal! Eu tenho uma planilha que cont&[…]

Saudações Senhoras(es)! Criei uma m[…]

Incluir sequência de códigos

Não sei se entendi, mas para C13, penso em […]