VBA Extract Photos From A Folder in Couple Cell (Couple Photo)

muhammad susanto

Well-known Member
Joined
Jan 8, 2013
Messages
2,077
Office Version
  1. 365
  2. 2021
Platform
  1. Windows
hi expert..
i have macro code to extract photo from a folder..the code actually working well in a single cell down.
i hope someone can modify that code can work to extract photo for double cell or couple photo down
here code
VBA Code:
Sub InsertPictures()
'Update 20140513
Dim PicList() As Variant
Dim PicFormat As String
Dim Rng As Range
Dim sShape As Shape
On Error Resume Next
PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
xColIndex = Application.ActiveCell.Column
If IsArray(PicList) Then
    xRowIndex = Application.ActiveCell.Row
    For lLoop = LBound(PicList) To UBound(PicList)
        Set Rng = Cells(xRowIndex, xColIndex)
        Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
        xRowIndex = xRowIndex + 1
    Next
End If
End Sub

i attach picture from detail information

thank for your help..
.sst
 

Attachments

  • extract_image couple.png
    extract_image couple.png
    69.8 KB · Views: 4

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.
Try this:

VBA Code:
Sub InsertPictures()
  'Update 20140513
  Dim PicList() As Variant, PicFormat As String
  Dim Rng As Range, sShape As Shape
  Dim xColIndex As Long, xRowIndex As Long, lLoop As Long
  '
  On Error Resume Next
  PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
  xColIndex = Application.ActiveCell.Column
  If IsArray(PicList) Then
    xRowIndex = Application.ActiveCell.Row
    For lLoop = LBound(PicList) To UBound(PicList)
      Set Rng = Cells(xRowIndex, xColIndex)
      Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
      If xColIndex = ActiveCell.Column Then
        xColIndex = xColIndex + 1
      Else
        xColIndex = xColIndex - 1
        xRowIndex = xRowIndex + 1
      End If
    Next
  End If
End Sub
 
Upvote 0
I'm glad to help you. Thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,213,531
Messages
6,114,172
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top