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]

Be sure to comment out the reference to my directory:
Const sImageDirectory As String = "D:\Documents and Settings\All Users\Documents\My Pictures\Sample Pictures\" 'for Phil

and uncomment yours:
Const sImageDirectory As String = "C:\Documents and Settings\usmitl2\Desktop\Images\" 'for lorryx3

 

[lorryx3]

It works! It really works! Thank you so much!

Originally the Show Shape type was 11 but after I ran the new code it is 13.

Now to push your patience - a lot of the images need to be repeated, is there a way to paste them every time an ISBN appears? or is is just like using a vlookup and it only sees the ISBN once.

Don't stress too much about the extra bit - i can just copy and paste.

Thanks again!
Lauren[FONT=&quot]
<o></o>[/FONT]

 

[pbornemeier]

Working on it

 

[pbornemeier]

Type 11 is a linked picture; type 13 is a picture.

Added some code to automatically delete all images on the active sheet before the individual images are inserted. Also added the line number to the picture name on the image. Now duplicated ISBNs in column B will result in duplicate pictures in the corresponding cell in column A.

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
    Dim shp As Shape
    
    'Delete all shapes in the active worksheet
    For Each shp In ActiveSheet.Shapes
      shp.Delete
    Next
    
    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 & "_" & CStr(lThisRow)).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 & "_" & CStr(lThisRow)
                
            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]

Wow you are amazing! Thank you so much. That does everything I want it to do!

You've actually made me like excel!

Thanks again.