Prev: Select list box entries in multiple rows?
Next: Macro to copy subtotaled data
From: marc747 on 6 Apr 2010 19:33
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
-----------------------------------------------
From: Peter T on 7 Apr 2010 05:13
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



"marc747" <marc747(a)excite.com> wrote in message
news:04edf68e-1568-49ee-8653-78677f424c8f(a)5g2000yqj.googlegroups.com...
> 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
> -----------------------------------------------


From: Dave Peterson on 7 Apr 2010 08:29
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
From: marc747 on 7 Apr 2010 18:56
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


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


On Apr 7, 2:13 am, "Peter T" <peter_t(a)discussions> wrote:
> 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
>
> "marc747" <marc...(a)excite.com> wrote in message
>
> news:04edf68e-1568-49ee-8653-78677f424c8f(a)5g2000yqj.googlegroups.com...
>
>
>
> > 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
> > ------------------------------------------------ Hide quoted text -
>
> - Show quoted text -

From: Peter T on 8 Apr 2010 08:08
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

"marc747" <marc747(a)excite.com> wrote in message
news:61675848-09eb-4125-8c2e-caa02562fec4(a)q23g2000yqd.googlegroups.com...
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


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


On Apr 7, 2:13 am, "Peter T" <peter_t(a)discussions> wrote:
> 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
>
> "marc747" <marc...(a)excite.com> wrote in message
>
> news:04edf68e-1568-49ee-8653-78677f424c8f(a)5g2000yqj.googlegroups.com...
>
>
>
> > 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
> > ------------------------------------------------ Hide quoted text -
>
> - Show quoted text -


 |  Next  |  Last
Pages: 1 2 3
Prev: Select list box entries in multiple rows?
Next: Macro to copy subtotaled data