Solved

Excel macro to import pictures from file

Posted on 2014-01-04
4
1,009 Views
Last Modified: 2014-01-05
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
Comment
Question by:laskydiver
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 2
  • 2
4 Comments
 
LVL 27

Expert Comment

by:MacroShadow
ID: 39757110
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
 

Author Comment

by:laskydiver
ID: 39757924
MacroShadow
It worked but the images came in full size. is there a way to re-size to something manageable.
0
 
LVL 27

Accepted Solution

by:
MacroShadow earned 500 total points
ID: 39757983
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
 

Author Closing Comment

by:laskydiver
ID: 39758348
Thanks
0

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Microsoft Office Picture Manager was included in Office 2003, 2007, and 2010, but not in Office 2013. Users had hopes that it would be in Office 2016/Office 365, but it is not. Fortunately, the same zero-cost technique that works to install it with …
I was prompted to write this article after the recent World-Wide Ransomware outbreak. For years now, System Administrators around the world have used the excuse of "Waiting a Bit" before applying Security Patch Updates. This type of reasoning to me …
This video walks the viewer through the process of creating envelopes and labels, with multiple names and addresses. Navigate to the “Start Mail Merge” button in the Mailings tab: Follow the step-by-step process until asked to find the address doc…
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…

734 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question