insert only the first 4 images from folder

[c_skytte]

Hi,

First of all;
In a VBA worksheet i have defined 4 cells by the names: Picture1, Picture2, Picture3 and Picture4.

In a folder I have 10 pictures, all JPG.

I'd like to take the first 4 pictures from that folder and place in the cells Picture1, Picture2, Picture3 and Picture4 (the names of the imported pictures may vary).
The pictures have to fit the cell by import (I guess imageWidth As Double and imageHeight as Double could be used, but i just can't figure it out!) which means the cell can't get any bigger height/width by import.
By import the pictures should be centered in the cell.

Secondly;
If the folder one day contain 0 pictures the import should be skipped, but if only 2 pictures are placed in the folder; the cells Picture3 and 4, should be left empty.

Thanks!

[c_skytte]

Guess I've done something wrong here ... I guess it's because i haven’t added any coding... :think:

But here is the "non-working" attempt, done by picking up lines on the net.




Dim FileBIL As Shape
Dim imageWidth As Double
Dim imageHeight As Double
Dim FilepointPathBIL As String
Dim FilepointBIL As String


Sheets("Ark1").Select

FilepointPathBIL = Range("S" & (ActiveCell.Row)).Value & "\Pictures\"
'With Worksheets("Report").Cells(Picture1)
FilepointBIL = Dir(FilepointPathBIL & "*.jpg")
Sheets("Report").Select
'Set FileBIL = ActiveSheet.Picture.Insert(Picture1)
Set FileBIL = FilepointBIL
imageWidth = 100
imageHeight = 50



FileBIL.LockAspectRatio = msoFalse
FileBIL.Width = imageWidth
FileBIL.Height = imageHeight


'End With

[georgiboy]

Perhaps the below would help, it will import the first 4 pictures it finds in a folder and centers them in a cell next to their file name:

Sub AddPIC()
Dim fPath As String, fso As Object, lFiles As Object, nFiles As Long
Dim fls As Object, x As Long, sPath As String, c As Long

fPath = "C:\Users\jbloggs\Desktop\test" ' <<< change to suit (image folder)

Set fso = CreateObject("Scripting.FileSystemObject")
nFiles = fso.GetFolder(fPath).Files.Count
Set lFiles = fso.GetFolder(fPath).Files

Columns("B").ColumnWidth = 100
Columns("B").RowHeight = 50

For Each fls In lFiles
If x < 5 Then
sPath = fPath & "\" & Trim(fls.Name)
If sPath <> "" Then
If (InStr(1, sPath, "jpg", vbTextCompare) > 1 _
Or InStr(1, sPath, "jpeg", vbTextCompare) > 1 _
Or InStr(1, sPath, "gif", vbTextCompare) > 1 _
Or InStr(1, sPath, "png", vbTextCompare) > 1) Then
c = c + 1
Range("A" & c).Value = fls.Name
Range("B" & c).Activate
Call insert(sPath, c)
End If
End If
End If
x = x + 1
Next
End Sub


Function insert(PicPath, c)
With ActiveSheet.Pictures.insert(PicPath)
With .ShapeRange
.LockAspectRatio = msoTrue
.Height = 50
End With
.Left = Range("B" & c).Left + (Range("B" & c).Width - .ShapeRange.Width) / 2
.Top = Range("B" & c).Top + (Range("B" & c).Height - .ShapeRange.Height) / 2
.Placement = 1
.PrintObject = True
End With
End Function

Hope this helps

[c_skytte]

I'll check and test! Thanks for the reply!