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

[Luciana Goes]

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
 

[ray gabriel]

ú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. 

[Midori]

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

[Luciana Goes]

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.

[Midori]

@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

 

[Luciana Goes]

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!