Paste Special Images excel 2010

[lorryx3]

Hi,

I'm sorry if this has already been answered - I tried searching but couldn't find an answer.

I found a macro on the internet that automatically pastes images from a folder into column A of my workbook. (I work in publishing and am creating a catalogue with ISBNs in Column B, all the images are in one folder with the ISBNs as the title).

Anyway it works fine - except when i need to send this onto someone who doesn't have the images saved in a folder on their desktop. Then they appear as broken links. When originally setting up the macro i tried a share drive folder but it didn't work.

Is there a way to paste special the images so they aren't linked to the folder? I've tried right clicking but it pastes as one giant image. I also need the images to be locked to cells in order to filter. The other issue with one giant image is for some reason it becomes a giant sized image - even when i try to compress.

I'm using excel 2010 with XP.

Hopefully that makes sense! I'll paste the code i found on the internet tomorrow at work - sorry i don't have it here.

Any help would be greatly appreciated!

Thanks,
Lauren

 

[pbornemeier]

Welcome to the Board!

Excel can paste images into the workbook or link to a file. Please provide the code you are using now and it can be modified. The size of the pasted image will default to the original size of the saved image. If you don't need it in the large size, then use an image manipulation program to reduce it to the smallest allowable size. This will make a significant difference in the size of the saved file. Even if you want to save the larger image to allow it to be shown, it can be made to appear smaller in Excel.

As far as I know, images cannot be "locked" into a particular cell, although it can be pasted with a given cell in its upper left corner and set to move with cells as they are moved. Images fully within a cell will be hidden if that cell is filtered

 

[lorryx3]

Thanks for the speedy reply!

By locking the images to cell i meant making them move with cells - sorry in my head they are locked to the cell in that they are hidden when the row is hidden.

The code i'm using is:

Sub Picture()
Dim picname As String

Dim pasteAt As Integer
Dim lThisRow As Long

lThisRow = 2

Do While (Cells(lThisRow, 2) <> "")


pasteAt = lThisRow
Cells(pasteAt, 1).Select 'This is where picture will be inserted


picname = Cells(lThisRow, 2) 'This is the picture name

present = Dir("C:\Documents and Settings\usmitl2\Desktop\Images\" & picname & ".jpg")

If present <> "" Then

ActiveSheet.Pictures.Insert("C:\Documents and Settings\usmitl2\Desktop\Images\" & picname & ".jpg").Select 'Path to where pictures are stored
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' This resizes the picture
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Selection
'.Left = Range("A1").Left
'.Top = Range("A1").Top
.Left = Cells(pasteAt, 1).Left
.Top = Cells(pasteAt, 1).Top

.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 130#
.ShapeRange.Rotation = 0#
End With



Else
Cells(pasteAt, 1) = "No Picture Found"
End If

lThisRow = lThisRow + 1
Loop

Range("A10").Select
Application.ScreenUpdating = True

Exit Sub

ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
Exit Sub
Range("B20").Select

End Sub

 

[pbornemeier]

I have modified the code a bit. Please let me know how this works:

Option Explicit

Sub PastePicture()
    'Read names in column B, Paste those pictures into column A
    
    Dim picname As String
    Dim pasteAt As Integer
    Dim lThisRow As Long
    Dim lLastCellWithData As Long
    Dim vPresent As Variant
    Dim sNotFound As String
    
    Application.ScreenUpdating = False
    
    Const sngMaxWidth As Single = 200 ' The maximum width of an image in pixels
    Const sngMaxHeight As Single = 120 'the maximum height of an image in pixels
    Const sngRowHeightToColumnWidth = 5 'Row height of 50 is about the same distance as a column wifth of 10
    
    'Adjust column width to sngMaxWidth
    'Column.ColumnWidth is measured in average character width; Column.Width is measured in pixels
    Columns(1).ColumnWidth = 1 + ((sngMaxWidth + 1) * (Columns(1).ColumnWidth / Columns(1).Width))
    
    lThisRow = 2
    Do While (Cells(lThisRow, "B") <> "") 'Names of pictures in column B
    
    
        pasteAt = lThisRow
        Cells(pasteAt, 1).Select 'This is where picture will be inserted
        
        picname = Cells(lThisRow, 2).Value 'This is the picture name
        
        'Clear picture or previous values from cell where picture will be pasted
        On Error Resume Next 'in case there is no picture with that name
        ActiveSheet.Shapes(picname).Delete
        On Error GoTo 0
        Cells(pasteAt, 1).Value = 0
        
        vPresent = Dir("D:\Documents and Settings\All Users\Documents\My Pictures\Sample Pictures\" & picname & ".jpg")
        
        If vPresent <> "" Then
        
            Rows(pasteAt).RowHeight = sngMaxHeight + 1 'Set row to 1 pixel over max specified height
            ActiveSheet.Pictures.Insert("C:\Documents and Settings\usmitl2\Desktop\Images\" & picname & ".jpg").Select 'Path to where pictures are stored
            ActiveSheet.Pictures.Insert("D:\Documents and Settings\All Users\Documents\My Pictures\Sample Pictures\" & picname & ".jpg").Select 'Path to where pictures are stored
            'An inserted picture becomes the selected item
            
            '''''''''''''''''''''''''''''''''''''''''''''''''''''''
            ' This resizes the picture to fit within the cell
            '''''''''''''''''''''''''''''''''''''''''''''''''''''''
            With Selection
                .ShapeRange.LockAspectRatio = msoTrue 'or pictures will be distorted
                .ShapeRange.Rotation = 0#
                If .Width > 130 Then .Width = 130 'measured in pixels
                If .Height > 100 Then .Height = 100 'measured in pixels
                Cells(pasteAt, 1).RowHeight = .Height + 1 'Set row to 1 pixel over picture height
                
                .Left = Cells(pasteAt, 1).Left
                .Top = Cells(pasteAt, 1).Top
                .Name = picname
              
            End With
        
        Else
            Cells(pasteAt, 1) = "No Picture Found"
            sNotFound = sNotFound & picname & "(" & pasteAt & "), "
        End If
        
        lThisRow = lThisRow + 1
    Loop
    
    If sNotFound <> vbNullString Then
        MsgBox "These pictures (which should have been pasted in the row in parenthesis) could not be found:" & vbLf & vbLf & sNotFound
    End If
    
End_Sub:

    Range("A10").Select
    Application.ScreenUpdating = True
    
End Sub

 

[lorryx3]

Thanks for trying to fix my problem!

I've tried your updated code but when i just copy and paste a warning comes up because of this clause:

If sNotFound <> vbNullString Then
MsgBox "These pictures (which should have been pasted in the row in parenthesis) could not be found:" & vbLf & vbLf & sNotFound
End If

When i change this part of the code:
vPresent = Dir("D:\Documents and Settings\All Users\Documents\My Pictures\Sample Pictures\" & picname & ".jpg") to

vPresent = Dir("C:\Documents and Settings\usmitl2\Desktop\Images\" & picname & ".jpg")

This error comes up:
Run-time error '1004':
Unable to get the Insert property of the Pictures class
and highlights:
ActiveSheet.Pictures.Insert("D:\Documents and Settings\All Users\Documents\My Pictures\Sample Pictures\" & picname & ".jpg").Select 'Path to where pictures are stored

i then tried two of the same lines:
ActiveSheet.Pictures.Insert("C:\Documents and Settings\usmitl2\Desktop\Images\" & picname & ".jpg").Select 'Path to where pictures are stored

This inserts pictures - but twice one sized and one full sized. i've emailed it to other people and the images appear as broken links.

I've tried to play around with the code but i can't get it to work sorry! Basically i just want to be able to insert pictures easily (note some of the images need to be repeated within the spreadsheet) and then send this document onto others to be able to view.

Hopefully that makes sense!

Thanks

 

[pbornemeier]

I apologize. I left a few of my test lines in the code I sent you. Before I correct that, a few questions:

Q1. Is this directory where your pictures are stored? "C:\Documents and Settings\usmitl2\Desktop\Images\"
Q2. Are the names in column B simply the ISBN, or is there a file extension on it? 0-8044-2957-X or 0-8044-2957-X.png)
Q3. Are all of the pictures .jpg?
Q4. What is the max size that you want for the pasted images?
Q5. Is there a typical aspect ratio for all of the pictures, or does it vary from picture to picture?

 

[lorryx3]

Sorry i was just copying and pasting your code - I really don't know what it all means so i was trying to figure it out!

The images are stored in C:\Documents and Settings\usmitl2\Desktop\Images\. but i also have them on the work share drive - but that didn't work either. i think different people have different share drive names i.e. K:\ S:\.

Column B is just the ISBN - but i can change it to be 9781740338813.jpg if that is easier?

All the images are jpg - I manually changed them all when i had the original code and it just said .jpg (the majority were already .jpg!)

Max size - about an inch square so just a thumbnail? i have a link in another column to the full size image on the share drive. But in terms of kb i was going to compress all the images to 96 ppi in order to make the overall file smaller.

Some of the images are landscape and some are portrait - it's book covers so that makes it tricky. but i want them to all fit in the same size cell square. I can manually make some covers more retangle and others square.

Thanks again!

 

[pbornemeier]

This warning

If sNotFound <> vbNullString Then
MsgBox "These pictures (which should have been pasted in the row in parenthesis) could not be found:" & vbLf & vbLf & sNotFound
End If

shows any names listed that were not matched with a file

Try this version:

Option Explicit

Sub PastePicture()
    'Read names in column B, Paste those pictures into column A
    
    Dim picname As String
    Dim pasteAt As Integer
    Dim lThisRow As Long
    Dim lLastCellWithData As Long
    Dim vPresent As Variant
    Dim sNotFound As String
    
    Application.ScreenUpdating = False
    
    Const sngMaxWidth As Single = 60 ' The maximum width of an image in pixels
    Const sngMaxHeight As Single = 60 'the maximum height of an image in pixels
    Const sImageDirectory As String = "C:\Documents and Settings\usmitl2\Desktop\Images\" 'for lorryx3
    'Const sImageDirectory As String = "C:\Users\Public\Pictures\Sample Pictures\" 'for Phil
    
    'Adjust column width to sngMaxWidth
    Columns(1).ColumnWidth = 1 + ((sngMaxWidth + 1) * (Columns(1).ColumnWidth / Columns(1).Width))
    'Column.ColumnWidth is measured in average character width; Column.Width is measured in pixels
    
    lThisRow = 2
    Do While (Cells(lThisRow, "B") <> "") 'There is a name in column B of lThisRow
        
        pasteAt = lThisRow
        Cells(pasteAt, 1).Select 'This is where picture will be inserted
        
        picname = Cells(lThisRow, 2).Value 'This is the picture name
        
        

        On Error Resume Next 'in case there is no picture with that name
        ActiveSheet.Shapes(picname).Delete 'Clear picture with that name
        On Error GoTo 0
        Cells(pasteAt, 1).Value = vbNullString 'clear text from cell where picture will be pasted
        vPresent = Dir(sImageDirectory & picname & ".jpg")
        
        If vPresent <> "" Then
        
            Rows(pasteAt).RowHeight = sngMaxHeight + 1 'Set row to 1 pixel over max specified height
            
            ActiveSheet.Pictures.Insert(sImageDirectory & picname & ".jpg").Select
            'The inserted picture becomes the selected item
            
            '''''''''''''''''''''''''''''''''''''''''''''''''''''''
            ' This resizes the picture to fit within the cell
            '''''''''''''''''''''''''''''''''''''''''''''''''''''''
            With Selection
                .ShapeRange.LockAspectRatio = msoTrue 'or pictures will be distorted
                .ShapeRange.Rotation = 0#
                If .Width > sngMaxWidth Then .Width = sngMaxWidth 'measured in pixels
                If .Height > sngMaxHeight Then .Height = sngMaxHeight 'measured in pixels
                Cells(pasteAt, 1).RowHeight = .Height + 1 'Set row to 1 pixel over picture height
                
                .Left = Cells(pasteAt, 1).Left
                .Top = Cells(pasteAt, 1).Top
                .Name = picname
              
            End With
        
        Else
            Cells(pasteAt, 1) = "No Picture Found"
            sNotFound = sNotFound & picname & "(" & pasteAt & "), "
        End If
        
        lThisRow = lThisRow + 1
    Loop
    
    If sNotFound <> vbNullString Then
        MsgBox "These pictures (which should have been pasted in the row in parenthesis) could not be found:" & vbLf & vbLf & sNotFound, , "Filenames for which files could not be found"
    End If
    
End_Sub:

    Range("A10").Select
    Application.ScreenUpdating = True
    
End Sub

 

[lorryx3]

The new code loads the images perfectly - however when i email it to someone the images still appear as broken links. It says file no longer at that location.

Ideally I want to be able to send this on to other people in the office for their use. Is that even possible?

 

[pbornemeier]

Please run the following code with the sheet where the pictures were pasted as the active sheet 'before' you change the previous code I sent you. Then check the immediate window in the VBA editor (Alt+F11 to show editor, Ctrl+G to toggle immediate window) and let me know what numbers appear to the right of the picture names.

Sub ShowShapeType()
    Dim s As Shape
    For Each s In ActiveSheet.Shapes
        Debug.Print s.Name, s.Type
    Next
End Sub

13 would be a picture
10 would be a link

This code is modified and will ensure the pictures to be saved in the worksheet with no link to the source image:

Option Explicit

Sub PastePicture()
    'Read names in column B, Paste those pictures into column A
    
    Dim picname As String
    Dim pasteAt As Integer
    Dim lThisRow As Long
    Dim lLastCellWithData As Long
    Dim vPresent As Variant
    Dim sNotFound As String
    Dim oTempImage As Object, oPermImage As Object
    
    Application.ScreenUpdating = False
    
    Const sngMaxWidth As Single = 60 ' The maximum width of an image in pixels
    Const sngMaxHeight As Single = 60 'the maximum height of an image in pixels
    'Const sImageDirectory As String = "C:\Documents and Settings\usmitl2\Desktop\Images\" 'for lorryx3
    'Const sImageDirectory As String = "C:\Users\Public\Pictures\Sample Pictures\" 'for Phil
    Const sImageDirectory As String = "D:\Documents and Settings\All Users\Documents\My Pictures\Sample Pictures\" 'for Phil
    
    'Adjust column width to sngMaxWidth
    Columns(1).ColumnWidth = 1 + ((sngMaxWidth + 1) * (Columns(1).ColumnWidth / Columns(1).Width))
    'Column.ColumnWidth is measured in average character width; Column.Width is measured in pixels
    
    lThisRow = 2
    Do While (Cells(lThisRow, "B") <> "") 'There is a name in column B of lThisRow
        
        pasteAt = lThisRow
        Cells(pasteAt, 1).Select 'This is where picture will be inserted
        
        picname = Cells(lThisRow, 2).Value 'This is the picture name

        On Error Resume Next 'in case there is no picture with that name
        ActiveSheet.Shapes(picname).Delete 'Clear picture with that name
        On Error GoTo 0
        Cells(pasteAt, 1).Value = vbNullString 'clear text from cell where picture will be pasted
        vPresent = Dir(sImageDirectory & picname & ".jpg")
        
        If vPresent <> "" Then
            
            Rows(pasteAt).RowHeight = sngMaxHeight + 1 'Set row to 1 pixel over max specified height
            
            'Next line sometimes (always?) inserts a link, rather
            'ActiveSheet.Pictures.Insert(sImageDirectory & picname & ".jpg").Select
            
            'To ensure picture, not link
            Set oTempImage = ActiveSheet.Pictures.Insert(sImageDirectory & picname & ".jpg") 'To get original picture size
            Set oPermImage = ActiveSheet.Shapes.AddPicture(sImageDirectory & picname & ".jpg", msoFalse, msoTrue, _
                0, 0, oTempImage.Width, oTempImage.Height)
            oTempImage.Delete
            
            With oPermImage
            
                '''''''''''''''''''''''''''''''''''''''''''''''''''''''
                ' This resizes the picture to fit within the cell
                '''''''''''''''''''''''''''''''''''''''''''''''''''''''
                .LockAspectRatio = msoTrue 'or pictures will be distorted
                .Rotation = 0#
                If .Width > sngMaxWidth Then .Width = sngMaxWidth 'measured in pixels
                If .Height > sngMaxHeight Then .Height = sngMaxHeight 'measured in pixels
                Cells(pasteAt, 1).RowHeight = .Height + 1 'Set row to 1 pixel over picture height
                
                .Left = Cells(pasteAt, 1).Left
                .Top = Cells(pasteAt, 1).Top
                .Name = picname
                
            End With
        
        Else
            Cells(pasteAt, 1) = "No Picture Found"
            sNotFound = sNotFound & picname & "(" & pasteAt & "), "
        End If
        
        lThisRow = lThisRow + 1
    Loop
    
    If sNotFound <> vbNullString Then
        MsgBox "These pictures (which should have been pasted in the row in parenthesis) could not be found:" & vbLf & vbLf & sNotFound, , "Filenames for which files could not be found"
    End If
    
End_Sub:

    Range("A10").Select
    Application.ScreenUpdating = True
    
End Sub

Please run ShowShapeType again and let me know about the numbers in the 'after' images as well.