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

Ir para conteúdo
guibean

Macro para inserir imagem

Mensagem Recomendada

Bom dia.

 

Estou tendo o mesmo problema da jessikcaires mas não estou conseguindo inserir o AddPicture conforme Basole informou. Alguém pode ajudar, por favor.

 

Segue o script:

 

Sub InsertPic()
Dim pic As String 'ENDEREÇO
Dim myPicture As Picture
Dim rng As Range 'RANGE PARA ITERAR


Set rng = Range("M5") '1A CELULA DA FOTA

Do While rng.Offset(0, -'8' <> ""

pic = "C:\FOTOS_INTERNET\" & rng.Offset(0, -'8' & "_productr_1.jpg"
If Dir(pic) = "" Then GoTo prox 'VERIFICA SE EXISTE
Set myPicture = ActiveSheet.Pictures.Insert(pic)
With myPicture
.ShapeRange.LockAspectRatio = msoFalse
.Width = rng.Width - 1
.Height = rng.Height - 1
.Top = Rows(rng.Row).Top
.Left = Columns(rng.Column).Left
End With
prox: Set rng = rng.Offset(1, 0)
Loop

End Sub

Compartilhar este post


Link para o post
Compartilhar em outros sites

Boa noite,

 

 

gostaria de um codigo VBA onde eu pudesse inserir varias fotos ao mesmo tempo em celulas pré selecionadas, esta que o Basole mandou é quase isso, mas eu gostaria de inseri-las todas ao mesmo tempo, alguém poderia me ajudar?

Editado por marcoagonzaga

''

Compartilhar este post


Link para o post
Compartilhar em outros sites

marcoagonzaga, Seja bem vindo a bordo,

Pelas regras do forum nao é permitido usar o topico  de outro usuario para sanar as duvidas similares. 

Sugiro q crie um novo topico com o titulo por ex.: "Macro para Inserir Varias imagens ao mesmo tempo"

Crie também um modelo (exemplo), bem proximo da sua planilha original indicando as celulas citadas e destacando o resultado desejado.

Isso ajuda e facilita o melhor entendimento do q você precisa e a breve resolução do seu problema.   


* Dê retorno.  

Compartilhar este post


Link para o post
Compartilhar em outros sites

Basole,

 

 

Desculpe, sou novo aqui, aproveitando sua deixa, alguém teria um codigo ou Macro para Inserir Varias imagens ao mesmo tempo? pois os codigos todos citados acima já tenho, pesquisei em varis lugares, porem sem sucesso, só consigo inserir uma imagem de cada vez. obrigado a todos.

Compartilhar este post


Link para o post
Compartilhar em outros sites

Boa tarde, testei essas macros, informadas pelo pessoal neste fórum, porém as imagem são anexadas na célula, e quando colocamos margem de borda nas celulas, a foto come um pedaço da margem quando mandamos imprimir ou salvar como pdf, alguém saberia me informar o que mudar no código para que isso não ocorra? pensei em uma macro que a foto fosse inserida como fundo de uma caixa de texto, daí não teríamos este problema também serviria para mim, alguém poderia me ajudar?

Compartilhar este post


Link para o post
Compartilhar em outros sites

Drausio Gomes

 

 

Drausio, me manda seu email, posso te ajudar eu acho.

 

marcagonzaga@hotmail.com


Pessoal,

 

 

Ainda estou tendo dificuldade em inserir varias fotos ao mesmo tempo em determinadas celular com um único click, tipo quando abrimos a aba inserir, imagens, dps abre a janela e selecionamos todas ao mesmo tempo, alguém, help!!!!

Editado por marcoagonzaga

''

Compartilhar este post


Link para o post
Compartilhar em outros sites

boa tarde Pessoal,

 

consegui o que eu queria, vou compartilhar com vcs...

 

 

 

Sub Carregar_AutoImagens()
 
    Dim Pict
    Dim ImgFileFormat As String
    Dim Celula As String
    Celula = "A38"    ' celula que será inserido a imagem
    ImgFileFormat = "Image Files JPG (*.jpg),*.jpg, Image Files PNG (*.png),*.jpg, Image Files GIF (*.gif),*.gif, Image Files BMP (*.bmp),*.bmp"
    
    'Pict = Application.GetOpenFilename(ImgFileFormat, False, False, MultiSelect:=True)
    
    Pict = Application.GetOpenFilename(ImgFileFormat, False, False, False, True)
    
    'If Pict = False Then End
    
    If IsArray(Pict) Then 'IF ARRAY
    
        If UBound(Pict) <= 28 Then 'IF I
        
            j = 1
    
            For i = LBound(Pict) To UBound(Pict) 'FOR I
            
                Select Case i 'Cobertura de 32 imagens
                
                    Case 1 To 4
                        'IMAGEM: largura = 30 colunas; altura= 13 linhas
                        Application.ActiveSheet.Shapes.AddPicture Pict(i), False, True, Range(Celula).Left, _
                        Range(Celula).Top, Range(Celula).Width * 3, Range(Celula).Height * 6
                        
                        j = j + 3
                        Celula = Chr(64 + j) & "38"
                                            
                    Case 5 To 8
                    
                        If Mid(Celula, 1, 1) = "M" Then
                            j = 1
                            Celula = Chr(64 + j) & "45"
                        End If
                        'IMAGEM: largura = 30 colunas; altura= 13 linhas
                        Application.ActiveSheet.Shapes.AddPicture Pict(i), False, True, Range(Celula).Left, _
                        Range(Celula).Top, Range(Celula).Width * 3, Range(Celula).Height * 6
                        
                        j = j + 3
                        Celula = Chr(64 + j) & "45"
                    
                    
                    Case 9 To 12
                        If Mid(Celula, 1, 1) = "M" Then
                            j = 1
                            Celula = Chr(64 + j) & "52"
                        End If
                        'IMAGEM: largura = 30 colunas; altura= 13 linhas
                        Application.ActiveSheet.Shapes.AddPicture Pict(i), False, True, Range(Celula).Left, _
                        Range(Celula).Top, Range(Celula).Width * 3, Range(Celula).Height * 6
                        
                        j = j + 3
                        Celula = Chr(64 + j) & "52"
                    
                    Case 13 To 16 '66
                        If Mid(Celula, 1, 1) = "M" Then
                            j = 1
                            Celula = Chr(64 + j) & "66"
                        End If
                        'IMAGEM: largura = 30 colunas; altura= 13 linhas
                        Application.ActiveSheet.Shapes.AddPicture Pict(i), False, True, Range(Celula).Left, _
                        Range(Celula).Top, Range(Celula).Width * 3, Range(Celula).Height * 6
                        
                        j = j + 3
                        Celula = Chr(64 + j) & "66"
                    
                    Case 17 To 20 '73
                       If Mid(Celula, 1, 1) = "M" Then
                            j = 1
                            Celula = Chr(64 + j) & "73"
                        End If
                        'IMAGEM: largura = 30 colunas; altura= 13 linhas
                        Application.ActiveSheet.Shapes.AddPicture Pict(i), False, True, Range(Celula).Left, _
                        Range(Celula).Top, Range(Celula).Width * 3, Range(Celula).Height * 6
                        
                        j = j + 3
                        Celula = Chr(64 + j) & "73"
                    
                    Case 21 To 24 '80
                      If Mid(Celula, 1, 1) = "M" Then
                            j = 1
                            Celula = Chr(64 + j) & "80"
                        End If
                        'IMAGEM: largura = 30 colunas; altura= 13 linhas
                        Application.ActiveSheet.Shapes.AddPicture Pict(i), False, True, Range(Celula).Left, _
                        Range(Celula).Top, Range(Celula).Width * 3, Range(Celula).Height * 6
                        
                        j = j + 3
                        Celula = Chr(64 + j) & "80"
                    
                    Case 25 To 28 '87
                        If Mid(Celula, 1, 1) = "M" Then
                            j = 1
                            Celula = Chr(64 + j) & "87"
                        End If
                        'IMAGEM: largura = 30 colunas; altura= 13 linhas
                        Application.ActiveSheet.Shapes.AddPicture Pict(i), False, True, Range(Celula).Left, _
                        Range(Celula).Top, Range(Celula).Width * 3, Range(Celula).Height * 6
                        
                        j = j + 3
                        Celula = Chr(64 + j) & "87"
 
                End Select
 
            Next i 'FOR I
        
        Else 'IF I
        
            MsgBox "Selecionar apenas 28 imagens"
            End
        
        End If 'IF I
    
    End If 'IF ARRAY
    
    
    'If Pict = False Then End
    'Application.ActiveSheet.Shapes.AddPicture Pict, False, True, Range(Celula).Left, _
    'Range(Celula).Top, Range(Celula).Width * 3, Range(Celula).Height * 6    'IMAGEM: largura = 30 colunas; altura= 13 linhas
End Sub

Código testado funcionando perfeitamente. Problema resolvido!!!! Muito Obrigada Basole =*

 

Código testado funcionando perfeitamente. Problema resolvido!!!! Muito Obrigada Basole =*

Boa tarde,

 

veja se te ajuda este codigo, ele insere varias fotos ao mesmo tempo.

 

Sub Carregar_AutoImagens()
 
    Dim Pict
    Dim ImgFileFormat As String
    Dim Celula As String
    Celula = "A38"    ' celula que será inserido a imagem
    ImgFileFormat = "Image Files JPG (*.jpg),*.jpg, Image Files PNG (*.png),*.jpg, Image Files GIF (*.gif),*.gif, Image Files BMP (*.bmp),*.bmp"
    
    'Pict = Application.GetOpenFilename(ImgFileFormat, False, False, MultiSelect:=True)
    
    Pict = Application.GetOpenFilename(ImgFileFormat, False, False, False, True)
    
    'If Pict = False Then End
    
    If IsArray(Pict) Then 'IF ARRAY
    
        If UBound(Pict) <= 28 Then 'IF I
        
            j = 1
    
            For i = LBound(Pict) To UBound(Pict) 'FOR I
            
                Select Case i 'Cobertura de 32 imagens
                
                    Case 1 To 4
                        'IMAGEM: largura = 30 colunas; altura= 13 linhas
                        Application.ActiveSheet.Shapes.AddPicture Pict(i), False, True, Range(Celula).Left, _
                        Range(Celula).Top, Range(Celula).Width * 3, Range(Celula).Height * 6
                        
                        j = j + 3
                        Celula = Chr(64 + j) & "38"
                                            
                    Case 5 To 8
                    
                        If Mid(Celula, 1, 1) = "M" Then
                            j = 1
                            Celula = Chr(64 + j) & "45"
                        End If
                        'IMAGEM: largura = 30 colunas; altura= 13 linhas
                        Application.ActiveSheet.Shapes.AddPicture Pict(i), False, True, Range(Celula).Left, _
                        Range(Celula).Top, Range(Celula).Width * 3, Range(Celula).Height * 6
                        
                        j = j + 3
                        Celula = Chr(64 + j) & "45"
                    
                    
                    Case 9 To 12
                        If Mid(Celula, 1, 1) = "M" Then
                            j = 1
                            Celula = Chr(64 + j) & "52"
                        End If
                        'IMAGEM: largura = 30 colunas; altura= 13 linhas
                        Application.ActiveSheet.Shapes.AddPicture Pict(i), False, True, Range(Celula).Left, _
                        Range(Celula).Top, Range(Celula).Width * 3, Range(Celula).Height * 6
                        
                        j = j + 3
                        Celula = Chr(64 + j) & "52"
                    
                    Case 13 To 16 '66
                        If Mid(Celula, 1, 1) = "M" Then
                            j = 1
                            Celula = Chr(64 + j) & "66"
                        End If
                        'IMAGEM: largura = 30 colunas; altura= 13 linhas
                        Application.ActiveSheet.Shapes.AddPicture Pict(i), False, True, Range(Celula).Left, _
                        Range(Celula).Top, Range(Celula).Width * 3, Range(Celula).Height * 6
                        
                        j = j + 3
                        Celula = Chr(64 + j) & "66"
                    
                    Case 17 To 20 '73
                       If Mid(Celula, 1, 1) = "M" Then
                            j = 1
                            Celula = Chr(64 + j) & "73"
                        End If
                        'IMAGEM: largura = 30 colunas; altura= 13 linhas
                        Application.ActiveSheet.Shapes.AddPicture Pict(i), False, True, Range(Celula).Left, _
                        Range(Celula).Top, Range(Celula).Width * 3, Range(Celula).Height * 6
                        
                        j = j + 3
                        Celula = Chr(64 + j) & "73"
                    
                    Case 21 To 24 '80
                      If Mid(Celula, 1, 1) = "M" Then
                            j = 1
                            Celula = Chr(64 + j) & "80"
                        End If
                        'IMAGEM: largura = 30 colunas; altura= 13 linhas
                        Application.ActiveSheet.Shapes.AddPicture Pict(i), False, True, Range(Celula).Left, _
                        Range(Celula).Top, Range(Celula).Width * 3, Range(Celula).Height * 6
                        
                        j = j + 3
                        Celula = Chr(64 + j) & "80"
                    
                    Case 25 To 28 '87
                        If Mid(Celula, 1, 1) = "M" Then
                            j = 1
                            Celula = Chr(64 + j) & "87"
                        End If
                        'IMAGEM: largura = 30 colunas; altura= 13 linhas
                        Application.ActiveSheet.Shapes.AddPicture Pict(i), False, True, Range(Celula).Left, _
                        Range(Celula).Top, Range(Celula).Width * 3, Range(Celula).Height * 6
                        
                        j = j + 3
                        Celula = Chr(64 + j) & "87"
 
                End Select
 
            Next i 'FOR I
        
        Else 'IF I
        
            MsgBox "Selecionar apenas 28 imagens"
            End
        
        End If 'IF I
    
    End If 'IF ARRAY
    
    
    'If Pict = False Then End
    'Application.ActiveSheet.Shapes.AddPicture Pict, False, True, Range(Celula).Left, _
    'Range(Celula).Top, Range(Celula).Width * 3, Range(Celula).Height * 6    'IMAGEM: largura = 30 colunas; altura= 13 linhas
End Sub

Compartilhar este post


Link para o post
Compartilhar em outros sites

Bom dia a todos.

Desculpa ressucitar um topico um pouco antigo, mas sou novo aqui no forum e esse topico é exatamente o assunto que preciso para tentar resolver meu problema.

Eu ja tenho a macro feita certinha para inserir as imagens automaticamente onde desejo, porem estou tendo o mesmo problema que a Jessikcaires teve.
 

Citar

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.

Ate tentei inserir o codigo abaixo que o usuario Basole indicou, mas sem sucesso:

Citar

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

Queria sabe se atraves do meu codigo abaixo, eu consigo formata-lo e inserir as imagens no arquivo para que quando a planilha seja aberta em outro computador, ele aparece as imagens.

Citar

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C:C]) Is Nothing Then Exit Sub
If Target.Row Mod 1000 = 0 Then Exit Sub
On Error GoTo son
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(0, 1).Top
Selection.Left = Target.Offset(0, 1).Left
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Target.Offset(0, 1).Height
Selection.ShapeRange.Width = Target.Offset(0, 1).Width
Target.Offset(1, 0).Select
son:

End Sub

 

Editado por kimsurf

Corrigindo o texto para acima da citacao que fiz do meu codigo.

Compartilhar este post


Link para o post
Compartilhar em outros sites
2 horas atrás, kimsurf disse:

Queria sabe se atraves do meu codigo abaixo, eu consigo formata-lo e inserir as imagens no arquivo para que quando a planilha seja aberta em outro computador, ele aparece as imagens.

 

Experimente:

Private Sub Worksheet_Change(ByVal Target As Range)
 If Intersect(Target, [C:C]) Is Nothing Then Exit Sub
 If Target.Row Mod 1000 = 0 Then Exit Sub
 On Error GoTo son

 Application.ActiveSheet.Shapes.AddPicture ThisWorkbook.Path & "\" & _
  Target.Value & ".jpg", False, True, Target.Offset(0, 1).Left, _
    Target.Offset(0, 1).Top, Target.Offset(0, 1).Width, Target.Offset(0, 1).Height

son:

End Sub

 


 

Osvaldo

 

Compartilhar este post


Link para o post
Compartilhar em outros sites

Osvaldomp, boa noite.

Cara, ajudou muito! Era disso mesmo que eu precisava, atualizei aqui e funcionou perfeitamente.

Só uma dúvida: hoje as imagens ficam na mesma pasta do arquivo excel, caso queira criar uma pasta ..\imagens seria possivel?

Se for complicado, não tem problema, porque ocultei todas as imagens (cerca de 500) para nao ficar vendo uma lista imensa.

Att.
Kim

Compartilhar este post


Link para o post
Compartilhar em outros sites
12 horas atrás, kimsurf disse:

Só uma dúvida: hoje as imagens ficam na mesma pasta do arquivo excel, caso queira criar uma pasta ..\imagens seria possivel?
 

Substitua este trecho

ThisWorkbook.Path & "\"

 

por este (altere se a pasta 'imagens' não estiver no drive 'C')

"C:\imagens\"


 

Osvaldo

 

Compartilhar este post


Link para o post
Compartilhar em outros sites
Em 12/08/2016 at 09:55, osvaldomp disse:

Substitua este trecho

ThisWorkbook.Path & "\"

 

por este (altere se a pasta 'imagens' não estiver no drive 'C')

"C:\imagens\"

Osvaldo, funcionou perfeitamente, muito obrigado pela ajuda!

Compartilhar este post


Link para o post
Compartilhar em outros sites

×
×
  • Criar Novo...