Place Picture Code was working now isn't?

[kramer]

Hi Guys, first timer here, I have been working with VBA for about 3 weeks now and have poached some awesome codes from around the net to do some awesome things to my file, one of the codes that I managed to manipulate to get a picture to show in several different locations based on what a cell content is, i.e. company name = company logo throughout the file, the picture is being imported from a folder. Now this was working well when I was using the initial data validation box to select the company name but now that I have learnt so much in the 3 weeks I have gotten addicted to the coolness of VBA and am now using an initial form (userform1) that displays upon opening the file and walks you through the processes, this is now where the new data validation combo box lives.... it's control source is still the original cell so the data in the original cell does change according to the combo box selection but the code doesn't work anymore..... I hope I haven't rambled on too much.... ok here's the code in the worksheet...

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, Range("rngDisplayName")) Is Nothing Then
InsertPicFromFile _
strFileLoc:=Worksheets("Data").Range("rngFileLocation").Value, _
rDestCells:=Worksheets("Quote Form").Range("rngPicDisplayCells"), _
blnFitInDestHeight:=True, _
strPicName:="MyDVPic" 'quote pg1
End If
If Not Intersect(Target, Range("rngDisplayName")) Is Nothing Then
InsertPicFromFile _
strFileLoc:=Worksheets("Data").Range("rngFileLocation").Value, _
rDestCells:=Worksheets("Quote Form").Range("rngPicDisplayCells1"), _
blnFitInDestHeight:=True, _
strPicName:="MyDVPic1" 'quote pg2
End If
If Not Intersect(Target, Range("rngDisplayName")) Is Nothing Then
InsertPicFromFile _
strFileLoc:=Worksheets("Data").Range("rngFileLocation").Value, _
rDestCells:=Worksheets("Quote Form").Range("rngPicDisplayCells2"), _
blnFitInDestHeight:=True, _
strPicName:="MyDVPic2" 'quote pg2
End If
If Not Intersect(Target, Range("rngDisplayName")) Is Nothing Then
InsertPicFromFile _
strFileLoc:=Worksheets("Data").Range("rngFileLocation").Value, _
rDestCells:=Worksheets("Contract").Range("PicDisplayCells"), _
blnFitInDestHeight:=True, _
strPicName:="MyDVPic3" 'contract pg 1
End If
If Not Intersect(Target, Range("rngDisplayName")) Is Nothing Then
InsertPicFromFile _
strFileLoc:=Worksheets("Data").Range("rngFileLocation").Value, _
rDestCells:=Worksheets("Contract").Range("PicDisplayCells1"), _
blnFitInDestHeight:=True, _
strPicName:="MyDVPic4" 'contract pg 2
End If
If Not Intersect(Target, Range("rngDisplayName")) Is Nothing Then
InsertPicFromFile _
strFileLoc:=Worksheets("Data").Range("rngFileLocation").Value, _
rDestCells:=Worksheets("Contract").Range("PicDisplayCells2"), _
blnFitInDestHeight:=True, _
strPicName:="MyDVPic5" 'contract pg 3
End If
End Sub


And here is the module it works with.....

Sub InsertPicFromFile( _
strFileLoc As String, _
rDestCells As Range, _
blnFitInDestHeight As Boolean, _
strPicName As String)

Dim oNewPic As Shape
Dim oNewPic1 As Shape
Dim shtWS As Worksheet

Set shtWS = rDestCells.Parent

On Error Resume Next
'Delete the named picture (if it already exists)
shtWS.Shapes(strPicName).Delete

On Error Resume Next
With rDestCells
'Create the new picture
'(arbitrarily sized as a square that is the height of the rDestCells)
Set oNewPic = shtWS.Shapes.AddPicture( _
Filename:=strFileLoc, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=.Left + 1, Top:=.Top + 1, Width:=.Height - 1, Height:=.Height - 1)

'Maintain original aspect ratio and set to full size
oNewPic.LockAspectRatio = msoTrue
oNewPic.ScaleHeight Factor:=1, RelativeToOriginalSize:=msoTrue
oNewPic.ScaleWidth Factor:=1, RelativeToOriginalSize:=msoTrue

If blnFitInDestHeight = True Then
'Resize the picture to fit in the destination cells
oNewPic.Height = .Height - 1

End If

'Assign the desired name to the picture
oNewPic.Name = strPicName


End With 'rCellDest


End Sub


Can anyone help?

 

[kramer]

anyone?

 

[kramer]

My apologies to all, I have found the error.... I had inserted extra columns on the sheet that the code referenced for the picture file location therefore returning a blank cell. Code is fine user is a clown!!