Este fórum foi descontinuado. LEIA AQUI e participe da Comunidade BABOO :)

A área de Remoção de Malwares está aberta na Comunidade BABOO. LEIA AQUI

Ir para conteúdo
guibean

Macro para inserir imagem

Mensagem Recomendada

Tenho o seguinte macro para inserir imagem no excel:

Sub Insere()
Dim Pict
Dim ImgFileFormat As String
Dim PictCell As Range
Dim Ans As Integer
'ActiveSheet.Protect True, True, True, True, True
ImgFileFormat = "Image Files gif (*.gif),*.wmf,(*.bmp),others , jpg (*.jpg),*.jpg"
GetPict:
Pict = Application.GetOpenFilename(ImgFileFormat)
If Pict = False Then End

ActiveSheet.Pictures.Insert(Pict).Select
Selection.ShapeRange.IncrementLeft -22.5
Selection.ShapeRange.IncrementTop -197.25
End Sub

Esse macro insere a imagem a -22.5 pra esquerda e -197.25 do topo da célula que você selecionou.

Mas o que eu gostaria mesmo é que a macro inserisse a imagem desejada exatamente na célula que eu quero, independentemente da célula selecionada. Teria que conter no código acima a célula que eu quero ex: célula B12 ou E15.

Queria também definir o tamanho da imagem inserida, podendo colocar qualquer tamanho desejado.

Obrigado


Giganova.org

Levando o Bittorrent até voce!!!!

http://www.giganova.org

Compartilhar este post


Link para o post
Compartilhar em outros sites

Tenho o seguinte macro para inserir imagem no excel:

Sub Insere()
Dim Pict
Dim ImgFileFormat As String
Dim PictCell As Range
Dim Ans As Integer
'ActiveSheet.Protect True, True, True, True, True
ImgFileFormat = "Image Files gif (*.gif),*.wmf,(*.bmp),others , jpg (*.jpg),*.jpg"
GetPict:
Pict = Application.GetOpenFilename(ImgFileFormat)
If Pict = False Then End

ActiveSheet.Pictures.Insert(Pict).Select
Selection.ShapeRange.IncrementLeft -22.5
Selection.ShapeRange.IncrementTop -197.25
End Sub

Esse macro insere a imagem a -22.5 pra esquerda e -197.25 do topo da célula que você selecionou.

Mas o que eu gostaria mesmo é que a macro inserisse a imagem desejada exatamente na célula que eu quero, independentemente da célula selecionada. Teria que conter no código acima a célula que eu quero ex: célula B12 ou E15.

Queria também definir o tamanho da imagem inserida, podendo colocar qualquer tamanho desejado.

Obrigado

Revivendo pois preciso de algo parecido, alguém tem solução para isso?

Em tempo, gostaria que a imagem fosse inserida na célula por mim especificada, com um tamanho já padrão. Por exemplo, ao clicar no botão é inserida uma imagem na célula A25 com 60mm altura x 80mm largura, com essas dimensões ela ocuparia um pouco mais de, aproximadamente, das células A25-C36.

Antecipadamente agradeço.

Atenciosamente,

Caio.

Editado por cacalino

Compartilhar este post


Link para o post
Compartilhar em outros sites

A imagem será inserida na célula selecionada... com o tamanho especificado nas duas últimas linhas do código 12 Linhas por 3 colunas.


Sub Insere()
Dim Pict
Dim Imagem As Object
Dim ImgFileFormat As String

ImgFileFormat = "Image Files JPG (*.jpg),*.jpg, Image Files GIF (*.gif),*.gif, Image Files BMP (*.bmp),*.bmp"

Pict = Application.GetOpenFilename(ImgFileFormat)
If Pict = False Then End

Set Imagem = ActiveSheet.Pictures.Insert(Pict)

Imagem.Top = ActiveCell.Top
Imagem.Left = ActiveCell.Left
Imagem.ShapeRange.LockAspectRatio = msoFalse

'12 = Quantidade de linhas...
Imagem.Height = ActiveCell.Height * 12

'3 = Quantidade de colunas...
Imagem.Width = ActiveCell.Width * 3
End Sub

Compartilhar este post


Link para o post
Compartilhar em outros sites

A imagem será inserida na célula selecionada... com o tamanho especificado nas duas últimas linhas do código 12 Linhas por 3 colunas.


Sub Insere()
Dim Pict
Dim Imagem As Object
Dim ImgFileFormat As String

ImgFileFormat = "Image Files JPG (*.jpg),*.jpg, Image Files GIF (*.gif),*.gif, Image Files BMP (*.bmp),*.bmp"

Pict = Application.GetOpenFilename(ImgFileFormat)
If Pict = False Then End

Set Imagem = ActiveSheet.Pictures.Insert(Pict)

Imagem.Top = ActiveCell.Top
Imagem.Left = ActiveCell.Left
Imagem.ShapeRange.LockAspectRatio = msoFalse

'12 = Quantidade de linhas...
Imagem.Height = ActiveCell.Height * 12

'3 = Quantidade de colunas...
Imagem.Width = ActiveCell.Width * 3
End Sub

Alexandre, muito obrigado pela resposta, funcionou certinho aqui, mas com um porém: não tem como inserir a imagem em alguma célula especificada - A25, por exemplo -, ao invés da célula selecionada?

Antecipadamente agradeço.

Atenciosamente, Caio.

Compartilhar este post


Link para o post
Compartilhar em outros sites

substitua por esse código...

A25 é a célula escolhida...

Sub Insere_Especifico()
Dim Pict
Dim Imagem As Object
Dim ImgFileFormat As String
Dim Celula As String

Celula = "A25"

ImgFileFormat = "Image Files JPG (*.jpg),*.jpg, Image Files GIF (*.gif),*.gif, Image Files BMP (*.bmp),*.bmp"

Pict = Application.GetOpenFilename(ImgFileFormat)
If Pict = False Then End

Set Imagem = ActiveSheet.Pictures.Insert(Pict)

Imagem.Top = Range(Celula).Top
Imagem.Left = Range(Celula).Left
Imagem.ShapeRange.LockAspectRatio = msoFalse

Imagem.Height = Range(Celula).Height * 12 '12 = Quantidade de linhas...
Imagem.Width = Range(Celula).Width * 3 '3 = Quantidade de colunas...
End Sub

Compartilhar este post


Link para o post
Compartilhar em outros sites

substitua por esse código...

A25 é a célula escolhida...

Sub Insere_Especifico()
Dim Pict
Dim Imagem As Object
Dim ImgFileFormat As String
Dim Celula As String

Celula = "A25"

ImgFileFormat = "Image Files JPG (*.jpg),*.jpg, Image Files GIF (*.gif),*.gif, Image Files BMP (*.bmp),*.bmp"

Pict = Application.GetOpenFilename(ImgFileFormat)
If Pict = False Then End

Set Imagem = ActiveSheet.Pictures.Insert(Pict)

Imagem.Top = Range(Celula).Top
Imagem.Left = Range(Celula).Left
Imagem.ShapeRange.LockAspectRatio = msoFalse

Imagem.Height = Range(Celula).Height * 12 '12 = Quantidade de linhas...
Imagem.Width = Range(Celula).Width * 3 '3 = Quantidade de colunas...
End Sub

Alexandre, funcionou perfeitamente aqui para mim, muito bom.

Sem palavras, muito obrigado!

Compartilhar este post


Link para o post
Compartilhar em outros sites

Alguém tem uma planilha que posso usar como base? Para melhorar a que utilizo, trabalho com laudos e preciso inserir varias imagens e tenho que ficar arrumando elas após isso, queria inserir todas com tamanho e local especifico mas entendo bem pouco de vba,  queria somente uma para utiliazar como base!

Editado por jessikcaires

''

Compartilhar este post


Link para o post
Compartilhar em outros sites

JESSIKCAIRES, Para melhor entendimento, se possivel especifique melhor sua pergunta. Que tipo de 'arrumacao' precisa? (tamanho da imagem ajustar dentro na celula, fixar alguma celula). Se pudesse enviar um ex pratico c/ o resultado desejado seria o ideal.  


* Dê retorno.  

Compartilhar este post


Link para o post
Compartilhar em outros sites

Boa tarde,

Consegui utilizar essa macro colocando a foto da maneira que precisava para gerar um laudo no qual trabalho. Mas após fazer vários desses laudos com essa macro percebi que quando passo essa planilha para outro computador a imagem não vai junto aparece a seguinte mensagem " A imagem vinculada não pode ser exibida. Talvez o arquivo tenha sido movido, renomeado ou excluído. Verifique se o vínculo aponta para o arquivo e o local correto". Tem como resolver esse problema? Preciso urgentemente solucionar isso!

Desde já agradeço.

Compartilhar este post


Link para o post
Compartilhar em outros sites

jessikcaires,

Adicionando uma foto com Insert faz uma referência a um arquivo no seu disco rígido e nao aparecerá qdo.abre em outro computador, se você quiser que a imagem seja incorporado no arquivo você tem que adicionar de uma forma (vide o codigo), colocando a imagem na forma usando a AddPicture:

 

Sub Insere_Especifico_AddPicture()
    Dim Pict
    Dim ImgFileFormat As String
    Dim Celula As String
    Celula = "A25"
    ImgFileFormat = "Image Files JPG (*.jpg),*.jpg, Image Files GIF (*.gif),*.gif, Image Files BMP (*.bmp),*.bmp"
    Pict = Application.GetOpenFilename(ImgFileFormat)
    If Pict = False Then End
   Application.ActiveSheet.Shapes.AddPicture Pict, False, True, Range(Celula).Left, _

    Range(Celula).Top, Range(Celula).Height * 12, Range(Celula).Width * 3

End Sub

abx.

Editado por Basole

''

* Dê retorno.  

Compartilhar este post


Link para o post
Compartilhar em outros sites

×
×
  • Criar Novo...