Insert Picture using Macro

[marc747]

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
-----------------------------------------------

 

[Peter T]

Just for what you are doing you don't need the name at all (though you might
want to give it a name and store it for some future process)

Dim shr As ShapeRange

'code

Set shr = activesheet.Pictures.Insert(filename).ShapeRange

now replace all "Selection.ShapeRange" with "shr"

Hmm, had anther glance at your code, not sure I quite follow what you aiming
to do overall. If the above is not enough revert back and explain.

Regards,
Peter T

 

[Dave Peterson]

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]

Hi,

The code did not work.
Basically what I use the code for is that I have in Cell "L21" a
Validation List with Picture names and every time I select a name from
the list the picture in cell "L9" changes and insert the picture with
the name on the list that I selected and incase there is no picture
with the name that I selected it will insert a default picture called
"Picture_not_Available.jpg"

The thing is that I don't want the name of the pictures on my list to
show the picture file name with the file extension, therefore I wanted
to make a change in the Macro that I have so that it will look for the
picture by name only no mater what the file extension is.

Thanks,

Armond


*******************************************************

 

[Peter T]

Well the sample code I suggested does work, though it may not with your
implementation of it.

From what I understand, I'd suggest you maintain a Lookup table somewhere,
perhaps on a hidden sheet or columns.

UserDisplayName : FileName
Green Apples : grnApples.jpg
Pink Roses : pnkRoses.jpg
unknown : Picture_not_Available.jpg


' warning air-code !
s = Range("L9" ).text

arr = range("fileList").value ' where fileList refers to the lookup table

For i = 1 to ubound(arr)
if s = arr(i,1) then
sFile = arr(i,2)
ExitFor
end If
Next

ifLen(sFile) = 0 then
sFile = Picture_not_Available.jpg
end if
pos = InStrRev(sFile, ".")
sPicName = Left$(sFile, pos - 1)

on error resume next
Set shr = activesheet.Pictures(sPicName).ShapeRange
on error goto 0

if shr is nothing then
sFile = thisworkbook.path & "\" & sFile
Set shr = activesheet.Pictures.Insert(sFile).ShapeRange
End if

shr.name = sPicName

etc ' change properties of shr for location, size etc

Regards,
Peter T

Hi,

The code did not work.
Basically what I use the code for is that I have in Cell "L21" a
Validation List with Picture names and every time I select a name from
the list the picture in cell "L9" changes and insert the picture with
the name on the list that I selected and incase there is no picture
with the name that I selected it will insert a default picture called
"Picture_not_Available.jpg"

The thing is that I don't want the name of the pictures on my list to
show the picture file name with the file extension, therefore I wanted
to make a change in the Macro that I have so that it will look for the
picture by name only no mater what the file extension is.

Thanks,

Armond


*******************************************************

 

[marc747]

Hi,

The first Code is working but not the way that I can use. The last one
I can't make it work.

Is it possible the keep my original codes most of it as is and only
add a few lines of code so that instead of the macro looking for the
picture by name and extension to only look for the name of the picture
file by name only no matter what the extension is. I appreciate your
help....

Thanks

 

[Peter T]

I don't follow what you are asking in addition to what I already suggested.
Try and explain the logic of how you want to get from a file name to the
name of a picture, eg, did you already name the picture as that of the
filename without the extension.

Better still, describe why you cannot use the "first" code and you cannot
make the "last" one work. Not sure what you mean by first and last, there
was only one set of code.

Regards,
Peter T

Hi,

The first Code is working but not the way that I can use. The last one
I can't make it work.

Is it possible the keep my original codes most of it as is and only
add a few lines of code so that instead of the macro looking for the
picture by name and extension to only look for the name of the picture
file by name only no matter what the extension is. I appreciate your
help....

Thanks

 

[marc747]

Hi,
Yes, my file names are without file extensions. I have the file names
in a validation list in Cell "L21" and everytime that I pick a file
name from that list the picture in cell "L9" changes and if no picture
is availbale for that file name a default picture is inserted "C:
\mypictures\Picture_not_Available.jpg".

Thanks.

 

[Peter T]

I am finding all this very difficult to understand. Do you mean -

a) the file-names themselves do not have an extension, or
b) do you mean the file-names do have an extension but you removed the
extensions from the list that papers in cells.

I think I already assume the shapes do not have extensions.

Are all the files in the same folder or different folders, where is/are the
path(s) stored.

Regards,
Peter T

Hi,
Yes, my file names are without file extensions. I have the file names
in a validation list in Cell "L21" and everytime that I pick a file
name from that list the picture in cell "L9" changes and if no picture
is availbale for that file name a default picture is inserted "C:
\mypictures\Picture_not_Available.jpg".

Thanks.

 

[marc747]

Hi,
Sorry for that, I just have hard time explaining....

The actual picture files have extensions most of which are ".jpg" some
".gif"
All pictures are in the same folder "C:\mypictures\
Default picture "C:\mypictures\Picture_not_Available.jpg"
The file names that I entered in Excel are without extensions,
example: actual picture name "138-58798.jpg" name entered in excel
"138-58798"

Thanks.

 

[Peter T]

OK. If you only store "138-58798 how will you know in future if it refers to
138-58798.jpg or 138-58798.gif

If it's no problem to store 138-58798.jpg in the cell visible to user,
before adding the picture to the sheet do something like this

Dim pos As Long
Dim sFile As String, sPicName As String

sFile = "138-58798.jpg"
pos = InStrRev(sFile, ".")
sPicName = Left$(sFile, pos - 1)

Apply sPicName as the name of the newly inserted picture. Later when you
want to check if the picture exists, use the same code to convert the name
in the cell (with the extension) from the name of the possible inserted
picture

On error resume next
Set pic = Activesheet.Pictures(sPicName)
on Error goto 0

If pic is nothing then
' code to insert a picture
Else
' code to reformat the picture
End if

If you do not want the extension to be visible in the list to your users,
you will need to include a separate Lookup table along the lines of my first
suggestion.

Regards,
Peter T




Hi,
Sorry for that, I just have hard time explaining....

The actual picture files have extensions most of which are ".jpg" some
".gif"
All pictures are in the same folder "C:\mypictures\
Default picture "C:\mypictures\Picture_not_Available.jpg"
The file names that I entered in Excel are without extensions,
example: actual picture name "138-58798.jpg" name entered in excel
"138-58798"

Thanks.