VBA Code Adapter to fetch photos from a folder

Navigation
-1

Good afternoon.

I have a macro, which searches a worksheet for the name of the photo (eg IMG0102.JPG), searches the predefined folder for a related photo, and inserts it into the cell that is the name of the photo.

However, I need to update this worksheet every day with new photos, however every time I run the macro it duplicates all the photos I've already inserted. Therefore, you would need this macro to skip each cell with a photo (not to duplicate the ones it already has) and follow only the cells without photos

Here is an example of the spreadsheet:

Hereisthemacrothatlooksforthecellwiththenameofthephotoandsearchesthefolder:

SubInserirFotos()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
    
asked by anonymous 23.05.2017 / 18:34

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 Tip: 

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
    
23.05.2017 / 19:06
0

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

CREATING AND UPDATING LIST OF WINDOWS FOLDER IMAGES.

LINK TO DOWNLOAD THE FULL ARCHIVE: link

'--- 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     
17.10.2018 / 15:39
Compiling a webservice Is there a basic script / code for email marketing?