Insert picture

[brownti via OfficeKB.com]

I am using the following code and it works, but i would like to make a couple
changes to it that i am not sure how to do. The first thing is that i plan
on using the same code for numerous different ranges. so i was thinking that
i would have 5 different buttons on my sheet and when i click the first
button it would set the range to be used, set the picture to be used and then
run the below macro using the variables that the first macro set. For
example:

Sub pictureone()
Dim myPictureName As Variant
Dim myRng As Range
myPictureName = "I:\Shop drawings\Doors\Raised panel\belmont.jpg"
With ActiveSheet
Set myRng = .Range("e16:f20")
End With
If myPictureName = False Then
Exit Sub 'user hit cancel
End If
Call pictureinsert
End Sub

Public Sub pictureinsert()
Dim myPict As Picture
With ActiveSheet
Set myPict = .Pictures.Insert(myPictureName)
myPict.top = myRng.top
myPict.Width = myRng.Width
myPict.Height = myRng.Height
myPict.Left = myRng.Left
myPict.Placement = xlMoveAndSize
End With
End Sub


Any thoughts on how i can make this work would be appreciated. Thanks

 

[Dave Peterson]

Maybe you can turn the portion of code that does the real work into a
function--and just pass it what it needs to do the work.

I'm not sure how you're going to get the 5 different ranges and pictures, but
maybe this will give you an idea:

Option Explicit
Sub pictureone()
Dim myPictureName As String
Dim myRng As Range
Dim InsertOk As Boolean

myPictureName = "I:\Shop drawings\Doors\Raised panel\belmont.jpg"

With ActiveSheet
Set myRng = .Range("e16:f20")
End With

InsertOk = PictureInsert(myRng, myPictureName)
If InsertOk = False Then
MsgBox myPictureName & " failed"
End If

End Sub
Function PictureInsert(myRng As Range, myPictName As String) As Boolean

Dim TestStr As String
Dim myPict As Picture

TestStr = ""
On Error Resume Next
TestStr = Dir(myPictName)
On Error GoTo 0

PictureInsert = False
If TestStr = "" Then
'do nothing
Else
With myRng.Parent 'the worksheet that owns the range
On Error Resume Next
Set myPict = .Pictures.Insert(myPictName)
If Err.Number <> 0 Then
Err.Clear
Else
myPict.Top = myRng.Top
myPict.Width = myRng.Width
myPict.Height = myRng.Height
myPict.Left = myRng.Left
myPict.Placement = xlMoveAndSize
PictureInsert = True
End If
On Error GoTo 0
End With
End If

End Function

 

[brownti via OfficeKB.com]

That works, but the picture isnt resizing to fill the cells. It is just
cutting off the edges and giving just part of the picture.

Maybe you can turn the portion of code that does the real work into a
function--and just pass it what it needs to do the work.

I'm not sure how you're going to get the 5 different ranges and pictures, but
maybe this will give you an idea:

Option Explicit
Sub pictureone()
Dim myPictureName As String
Dim myRng As Range
Dim InsertOk As Boolean

myPictureName = "I:\Shop drawings\Doors\Raised panel\belmont.jpg"

With ActiveSheet
Set myRng = .Range("e16:f20")
End With

InsertOk = PictureInsert(myRng, myPictureName)
If InsertOk = False Then
MsgBox myPictureName & " failed"
End If

End Sub
Function PictureInsert(myRng As Range, myPictName As String) As Boolean

Dim TestStr As String
Dim myPict As Picture

TestStr = ""
On Error Resume Next
TestStr = Dir(myPictName)
On Error GoTo 0

PictureInsert = False
If TestStr = "" Then
'do nothing
Else
With myRng.Parent 'the worksheet that owns the range
On Error Resume Next
Set myPict = .Pictures.Insert(myPictName)
If Err.Number <> 0 Then
Err.Clear
Else
myPict.Top = myRng.Top
myPict.Width = myRng.Width
myPict.Height = myRng.Height
myPict.Left = myRng.Left
myPict.Placement = xlMoveAndSize
PictureInsert = True
End If
On Error GoTo 0
End With
End If

End Function

I am using the following code and it works, but i would like to make a couple
changes to it that i am not sure how to do. The first thing is that i plan

[quoted text clipped - 34 lines]

Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.aspx/excel-programming/200707/1

 

[Dave Peterson]

It worked ok for me.

You sure your picture is ok?

That works, but the picture isnt resizing to fill the cells. It is just
cutting off the edges and giving just part of the picture.

Maybe you can turn the portion of code that does the real work into a
function--and just pass it what it needs to do the work.

I'm not sure how you're going to get the 5 different ranges and pictures, but
maybe this will give you an idea:

Option Explicit
Sub pictureone()
Dim myPictureName As String
Dim myRng As Range
Dim InsertOk As Boolean

myPictureName = "I:\Shop drawings\Doors\Raised panel\belmont.jpg"

With ActiveSheet
Set myRng = .Range("e16:f20")
End With

InsertOk = PictureInsert(myRng, myPictureName)
If InsertOk = False Then
MsgBox myPictureName & " failed"
End If

End Sub
Function PictureInsert(myRng As Range, myPictName As String) As Boolean

Dim TestStr As String
Dim myPict As Picture

TestStr = ""
On Error Resume Next
TestStr = Dir(myPictName)
On Error GoTo 0

PictureInsert = False
If TestStr = "" Then
'do nothing
Else
With myRng.Parent 'the worksheet that owns the range
On Error Resume Next
Set myPict = .Pictures.Insert(myPictName)
If Err.Number <> 0 Then
Err.Clear
Else
myPict.Top = myRng.Top
myPict.Width = myRng.Width
myPict.Height = myRng.Height
myPict.Left = myRng.Left
myPict.Placement = xlMoveAndSize
PictureInsert = True
End If
On Error GoTo 0
End With
End If

End Function

I am using the following code and it works, but i would like to make a couple
changes to it that i am not sure how to do. The first thing is that i plan

[quoted text clipped - 34 lines]

Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.aspx/excel-programming/200707/1

 

[brownti via OfficeKB.com]

My bad, picture got clipped...

Thanks for the assistance.

It worked ok for me.

You sure your picture is ok?

That works, but the picture isnt resizing to fill the cells. It is just
cutting off the edges and giving just part of the picture.

[quoted text clipped - 64 lines]