Improve company productivity with a Business Account.Sign Up

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 1329
  • Last Modified:

Excel macro to import pictures from file

I have a list of picture names in Column A.  I want to import from a folder the images that match the names in Column A and place them in Column B beside the name.


A                                   B
Image Name            Actual Image

There are about 400 of the images. Looking for VBA code to do the import from folder.
0
laskydiver
Asked:
laskydiver
  • 2
  • 2
1 Solution
 
MacroShadowCommented:
Give this a spin:

Option Explicit

Sub Demo()

    Dim rng As Range, cell As Range
    Dim strPicturesPath As String

    ' Set path of Pictures
    strPicturesPath = "C:\Test\"
    ' Set range containing picture names
    Set rng = Range("A1:A100")

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

    On Error Resume Next
    For Each cell In rrng
        InsertPicture strPicturesPath & cell.Value, cell, True, True
    Next

End Sub

Sub InsertPicture(PictureFileName As String, TargetCell As Range, CenterH As Boolean, CenterV As Boolean)
' inserts a picture at the top left position of TargetCell
' the picture can be centered horizontally and/or vertically
    Dim p As Object, t As Double, l As Double, w As Double, h As Double
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    If Dir(PictureFileName) = "" Then Exit Sub
    ' import picture
    Set p = ActiveSheet.Pictures.Insert(PictureFileName)
    ' determine positions
    With TargetCell
        t = .Top
        l = .Left
        If CenterH Then
            w = .offset(0, 1).Left - .Left
            l = l + w / 2 - p.Width / 2
            If l < 1 Then l = 1
        End If
        If CenterV Then
            h = .offset(1, 0).Top - .Top
            t = t + h / 2 - p.Height / 2
            If t < 1 Then t = 1
        End If
    End With
    ' position picture
    With p
        .Top = t
        .Left = l
    End With
    Set p = Nothing
End Sub

Open in new window

0
 
laskydiverAuthor Commented:
MacroShadow
It worked but the images came in full size. is there a way to re-size to something manageable.
0
 
MacroShadowCommented:
Try this:

Option Explicit

Sub Demo()

    Dim rng As Range, cell As Range
    Dim strPicturesPath As String

    ' Set path of Pictures
    strPicturesPath = "C:\Test\"
    ' Set range containing picture names
    Set rng = Range("A1:A100")

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

    On Error Resume Next
    For Each cell In rrng
        InsertPictureInRange strPicturesPath & cell.Value, cell
    Next

End Sub

Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
    Dim p As Object, t As Double, l As Double
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    If Dir(PictureFileName) = "" Then Exit Sub
    ' import picture
    Set p = ActiveSheet.Pictures.Insert(PictureFileName)
    ' determine positions
    With TargetCells
        t = .Top
        l = .Left
    End With
    ' position picture
    With p
        .ShapeRange.LockAspectRatio = msoTrue
        .ShapeRange.Width = 100 ' Adjust to your liking
        .Top = t
        .Left = l
    End With
    Set p = Nothing
End Sub

Open in new window

0
 
laskydiverAuthor Commented:
Thanks
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Get expert help—faster!

Need expert help—fast? Use the Help Bell for personalized assistance getting answers to your important questions.

  • 2
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now