Insert Picture Macro

[SamDev]

In a portion of a macro, I would like the macro to open Insert Picture
dialog box and then go to a particular folder - I can get the macro to open
to the My Pictures folder but then I would have to ask user to select a
different folder - I would prefer that the macro selected the folder.

The macro I am using is:

dlgAnswer = Application.Dialogs(xlDialogInsertPicture).Show

Much thanks.

 

[Dave Peterson]

You could get the filename yourself:

Option Explicit
Sub testme02()

Dim myPictureName As Variant
Dim myCurFolder As String
Dim myNewFolder As String

myCurFolder = CurDir
myNewFolder = "C:\my documents\excel"

ChDrive myNewFolder
ChDir myNewFolder

myPictureName = Application.GetOpenFilename _
(filefilter:="Picture Files,*.jpg;*.bmp;*.tif;*.gif")

ChDrive myCurFolder
ChDir myCurFolder

If myPictureName = False Then
Exit Sub 'user hit cancel
End If

'do the real work

End Sub

 

[SamDev]

Dave:

It works except.....

I have other code for resizing etc for the picture and I get error
messages....

The following is my code - the issue is the code
"Selection.ShapeRange.IncrementTop 13" - see complete code below. I don't
know if rest of the code is OK because of the error I get at the
Selection.ShapeRange.IncrementTop 13 line.

Much thanks!


Dim myPictureName As Variant
Dim myCurFolder As String
Dim myNewFolder As String

myCurFolder = CurDir
myNewFolder = "C:\my documents\excel"

ChDrive myNewFolder
ChDir myNewFolder

myPictureName = Application.GetOpenFilename _
(filefilter:="Picture
Files,*.jpg;*.bmp;*.tif;*.gif")

ChDrive myCurFolder
ChDir myCurFolder

If myPictureName = False Then
Exit Sub 'user hit cancel
End If

Dim Center1, Center2 As Double
Selection.Name = ImgName
Selection.ShapeRange.IncrementTop 13
Selection.ShapeRange.LockAspectRatio = True
Selection.Locked = False
If Selection.ShapeRange.Height < Selection.ShapeRange.Width Then
Selection.ShapeRange.Width = 410#
If Selection.ShapeRange.Height > 305# Then
Selection.ShapeRange.Height = 288#
Center1 = (419 - Selection.ShapeRange.Width) / 2
Selection.ShapeRange.IncrementLeft Center1
Center2 = (306 - Selection.ShapeRange.Height) / 2
If Center1 < Center2 Then Center2 = Center1
Selection.ShapeRange.IncrementTop Center2
Else
Wrng = MsgBox("This is a Verticle picture - do you want to set it to
4 inches tall?", _
vbYesNo, "Warning!")
If Wrng = 7 Then
Selection.ShapeRange.Delete
Else
Selection.ShapeRange.Height = 305#
Center1 = (418 - Selection.ShapeRange.Width) / 2
Selection.ShapeRange.IncrementLeft Center1
Center2 = (306 - Selection.ShapeRange.Height) / 2
If Center1 < Center2 Then Center2 = Center1
Selection.ShapeRange.IncrementTop Center2
End If
End If

End Sub

 

[SamDev]

Oops forgot to mention that the code below worked fine in my original code
that only opened the Insert Picture dialog box to the My Pictures folder.

Dave:

It works except.....

I have other code for resizing etc for the picture and I get error
messages....

The following is my code - the issue is the code
"Selection.ShapeRange.IncrementTop 13" - see complete code below. I don't
know if rest of the code is OK because of the error I get at the
Selection.ShapeRange.IncrementTop 13 line.

Much thanks!


Dim myPictureName As Variant
Dim myCurFolder As String
Dim myNewFolder As String

myCurFolder = CurDir
myNewFolder = "C:\my documents\excel"

ChDrive myNewFolder
ChDir myNewFolder

myPictureName = Application.GetOpenFilename _
(filefilter:="Picture
Files,*.jpg;*.bmp;*.tif;*.gif")

ChDrive myCurFolder
ChDir myCurFolder

If myPictureName = False Then
Exit Sub 'user hit cancel
End If

Dim Center1, Center2 As Double
Selection.Name = ImgName
Selection.ShapeRange.IncrementTop 13
Selection.ShapeRange.LockAspectRatio = True
Selection.Locked = False
If Selection.ShapeRange.Height < Selection.ShapeRange.Width Then
Selection.ShapeRange.Width = 410#
If Selection.ShapeRange.Height > 305# Then
Selection.ShapeRange.Height = 288#
Center1 = (419 - Selection.ShapeRange.Width) / 2
Selection.ShapeRange.IncrementLeft Center1
Center2 = (306 - Selection.ShapeRange.Height) / 2
If Center1 < Center2 Then Center2 = Center1
Selection.ShapeRange.IncrementTop Center2
Else
Wrng = MsgBox("This is a Verticle picture - do you want to set it
to 4 inches tall?", _
vbYesNo, "Warning!")
If Wrng = 7 Then
Selection.ShapeRange.Delete
Else
Selection.ShapeRange.Height = 305#
Center1 = (418 - Selection.ShapeRange.Width) / 2
Selection.ShapeRange.IncrementLeft Center1
Center2 = (306 - Selection.ShapeRange.Height) / 2
If Center1 < Center2 Then Center2 = Center1
Selection.ShapeRange.IncrementTop Center2
End If
End If

End Sub

 

[Dave Peterson]

You have to actually do your own inserting of the picture.

I think I'd rather just put the picture in a set range:

Option Explicit
Sub testme02()

Dim myPictureName As Variant
Dim myPict As Picture
Dim myRng As Range
Dim myCurFolder As String
Dim myNewFolder As String

myCurFolder = CurDir
myNewFolder = "C:\my documents\excel"

ChDrive myNewFolder
ChDir myNewFolder

myPictureName = Application.GetOpenFilename _
(filefilter:="Picture Files,*.jpg;*.bmp;*.tif;*.gif")

ChDrive myCurFolder
ChDir myCurFolder

If myPictureName = False Then
Exit Sub 'user hit cancel
End If

With Worksheets("sheet1")
Set myRng = .Range("A1:c5")
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

 

[SamDev]

Ok - much thanks - that makes sense!!

You have to actually do your own inserting of the picture.

I think I'd rather just put the picture in a set range:

Option Explicit
Sub testme02()

Dim myPictureName As Variant
Dim myPict As Picture
Dim myRng As Range
Dim myCurFolder As String
Dim myNewFolder As String

myCurFolder = CurDir
myNewFolder = "C:\my documents\excel"

ChDrive myNewFolder
ChDir myNewFolder

myPictureName = Application.GetOpenFilename _
(filefilter:="Picture
Files,*.jpg;*.bmp;*.tif;*.gif")

ChDrive myCurFolder
ChDir myCurFolder

If myPictureName = False Then
Exit Sub 'user hit cancel
End If

With Worksheets("sheet1")
Set myRng = .Range("A1:c5")
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