Using PastePictureInCell

[mikeymay]

I am using the following code to paste a signature image into a cell

Set shpSig = wsFD.Shapes(strSig)

 shpSig.Copy
         
 Range("Output_SigABStart").Offset((intSig - 1) * 5, 0).PastePictureInCell

This is executed 3 time for 3 different siganture that need to be copied in and is part of a loop of up to 15 set of the 3 signature (min 3, max 45)

The code was debugging sometimes on both the copying of the image and/or the pasting in of the image due to the clipboard being slow so I have tried to use the DoEvents but this hasn't worked.

I don't want to put an Application.Wait in as it may take up to 45 seconds to paste in all the signatures.

This is the full code for the loop

With wsPD
   intCount = .Range("PD_Revision")

   If intCount = 0 Then
      Else
      For intSig = 1 To intCount
         'Prepared by
         strSig = Replace(.Range("PD_PreparedBy").Offset((intSig - 1) * 4, 0), " ", "")
        
         If strSig = "" Then
            Else
            Set shpSig = wsFD.Shapes(strSig)
               
            DoEvents
           
            shpSig.Copy
     
            DoEvents
                
            Range("Output_SigPBStart").Offset((intSig - 1) * 5, 0).PastePictureInCell
         End If
        
         'Checked by
         strSig = Replace(.Range("PD_CheckedBy").Offset((intSig - 1) * 4, 0), " ", "")
        
         If strSig = "" Then
            Else
            Set shpSig = wsFD.Shapes(strSig)
           
            DoEvents
           
            shpSig.Copy
     
            DoEvents
     
            Range("Output_SigCBStart").Offset((intSig - 1) * 5, 0).PastePictureInCell
         End If
        
         'Approved by
         strSig = Replace(.Range("PD_ApprovedBy").Offset((intSig - 1) * 4, 0), " ", "")
        
         If strSig = "" Then
            Else
            Set shpSig = wsFD.Shapes(strSig)
                  
            DoEvents
           
            shpSig.Copy
           
            DoEvents

            Range("Output_SigABStart").Offset((intSig - 1) * 5, 0).PastePictureInCell
         End If
      Next
   End If
End With

As an attempt to resolve I thought the following would work

Set shpSig = wsFD.Shapes(strSig)
               
DoEvents
           
shpSig.Copy
     
DoEvents
           
On Error Resume Next
     
Do Until (Not (Range("Output_SigPBStart").Offset((intSig - 1) * 5, 0) Is Nothing))
     Range("Output_SigPBStart").Offset((intSig - 1) * 5, 0).PastePictureInCell
              
     On Error GoTo 0
Loop

But I can't seem to use this to recognise if there is a 'Picure' in the cell.

TIA

 

[mikeymay]

So I seem to have solved this as follows -

Instread of copying and pasting the image as a Picture In Cell, I am placing the signature image as a Picture In Cell within a table of the names in column A and the singature in image in columns B.

By then establishing the row in the table in which the required signature is held, I can then establish which row in column B holds the required signature image.

You then need to populate the cell to show the required image with a formual that references the specif cell where the image is help. so 'File Data'!B7.

Using the VBA code I create the formula by performing a match on column A to get the row holding the name and then reference column B with the appropriate row.

A bit of a faff and took me some time to work this out but a solution all the same.