Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

Excel macro to import pictures from file

Posted on 2014-01-04
4
Medium Priority
?
1,158 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
  • 2
  • 2
4 Comments
 
LVL 28

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 28

Accepted Solution

by:
MacroShadow earned 2000 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

How to Use the Help Bell

Need to boost the visibility of your question for solutions? Use the Experts Exchange Help Bell to confirm priority levels and contact subject-matter experts for question attention.  Check out this how-to article for more information.

Question has a verified solution.

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

Ever visit a website where you spotted a really cool looking Font, yet couldn't figure out which font family it belonged to, or how to get a copy of it for your own use? This article explains the process of doing exactly that, as well as showing how…
Quickbooks hosting can do wonders to your enterprise but considering the points elaborated in the article which will help you to better analyze the outcomes. So scan your business, its needs and then move to the new world of limitless benefits.
The view will learn how to download and install SIMTOOLS and FORMLIST into Excel, how to use SIMTOOLS to generate a Monte Carlo simulation of 30 sales calls, and how to calculate the conditional probability based on the results of the Monte Carlo …
Visualize your data even better in Access queries. Given a date and a value, this lesson shows how to compare that value with the previous value, calculate the difference, and display a circle if the value is the same, an up triangle if it increased…

971 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