Insert Picture Macro

  • Thread starter Thread starter SamDev
  • Start date Start date
S

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


SamDev said:
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
Click to expand...
 
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
 
Ok - much thanks - that makes sense!!


Dave Peterson said:
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
Click to expand...
 
Back
Top