Notifications
Clear all

Macro para buscar imagem em diretório externo

11 Posts
2 Usuários
0 Reactions
1,921 Visualizações
Zgoda
(@zgoda)
Posts: 88
Trusted Member
Topic starter
 

Boa tarde amigos.

Preciso criar uma macro no excel, para inserir em uma célula "X", POR EXEMPLO a2, uma imagem que está em uma pasta na rede.

É como se fosse pegaro nome que está na célula B3 e procurar este nome em uma pasta com imagens que possuam este nome e inserir a imagem na célula A2.

EX: célula B3 possui: "1123", na célula A2 vai me trazer a imagem do arquivo "1123.jpg" que está na pasta "C:Documentos", como crio uma macro para trazer isso automaticamente ou em várias células, apenas mudando a célula referência para busca.

Desde já agradeço!!

 
Postado : 20/03/2015 11:44 am
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Boa tarde!!

Tente
Na coluna E, colocar os nomes de suas imagens.
Na coluna D, coloque o caminho para as imagens na coluna E.
Na coluna C:
= D4 & "" & E4

Sub NaoTestado()
'Criado por -> Dave Peterson <-...............
Dim myPict As Picture
Dim curWks As Worksheet
Dim myRng As Range
Dim myCell As Range
Dim myPictName As Variant

Set curWks = Sheets("Plan1")

curWks.Pictures.Delete

With curWks
    Set myRng = .Range("C2", .Cells(.Rows.Count, "C").End(xlUp))
End With

For Each myCell In myRng.Cells
    If Trim(myCell.Value) = "" Then
        '...........
    ElseIf Dir(CStr(myCell.Value)) = "" Then
        MsgBox myCell.Value & " Não existe!"
    Else
        With myCell.Offset(0, 3)
            Set myPict = myCell.Parent.Pictures.Insert(myCell.Value)
            myPict.Top = .Top
            myPict.Width = .Width
            myPict.Height = .Height
            myPict.Left = .Left
            myPict.Placement = xlMoveAndSize
        End With
    End If
Next myCell

End Sub

Att

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 20/03/2015 1:01 pm
Zgoda
(@zgoda)
Posts: 88
Trusted Member
Topic starter
 

Deixa eu colocar um exemplo. nas células "imagem" tem que trazer o arquivo com o nome/número do lado

 
Postado : 20/03/2015 1:06 pm
Zgoda
(@zgoda)
Posts: 88
Trusted Member
Topic starter
 

Eu consegui usar a fórmula, porém preciso que a imagem vá automaticamente nas células que estão no campo "imagem" e que esteja no tamanho 150x115 pixels, senão ela vem muito pequena.

 
Postado : 20/03/2015 1:38 pm
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Contribuindo.
Experimente:

Option Explicit
Sub test()
Dim YourPic As Picture
Dim sPath As String, sDir As String, Img As String, ed As String
'Dim myPic As Variant
Dim myrng As Range, cel As Range
sPath = ThisWorkbook.Path 'Altere aqui para o seu caminho
'Acrescenta "" ao caminho se necessario
If Right(sPath, 1) <> "" Then
    sPath = sPath & ""
    Else
    sPath = sPath
End If
Set myrng = Sheets("Arquivos").Range("A1:M18")
'Altera o diretorio de "trabalho" para o caminho sPath
ChDir sPath

sDir = Dir("*.jpg")
Do While sDir <> ""
    Img = Left(sDir, Len(sDir) - 4)
    For Each cel In myrng
        If Img = cel.Value Then
            ed = cel.Offset(0, -2).Address
            
            With ActiveSheet.Range(ed)
                Set YourPic = .Parent.Pictures.Insert(sPath & sDir)
                YourPic.Top = .Top
                YourPic.ShapeRange.LockAspectRatio = msoFalse
                YourPic.ShapeRange.Height = 45.5
                YourPic.ShapeRange.Width = 95.5
                'YourPic.ShapeRange.ScaleWidth 0.45, msoFalse, msoScaleFromTopLeft
                'YourPic.ShapeRange.ScaleHeight 0.45, msoFalse, msoScaleFromTopLeft
                YourPic.Left = .Left
            End With
        End If
    Next
    sDir = Dir
Loop
End Sub

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 20/03/2015 5:27 pm
Zgoda
(@zgoda)
Posts: 88
Trusted Member
Topic starter
 

Aqui vai um exemplo mais detalhado do que preciso.

Reinaldo, não consegui usar seu código, dá erro quando vou tentar compilar no campo em que está o diretório de imagens, não sei se colei errado.

Mas creio que com esse exemplo vocês possam entender mais minha dúvida.

na direita coloquei o caminho e uma fórmula básica para concatenar o caminho e o nome da imagem caso eu use a solução em outras guias, para que todos os nomes das imgens estejam na coluna R.

 
Postado : 23/03/2015 4:32 am
Zgoda
(@zgoda)
Posts: 88
Trusted Member
Topic starter
 

Alguém sabe se existe apenas uma fórmula para realizar essa minha necessidade, ao invés de programação em VBA?

 
Postado : 23/03/2015 1:03 pm
Zgoda
(@zgoda)
Posts: 88
Trusted Member
Topic starter
 

Existe esse código em uma planilha antiga:

Private Sub Pos3_Click()

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
'On Error GoTo Mensagem
Dim cont As Integer

  cont = 1
  Pos1.Picture = LoadPicture(Range("r2").Value)
  
  cont = 2
  Pos2.Picture = LoadPicture(Range("r3").Value)
  
  cont = 3
  Pos3.Picture = LoadPicture(Range("r4").Value)
    
  cont = 4
  Pos4.Picture = LoadPicture(Range("r5").Value)

  cont = 5
  Pos5.Picture = LoadPicture(Range("r6").Value)
  
  cont = 6
  Pos6.Picture = LoadPicture(Range("r7").Value)
  
  cont = 7
  Pos7.Picture = LoadPicture(Range("r8").Value)
  
  cont = 8
  Pos8.Picture = LoadPicture(Range("r9").Value)
  
  cont = 9
  Pos9.Picture = LoadPicture(Range("r10").Value)
  
  cont = 10
  Pos10.Picture = LoadPicture(Range("r11").Value)
  
  cont = 11
  Pos11.Picture = LoadPicture(Range("r12").Value)
  
  cont = 12
  Pos12.Picture = LoadPicture(Range("r13").Value)
  
  cont = 13
  Pos13.Picture = LoadPicture(Range("r14").Value)
  
  cont = 14
  Pos14.Picture = LoadPicture(Range("r15").Value)
  
  cont = 15
  Pos15.Picture = LoadPicture(Range("r16").Value)
  
  cont = 16
  Pos16.Picture = LoadPicture(Range("r17").Value)
  
  cont = 17
  Pos17.Picture = LoadPicture(Range("r18").Value)
  
  cont = 18
  Pos18.Picture = LoadPicture(Range("r19").Value)
  
  cont = 19
  Pos19.Picture = LoadPicture(Range("r20").Value)
  
  cont = 20
  Pos20.Picture = LoadPicture(Range("r21").Value)

End Sub

Se alguém souber como fazer funcionar. como fazer o elo com os campos onde devem ir as imagens.

O botão "editar" não está aparecendo para mim no post, por isso estou postando de novo, desculpem o incômodo.

 
Postado : 23/03/2015 2:24 pm
Zgoda
(@zgoda)
Posts: 88
Trusted Member
Topic starter
 

Pessoal, consegui este código bem simples para usar:

Sub Picture()    
Range("A6").Select 'This is where picture will be inserted    
Dim picname As String    
picname = Range("B6") 'This is the picture name    
ActiveSheet.Pictures.Insert("C:UsersvbayatMy Documentsvidabayatre-market" & picname & ".jpg").Select 'Path to where pictures are stored    
'''''''''''''''''''''''''''''''''''''''''''''''''''''''    
' This resizes the picture    
'''''''''''''''''''''''''''''''''''''''''''''''''''''''    
With Selection    
.Left = Range("A6").Left    
.Top = Range("A6").Top    
.ShapeRange.LockAspectRatio = msoFalse    
.ShapeRange.Height = 100#    
.ShapeRange.Width = 80#    
.ShapeRange.Rotation = 0#    
End With    

Range("A10").Select    
Application.ScreenUpdating = True    

Exit Sub    

ErrNoPhoto:    
MsgBox "Unable to Find Photo" 'Shows message box if picture not found    
Exit Sub    
Range("B20").Select    

End Sub

POrém só cnosegui usar uma vez em uma planilha em branco, quando tento usar na planilha já existente ele dá um erro de excução 1004.

Podem me ajudar?

 
Postado : 24/03/2015 2:31 pm
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Estou em transito no momento, e sem acesso ao excel. se não houver resposta até aproxima segunda (quando retorno) tentarei ver sua demanda.

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 24/03/2015 4:16 pm
Zgoda
(@zgoda)
Posts: 88
Trusted Member
Topic starter
 

Pessoal consegui resolver sozinho aqui, se alguém tiver o mesmo problema é só usar esse código aqui:

Sub Imagem1()

Range("F2").Select 'This is where picture will be inserted
Dim picname As String
picname = Range("R2") 'This is the picture name
ActiveSheet.Pictures.Insert("P:Fotos IMPrimavera 15_16Todos" & picname & ".jpg").Select 'Path to where pictures are stored
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' This resizes the picture
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Selection
.Left = Range("F2").Left
.Top = Range("F2").Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 100#
.ShapeRange.Rotation = 0#
End With

Range("A10").Select
Application.ScreenUpdating = True

Exit Sub

ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
Exit Sub
Range("B20").Select

End Sub

Modificando os valores onde tem F2, R2, a proporção da imagem 100# e a pasta destino, de acordo com sua necessidade.

Valeu pessoal do fórum!

 
Postado : 25/03/2015 11:25 am