Cross posted
http://www.eileenslounge.com/viewtop...292701#p292701
hi expert..
this macro code below working properly to insert picture from a folder with one by one select picture
i want to modified so macro work with criteria:
1. can insert picture from a folder with multiple select picture and insert to multiple cell at once
2. pictures can inserted automatically consecutive/sequentially placing into target cell (target cell are random) with name of file picture are random --> (main option)
3. if point #2 impossible to do it , to insert automatically consecutive can use name of file picture or based on name pictures like e.g. photo1, photo2,photo3, photo4, or whatever name's file picture etc....> (secondary option)
here code
Code:
Sub InsertPicture() Const cBorder As Double = 5 ' << change as required
Dim vPicture As Variant, pic As Shape
vPicture = Application.GetOpenFilename("Pictures (*.gif; *.jpg; *.jpeg; *.tif), *.gif; *.jpg; *.jpeg; *.tif", , "Select Picture to Import")
If vPicture = False Then Exit Sub
Set pic = ActiveSheet.Shapes.AddPicture(Filename:=vPicture, LinkToFile:=False, SaveWithDocument:=True, _
Left:=ActiveCell.MergeArea.Left + cBorder, Top:=ActiveCell.MergeArea.Top + cBorder, Width:=-1, Height:=-1)
With pic
.LockAspectRatio = False ' << change as required
If Not .LockAspectRatio Then
.Width = ActiveCell.MergeArea.Width - (2 * cBorder)
.Height = ActiveCell.MergeArea.Height - (2 * cBorder)
Else
If .Width >= .Height Then
.Width = ActiveCell.MergeArea.Width - (2 * cBorder)
Else
.Height = ActiveCell.MergeArea.Height - (2 * cBorder)
End If
End If
.Placement = xlMoveAndSize
End With
Set pic = Nothing
End Sub
any help, greatly appreciated..
susanto
Bookmarks