Ir ao conteúdo
  • Cadastre-se
Luciana Goes

Excel RESOLVIDO VBA - Imagem altera se mudar o nome e o local

Posts recomendados

Olá!

Preciso de uma ajuda.

Fiz um código em VBA que busca a imagem no diretório e inclui nas céluas B2:D2. Até aí tudo certo.

O problema é que se eu altero o nome da imagem na pasta ou diretório (ou se mudo a imagem pra outro local), quando abro a planilha ela não aparece mais.

Preciso ajustar esse código pra que, se eu precisar alterar o nome ou mudar a imagem de local ela não altere na que já está inserida no Excel.

Será que alguém poderia me ajudar?

 

Segue o código que eu tenho:

 

Sub INSERE_IMAGEM()
Dim profile As String
    On Error GoTo 0
    Dim fd As FileDialog
    Dim myCel As Range
    Set myCel = ActiveSheet.Range("b2:d2") ' AQUI: Altere a cel. desejada
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    
  Range("B2:D2").Select
    Selection.ClearContents
    
For Each img In ActiveSheet.Shapes
    If Not Application.Intersect(img.TopLeftCell, ActiveSheet.Range("B2:D2")) Is Nothing Then
        img.Delete
    End If
Next

With fd
        .Filters.Clear
        .Filters.Add "Picture Files", "*.jpg"
        .ButtonName = "Select"
        .AllowMultiSelect = False
        .Title = "Choose Photo"
        .InitialView = msoFileDialogViewDetails
        .Show
    End With
ActiveSheet.Range("b2:d2").Select
         On Error Resume Next
    With ActiveSheet.Pictures.Insert(fd.SelectedItems(1))
        I = 17
        .Left = myCel.Left
        .Top = myCel.Top
        .Placement = 1
        .PrintObject = True
        profile = .Name
        .Name = "imagemdalogo"
    End With
 
     ActiveSheet.Pictures(profile).Select
    With Selection.ShapeRange
        .LockAspectRatio = msoFalse
        .Width = myCel.Width
        .Height = myCel.Height
    End With
 
Range("C5").Select
End Sub

 

Compartilhar este post


Link para o post
Compartilhar em outros sites

única forma que penso nesse problema é usando o Recordset com banco de dados Access ou SQL Server pra armazenar a imagem.... não sei como armazenar o valor da imagem no próprio excel, do jeito que você faz é uma referência. Por isso quando muda o nome ou a pasta ele não acha mais. 

Compartilhar este post


Link para o post
Compartilhar em outros sites

@Luciana Goes Em vez de Pictures.Insert você pode usar Shapes.AddPicture e atribuir msoTrue em SaveWithDocument

  • Curtir 1

Compartilhar este post


Link para o post
Compartilhar em outros sites
9 horas atrás, Midori disse:

@Luciana Goes Em vez de Pictures.Insert você pode usar Shapes.AddPicture e atribuir msoTrue em SaveWithDocument

 

Nesse caso eu teria que buscar a imagem num diretório específico?

adicionado 3 minutos depois
10 horas atrás, ray gabriel disse:

única forma que penso nesse problema é usando o Recordset com banco de dados Access ou SQL Server pra armazenar a imagem.... não sei como armazenar o valor da imagem no próprio excel, do jeito que você faz é uma referência. Por isso quando muda o nome ou a pasta ele não acha mais. 

Agradeço pelo retorno.

Na verdade eu precisaria pensar alguma forma que quando a imagem fosse inserida, ela ignorasse o nome e diretório. É como se fosse um copia e cola. Mas te agradeço mesmo assim.

Compartilhar este post


Link para o post
Compartilhar em outros sites

@Luciana Goes O método de busca continua o mesmo,

 

Você só tem que usar outra função para adicionar a imagem, assim.

 Sub INSERE_IMAGEM()
Dim profile As String
    On Error GoTo 0
    Dim fd As FileDialog
    Dim myCel As Range
    Set myCel = ActiveSheet.Range("b2:d2") ' AQUI: Altere a cel. desejada
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    
  Range("B2:D2").Select
    Selection.ClearContents
    
For Each img In ActiveSheet.Shapes
    If Not Application.Intersect(img.TopLeftCell, ActiveSheet.Range("B2:D2")) Is Nothing Then
        img.Delete
    End If
Next

With fd
        .Filters.Clear
        .Filters.Add "Picture Files", "*.jpg"
        .ButtonName = "Select"
        .AllowMultiSelect = False
        .Title = "Choose Photo"
        .InitialView = msoFileDialogViewDetails
        .Show
    End With
ActiveSheet.Range("b2:d2").Select
         On Error Resume Next
         
    ActiveSheet.Shapes.AddPicture fd.SelectedItems(1), _
        msoFalse, msoTrue, myCel.Left, myCel.Top, myCel.Width, myCel.Height

Range("C5").Select
End Sub

 

Compartilhar este post


Link para o post
Compartilhar em outros sites
19 minutos atrás, Midori disse:

@Luciana Goes O método de busca continua o mesmo,

 

Você só tem que usar outra função para adicionar a imagem, assim.


 Sub INSERE_IMAGEM()
Dim profile As String
    On Error GoTo 0
    Dim fd As FileDialog
    Dim myCel As Range
    Set myCel = ActiveSheet.Range("b2:d2") ' AQUI: Altere a cel. desejada
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    
  Range("B2:D2").Select
    Selection.ClearContents
    
For Each img In ActiveSheet.Shapes
    If Not Application.Intersect(img.TopLeftCell, ActiveSheet.Range("B2:D2")) Is Nothing Then
        img.Delete
    End If
Next

With fd
        .Filters.Clear
        .Filters.Add "Picture Files", "*.jpg"
        .ButtonName = "Select"
        .AllowMultiSelect = False
        .Title = "Choose Photo"
        .InitialView = msoFileDialogViewDetails
        .Show
    End With
ActiveSheet.Range("b2:d2").Select
         On Error Resume Next
         
    ActiveSheet.Shapes.AddPicture fd.SelectedItems(1), _
        msoFalse, msoTrue, myCel.Left, myCel.Top, myCel.Width, myCel.Height

Range("C5").Select
End Sub

 

Show!

Perfeito!

Muito obrigada! Era isso mesmo que eu precisava!

 

Compartilhar este post


Link para o post
Compartilhar em outros sites

Crie uma conta ou entre para comentar

Você precisar ser um membro para fazer um comentário

Criar uma conta

Crie uma nova conta em nossa comunidade. É fácil!

Crie uma nova conta

Entrar

Já tem uma conta? Faça o login.

Entrar agora





Sobre o Clube do Hardware

No ar desde 1996, o Clube do Hardware é uma das maiores, mais antigas e mais respeitadas comunidades sobre tecnologia do Brasil. Leia mais

Direitos autorais

Não permitimos a cópia ou reprodução do conteúdo do nosso site, fórum, newsletters e redes sociais, mesmo citando-se a fonte. Leia mais

×
×
  • Criar novo...

Aprenda_a_Ler_Resistores_e_Capacitores-capa-3d-newsletter.jpg

EBOOK GRÁTIS!

CLIQUE AQUI E BAIXE AGORA MESMO!