Creating a Photo Catalog from a Folder of Photos

I have come accorss an article on Excel Tips website explaining how to incorporate images in Excel documents. To view the original article which explains the code and the limitations involved you can  click here. I do recommend visiting that site where you can subscribe for daily or weekly tips. The artiicles are very clear and educational. If you would like to polish your excel skills they have cheap electronic books for sale.

I copies the VBA for my own future use. The code assumes that there is a folder with the thumbnails and a folder with the images, and loops through the the list to get the images.

Sub PhotoCatalog()

  Dim i As Double
  Dim xPhoto As String
  Dim sLocT As String
  Dim sLocP As String
  Dim sPattern As String
  sLocT = "c:\Photos\Thumbnails\"
  sLocP = "c:\Photos\"
  sPattern = sLocT & "*.jpg"
 
  Application.EnableEvents = False
  Application.ScreenUpdating = False
 
  Range("A1").Select
  ActiveCell.FormulaR1C1 = "Description"
  Range("B1").Select
  ActiveCell.FormulaR1C1 = "Thumbnail"
  Range("C1").Select
  ActiveCell.FormulaR1C1 = "Hyperlink"
  Range("A1:C1").Select

  With Selection.Font
    .Name = "Arial"
    .FontStyle = "Bold"
    .Size = 12
    .ColorIndex = xlAutomatic
  End With

  With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .Weight = xlMedium
    .ColorIndex = xlAutomatic
  End With

   i = 1
  On Error GoTo 0
  xPhoto = Dir(sPattern, vbNormal)
  Do While xPhoto <> ""
    i = i + 1
    Range("B" & i).Select
    ActiveSheet.Pictures.Insert(sLocT & xPhoto).Select
    With Selection.ShapeRange
      .LockAspectRatio = msoTrue
      .Height = 54#
      .PictureFormat.Brightness = 0.5
      .PictureFormat.Contrast = 0.5
      .PictureFormat.ColorType = msoPictureAutomatic
    End With

    Range("C" & i).Select
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, _
    Address:= sLocP & xPhoto, TextToDisplay:=xPhoto
    xPhoto = Dir
  Loop

  Application.EnableEvents = True
  Application.ScreenUpdating = True

End Sub