VBA Code Adaptation to fetch photos from a folder

Asked

Viewed 2,049 times

-1

Good afternoon.

I have a macro, which searches a spreadsheet for the name of the photo (e.g., IMG0102.JPG), searches a predefined folder for the related photo and inserts it into the cell that bears the name of the photo.

However, I need to update this spreadsheet every day with new photos, however every time I run the macro it duplicates all the photos I had already inserted. Therefore, I would need this macro to skip each cell with photo (not to duplicate the ones you already have) and proceed only to the cells without photos

The following is an example of the spreadsheet:

inserir a descrição da imagem aqui

Follow the macro that looks for the cell with the name of the photo and looks in the folder:

    Sub InserirFotos()
imgpasta = "xxxxxxxxx\" ' caminho da pasta das fotos

For i = 2 To 1000 'Numero das Linhas ' inicio e fim para inserir fotos
For j = 28 To 35 'Numero das Colunas ' inicio e fim das colunas de onde estao os nomes das fotos

        imgleft = ActiveSheet.Cells(i, j).Left
        imgtop = ActiveSheet.Cells(i, j).Top
        imgwidth = ActiveSheet.Cells(i, j).Width
        imgheight = ActiveSheet.Cells(i, j).Height
        imagem = Trim(ActiveSheet.Cells(i, j).Value)

    If imagem <> "" Then
    If Dir(imgpasta + imagem) <> "" Then
        ActiveSheet.Shapes.AddPicture imgpasta + imagem, True, True, imgleft, imgtop, imgwidth, imgheight
    End If
    End If

Next j
Next i

    ActiveSheet.Shapes.SelectAll
    Selection.Placement = xlMoveAndSize

End Sub
  • Behold this answer

  • My dear, I’m a little busy here and I haven’t looked at the code, but as you said it was working, it would be easier for you to create a new column like Statues, and when recording the image this column gets a value between 0 and 1. Where 0 has no photo and 1 has photo. When analyzing the code to record the photos check the status first and then insert the photo. Try it there, in case I can’t, I’ll take a look at the code.

  • Good morning Kevin Valente, I created the code for you, I hope for sure. Obs.: I tried to put the code here, but I had some problems with the code, so I prefer to insert the download link. CREATING AND UPDATING LIST OF IMAGES FROM WINDOWS FOLDER. FILE DOWNLOAD LINK: https://drive.google.com/open?id=1poR5-FSLko3-AcHKrHxQKAG9u9BYg5Bm inserir a descrição da imagem aqui

  • You should always put the code directly in your answer, because if that link breaks, in the future your answer will no longer be useful.

  • I tried to put it, but Stackoverflow’s own page confuses what is code with comments, mixes lines of code and removes lines of code and becomes a writing on the page. That’s why I posted the link. But, if you can solve this problem or show me how to fix the code here.

  • After entering the code in your text you can select all the lines of code and click the button { } (Code sample), or you can also manually add 4 spaces at the beginning of each line of code, so the editor will already know that the snippet is code, and will do the proper formatting. Or, if you can’t, put wrong anyway, then someone edits your message to tidy up the formatting.

  • Please read how to edit code and edit your reply

Show 2 more comments

2 answers

0

All your files are passing through here:

If imagem <> "" Then
    If Dir(imgpasta + imagem) <> "" Then
        ActiveSheet.Shapes.AddPicture imgpasta + imagem, True, True, imgleft, imgtop, imgwidth, imgheight
    End If
End If

Quick suggestion:

If imagem <> "" Then

        If Len(Dir(imgpasta + imagem, vbDirectory) & "") = 0 Then

            ActiveSheet.Shapes.AddPicture imgpasta + imagem, True, True, imgleft, imgtop, imgwidth, imgheight

        End If

    End If
  • Good afternoon, friend. Replace with your suggestion, however do not pull the photos from the folder. Know what can be?

  • Just so you understand, it’s a list that tells you which images are in the folder?

  • The macro inserts the images according to cell naming within the selected matrix.

0

I created the code for you, I hope it works.

CREATING AND UPDATING IMAGE LIST FROM WINDOWS FOLDER.

LINK TO DOWNLOAD THE COMPLETE FILE: https://drive.google.com/open?id=1poR5-FSLko3-AcHKrHxQKAG9u9BYg5Bm

inserir a descrição da imagem aqui

'--- INSERINDO E ALTERANDO FOTOS  
'--- by [email protected]  
'--- versão 1.0  }

Option Explicit  
Public Cod         As String  
Public UCell       As Range  
Public Nome1       As String  
Public Nome2       As String  
Public strFolder   As String  
Public strFileName As String  
Public objPic      As Picture  
Public rngCell     As Range  
Public CPasta      As String  

Sub InserirImagens()

    Set UCell = Range("E1048576").End(xlUp)

    [E2].Select
    Nome1 = ActiveCell.Value

    CPasta = [A2].Value 'Caminho das fotos  
    strFolder = CPasta '"C:\Users\Jean Braga\Desktop\EXCEL IMAGENS\" 'altere o caminho para onde estão as imagens

    If Right(strFolder, 1) <> "\" Then
        strFolder = strFolder & "\"
    End If

    strFileName = Dir(strFolder & "*.jpg", vbNormal) 'arquivos jpg

    If Nome1 = "" Then
        PrimeiraFoto

    Else

    Do While Len(strFileName) > 0
        Selection.Offset(1, 0).Select
        strFileName = Dir
        Nome1 = ActiveCell.Value
        If Nome1 = "" Then
            Nome2 = strFileName
            strFileName = ActiveCell.Value
        End If

    Loop

    Selection.Offset(-1, -1).Select
    Cod = ActiveCell.Value
    Selection.Offset(1, 0).Select
    ActiveCell.Value = Cod + 1
    Selection.Offset(0, 1).Select
    ActiveCell.Value = Nome2
    Selection.Offset(0, 1).Select

    strFileName = Nome2

    If strFileName = "" Then
        MsgBox "FOTOS ATUALIZADAS"
        Selection.Offset(0, -2).Select
        ActiveCell.Value = ""
        Exit Sub

    End If

    Set objPic = ActiveSheet.Pictures.Insert(strFolder & strFileName)
    With objPic
        .ShapeRange.Top = ActiveCell.Top
        .ShapeRange.Left = ActiveCell.Left
        .ShapeRange.Height = 12.5
        .ShapeRange.Width = 23

    End With

    strFileName = Dir

    Do While Len(strFileName) > 0
        [D2].Select
        Set UCell = Range("D1048576").End(xlUp)
        UCell.Select
        Cod = ActiveCell.Value
        Selection.Offset(1, 0).Select
        ActiveCell.Value = Cod + 1
        Selection.Offset(0, 1).Select
        ActiveCell.Value = strFileName
        Selection.Offset(0, 1).Select

        Set objPic = ActiveSheet.Pictures.Insert(strFolder & strFileName)
        With objPic
            .ShapeRange.Top = ActiveCell.Top
            .ShapeRange.Left = ActiveCell.Left
            .ShapeRange.Height = 12.5
            .ShapeRange.Width = 23

        End With

        strFileName = Dir
    Loop

    End If

End Sub  

Function PrimeiraFoto()  

    ActiveCell.Value = strFileName
    Selection.Offset(0, -1).Select
    ActiveCell.Value = "1"
    Selection.Offset(0, 2).Select

    If strFileName = "" Then
        MsgBox "FOTOS ATUALIZADAS"
        Selection.Offset(0, -2).Select
        ActiveCell.Value = ""
        'Exit Sub

    End If  

    Set objPic = ActiveSheet.Pictures.Insert(strFolder & strFileName)
    With objPic
        .ShapeRange.Top = ActiveCell.Top
        .ShapeRange.Left = ActiveCell.Left
        .ShapeRange.Height = 12.5
        .ShapeRange.Width = 23

    End With  

    strFileName = Dir  

    Do While Len(strFileName) > 0
        [D2].Select
        Set UCell = Range("D1048576").End(xlUp)
        UCell.Select
        Cod = ActiveCell.Value
        Selection.Offset(1, 0).Select
        ActiveCell.Value = Cod + 1
        Selection.Offset(0, 1).Select
        ActiveCell.Value = strFileName
        Selection.Offset(0, 1).Select  

        Set objPic = ActiveSheet.Pictures.Insert(strFolder & strFileName)
        With objPic
            .ShapeRange.Top = ActiveCell.Top
            .ShapeRange.Left = ActiveCell.Left
            .ShapeRange.Height = 12.5
            .ShapeRange.Width = 23

        End With  

        strFileName = Dir  

    Loop  
End Function  

Browser other questions tagged

You are not signed in. Login or sign up in order to post.