Put a picture in a text box without selecting it?

[Paul B]

Can this be done without selecting the text box? I am using it to put a
picture in a text box, the picture number is in cell G1. Or is there a
better way?

Using Excel 2003

Thanks



Sub ShowPictures()



ActiveSheet.Shapes("Text Box 21").Select

Selection.Characters.Text = ""

With Selection.Font

.Name = "Arial"

.FontStyle = "Regular"

.Size = 10

.Strikethrough = False

.Superscript = False

.Subscript = False

.OutlineFont = False

.Shadow = False

.Underline = xlUnderlineStyleNone

.ColorIndex = xlAutomatic



End With

Selection.ShapeRange.Fill.Transparency = 0#

Selection.ShapeRange.Line.Weight = 0.75

Selection.ShapeRange.Line.DashStyle = msoLineSolid

Selection.ShapeRange.Line.Style = msoLineSingle

Selection.ShapeRange.Line.Transparency = 0#

Selection.ShapeRange.Line.Visible = msoTrue

Selection.ShapeRange.Line.ForeColor.SchemeColor = 64

Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)

Selection.ShapeRange.Fill.Visible = msoTrue

Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 255)

Selection.ShapeRange.Fill.BackColor.RGB = RGB(255, 255, 255)



On Error GoTo NoPic



Selection.ShapeRange.Fill.UserPicture _

Application.DefaultFilePath & "\My Pictures\Carousels" & "\" &
Range("G1").Value & ".jpg"



On Error GoTo 0

Exit Sub



NoPic:

MsgBox Prompt:="No Picture Available", _

Title:="Error Retrieving Picture", _

Buttons:=vbOKOnly

On Error GoTo 0



End Sub

 

[Dave Peterson]

This worked ok for me.

Just a warning...
if that number in G1 that is the name of the file, you may have to format it to
show any leading 0's.

You may need to use something like:
& format(.range("g1").value, "00000") & ".jpg"

Option Explicit
Sub ShowPictures()

Dim TBox As TextBox
Dim myFileName As String
Dim TestStr As String

With ActiveSheet
Set TBox = .TextBoxes("text box 21")
myFileName = Application.DefaultFilePath _
& "\My Pictures\Carousels" & "\" _
& .Range("G1").Value & ".jpg"
End With

With TBox
.Characters.Text = ""
With .Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With

With .ShapeRange
.Fill.Transparency = 0#
.Line.Weight = 0.75
.Line.DashStyle = msoLineSolid
.Line.Style = msoLineSingle
.Line.Transparency = 0#
.Line.Visible = msoTrue
.Line.ForeColor.SchemeColor = 64
.Line.BackColor.RGB = RGB(255, 255, 255)
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Fill.BackColor.RGB = RGB(255, 255, 255)

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

If TestStr = "" Then
MsgBox Prompt:="No Picture Available", _
Title:="Error Retrieving Picture", _
Buttons:=vbOKOnly
Else
.Fill.UserPicture picturefile:=myFileName
End If
End With
End With

End Sub

 

[Paul B]

Dave, thanks for this one also, works fine

This worked ok for me.

Just a warning...
if that number in G1 that is the name of the file, you may have to format
it to
show any leading 0's.

You may need to use something like:
& format(.range("g1").value, "00000") & ".jpg"

Option Explicit
Sub ShowPictures()

Dim TBox As TextBox
Dim myFileName As String
Dim TestStr As String

With ActiveSheet
Set TBox = .TextBoxes("text box 21")
myFileName = Application.DefaultFilePath _
& "\My Pictures\Carousels" & "\" _
& .Range("G1").Value & ".jpg"
End With

With TBox
.Characters.Text = ""
With .Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With

With .ShapeRange
.Fill.Transparency = 0#
.Line.Weight = 0.75
.Line.DashStyle = msoLineSolid
.Line.Style = msoLineSingle
.Line.Transparency = 0#
.Line.Visible = msoTrue
.Line.ForeColor.SchemeColor = 64
.Line.BackColor.RGB = RGB(255, 255, 255)
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Fill.BackColor.RGB = RGB(255, 255, 255)

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

If TestStr = "" Then
MsgBox Prompt:="No Picture Available", _
Title:="Error Retrieving Picture", _
Buttons:=vbOKOnly
Else
.Fill.UserPicture picturefile:=myFileName
End If
End With
End With

End Sub