Copying Pictures

[Will_Cain]

I know how to navigate round spreadsheets in VBA macros looking for ones that contain certain values or even any value at all but I can't figure out how to do it for embedded pictures and having found one how to copy it via a variable into another sheet, possibly with a new name.
My routine looks down a column of dates and if it finds one it's interested in, wants to get the picture whose name is not known from the adjacent column if it exists, and copy it into another sheet .

The set command seems to need the occurence of the picture

Any clues how to do this?

Regards

[Kenneth Hobs]

I am confused. Are you wanting to copy a Picture object from one sheet to another or use LoadPicture to insert some filename into a picture object. If the later, obviously the filename must exist to do that. The offset part is confusing. Is that the filename or what?

[Aussiebear]

HI Will, Welcome to the Forum. Are you able to assist us better by posting a workbook with some sample data and the required outcome. You know what you want, but we are guessing a little here.

[Will_Cain]

The first column contains a birthday. In the adjacent column is a cell with a picture of the person and his name. I want to generate a calendar that takes the picture, if it exists, and the name and drops it in the cell for the b day. I can do it for the text but I don't know how to get hold of the picture and paste it in the cell

Regards

[Kenneth Hobs]

Add your data to column A on sheet1. Put your picture shapes into column B on sheet1. As I understand it, that is what you have done.

I don't know the other details so I just copied the shapes from column B on sheet1 to column B on sheet2.

The last part of this code copies the shapes in column B to the same cell in sheet2. The 2nd to last loop shows the details of how it works in VBE's Immediate window. You can delete that if you like.

Insert this into a Module:
Sub Sheet1Shapes()
Dim shp As Shape
Dim aRange As Range, c As Range, iRange As Range
Dim a() As String, sAdd As String
Dim p() As Variant, pTL() As Variant
Dim lc As Long

Set aRange = Sheet1.Range("A1", Cells(Rows.Count, "A").End(xlUp))
ReDim p(1 To Sheet1.Shapes.Count)
ReDim pTL(1 To Sheet1.Shapes.Count)

lc = 0
For Each shp In Sheet1.Shapes
lc = lc + 1
Set p(lc) = shp
pTL(lc) = shp.TopLeftCell.Address
Next shp

Set iRange = Intersect(aRange.Offset(0, 1), Sheet1.Range(Join(pTL, ",")))
If iRange Is Nothing Then Exit Sub

'Show the address of the topleft cell of our shapes in column B and the shape's name
For Each c In iRange
Debug.Print c.Address 'Address of the topleftcell for the shape that is column B
lc = WorksheetFunction.Match(c.Address, pTL(), 0)
Debug.Print p(lc).Name
Next c

'Copy the picture's from column B on Sheet1 to the same cell on Sheet2
For Each c In iRange
lc = WorksheetFunction.Match(c.Address, pTL(), 0)
p(lc).Copy
Sheet2.Range(c.Address).PasteSpecial xlFormats
Next c
Application.CutCopyMode = False
End Sub

[Will_Cain]

Thanks for the quick response. I'm trying to understand the implications. Am I right in saying you can't store a picture i.e shape in a variable and simply put it into a cell like you can an integer or string? If that is true the only way appears to be to find the name of the cell with the picture in and then use a glorified copy and paste by cycling down the list of names and locations that you have made

I think I should be able to extend the code to just find the picture I need based on the date in the adjacent column.

Incidently one of my pictures failed to copy properly do you know what is the limit on the size of pictures that can be copied this way?

Regards and thanks again.

[Kenneth Hobs]

I guess it would be limited based on your resources. You can post a sample xls with the problem if you like. If the file is too big, post to a free shared site like 4shared.com, box.net or mediafire.com.

If you have image files, you can always add a picture object and then use LoadPicture() to fill it rather than copy/paste.

[Will_Cain]

I managed to get my picture pasting done totally successfully, thanks very much. There were a couple of funnies. I had renamed the sheets that I was copying from but the lines
ReDim p(1 To Sheet1.Shapes.Count)
ReDim pTL(1 To Sheet1.Shapes.Count)

lc = 0
For Each shp In Sheet1.Shapes

all inserted I reverrt back from my name to the original Sheet name. The renamed name isn't a problem anywhere else in the macro.
and
When I did the Paste special the picture missed by half a cell until I removed the XLFORMAT param.

All in all though I'm totally happy

thanks again