This fills L10 vertically with the picture.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

Dim myAspectRatio As Double
Dim myPict As Picture
Dim TestStr As String
Dim mySfx As Variant
Dim sCtr As Long
Dim myPath As String
Dim myFileName As String
Dim FoundIt As Boolean

If Target.Cells.Count 1 Then
Exit Sub
End If

If Intersect(Target, Me.Range("L21")) Is Nothing Then
Exit Sub
End If

'don't check empty cells
If Trim(Target.Value) = "" Then
Exit Sub
End If

mySfx = Array(".jpg", ".gif", ".jpeg", ".bmp")

myPath = "C:\Temp\Pix"
myPath = "U:\My Pictures\2005_01_04"
If Right(myPath, 1) < "\" Then
myPath = myPath & "\"
End If

On Error Resume Next
Me.Shapes("KnownPictureName").Delete
On Error GoTo 0

FoundIt = False
On Error Resume Next 'in case the path is really bad!
For sCtr = LBound(mySfx) To UBound(mySfx)
myFileName = myPath & Target.Value & mySfx(sCtr)
TestStr = ""
TestStr = Dir(myPath & Target.Value & mySfx(sCtr))
If TestStr = "" Then
'keep looking, it wasn't found
Else
FoundIt = True
Exit For 'stop looking
End If
Next sCtr
On Error GoTo 0

If FoundIt = False Then
'what should happen??
Exit Sub
End If

Application.ScreenUpdating = False

Set myPict = Me.Pictures.Insert(myFileName)

With myPict
.Name = "KnownPictureName"
myAspectRatio = .Width / .Height
.ShapeRange.LockAspectRatio = msoTrue
End With

With Target
myPict.Top = .Top
myPict.Left = .Left

myPict.Height = .Height
myPict.Width = myAspectRatio * .Height

If myPict.Width .Width Then
'too wide for the cell
'With the aspectratio locked, the
'reducing the width will reduce the height
myPict.Width = .Width
End If
End With

Application.ScreenUpdating = True

End Sub


marc747 wrote:

Hi,

I have the following Macro but it seems that I need the name of the
picture along with the extension in order to work, is there a way to
include the extensions (.gif, .jpg, .jpeg, and more that I don't
know ........) into the Macro so that I don't need to include the
picture name with the extension.
Thank You.

-----------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myScale As Double
If Target.Address < "$L$21" Then Exit Sub

'Select the cell where the picture is placed
Application.EnableEvents = False
On Error Resume Next
ActiveSheet.Shapes("KnownPictureName").Delete
On Error GoTo 0

Range("L10").Select
'Insert the picture
On Error GoTo NoPic

'this is the one with the link to the file that I need the extension
ActiveSheet.Pictures.Insert("C:\Temp\Pix\" &
Range("L21").Value).Select

GoTo GotPic
NoPic:
ActiveSheet.Pictures.Insert("C:\Temp\Pix\No Pic.jpg").Select
GotPic:
'scale the picture to the width of the column
myScale = 42 / Selection.ShapeRange.Height
Selection.Name = "KnownPictureName"
Selection.ShapeRange.ScaleWidth myScale, msoFalse,
msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight myScale, msoFalse,
msoScaleFromTopLeft
Range("L22").Select

Application.EnableEvents = True
End Sub
-----------------------------------------------

--

Dave Peterson