insert multiple random images

[AkaTrouble]

Hello

I would like to ask spreadsheet user to select a folder on hard drive (using folder picker maybe), then scan this folder including any sub-folders for any image files e.g. .jpg .png

then to select at random an image and place it in a range sized to that range. to complete this a number of times (lets say 12) and pasting selected random image in a separate range insuring it is not a duplicate of any image already pasted.

if possible i would like to be able to exclude some files from possible selection if they contain certain text (example "back" "folder" using wild cards maybe so back1 back2 etc are excluded)

if there is not enough images to complete loop then duplicate should be allowed

i already have a piece of code to insert an image into a sized range which i have pasted below only in the possibility it may help not in an attempt to offer solution to part of my own question

Sub insert_pic()

On Error GoTo GetOut

ActiveSheet.Pictures.Delete

Dim myPicture As Picture 'embedded pic
Set myPicture = ActiveSheet.Pictures.Insert(Range("C32").Value)
myPicture.Width = Range("F2:H30").Width
myPicture.Top = Range("F2").Top
myPicture.Left = Range("F2").Left

GetOut:

End Sub

hope i have explained well and thank you for reading

 

[AkaTrouble]

as no answer i have now asked on another site insert multiple random images

i will report back here if any solution offered

 

[Kenneth Hobson]

It is nice to see that you know courtesy rules for cross-posts.

I suspect that you had no replies on excelforum or this one yet because you asked for so many things in one post. Sometimes, it is better to use one thread per goal or concept. Change column A and the row column sizes to suit.

You seem to be asking for:
1. Let user pick a folder.
2. Batch processing files.
3. Limit searches for files.
4. Do not include some files with a prefix.
5. Random sort picture files.
6. Embed, not link, picture files.

First, add this to a module or include with code that follows in the same module.

'Set extraSwitches, e.g. "/ad", to search folders only.
'MyDir should end in a "\" character unless searching by wildcards, e.g. "x:\test\t*
'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
  Optional tfSubFolders As Boolean = False) As Variant
  
  Dim s As String, a() As String, v As Variant
  Dim b() As Variant, i As Long
  
  If tfSubFolders Then
    s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
      """" & myDir & """" & " /b /s " & extraSwitches).StdOut.ReadAll
    Else
    s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
      """" & myDir & """" & " /b " & extraSwitches).StdOut.ReadAll
  End If
  
  a() = Split(s, vbCrLf)
  If UBound(a) = -1 Then
    Debug.Print myDir & " not found."
    Exit Function
  End If
  ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr
  
  For i = 0 To UBound(a)
    If Not tfSubFolders Then
      s = Left$(myDir, InStrRev(myDir, "\"))
      'add the folder name
      a(i) = s & a(i)
    End If
  Next i
  aFFs = sA1dtovA1d(a)
End Function

Function sA1dtovA1d(strArray() As String) As Variant
  Dim varArray() As Variant, i As Long
  ReDim varArray(LBound(strArray) To UBound(strArray))
  For i = LBound(strArray) To UBound(strArray)
    varArray(i) = CVar(strArray(i))
  Next i
  sA1dtovA1d = varArray()
End Function

The comments in MainEmbed() should explain how the other concepts were used. Change 11 as needed if you want a maximum of 12 pics. Change the default folder C:\myfiles\pics2 to suit. It should be evident how to add more pic types like tif, tiff, bmp, gif, etc.

Sub MainEmbed()
  Dim fldr$, aJPG, aPNG, aPics, i&, c As Range, s As Shape
  
  'Get folder name:
  fldr = Get_Folder("C:\myfiles\pics2", "Select Pics Root Folder")
  If fldr = "" Then Exit Sub
  fldr = fldr & Application.PathSeparator
  
  'Make aPics array:
  aJPG = aFFs(fldr & "*.jpg", "/A:-D", True)
  aPNG = aFFs(fldr & "*.png", "/A:-D", True)
  If IsArray(aJPG) Then aPics = aJPG
  If IsArray(aPNG) Then
    For i = 0 To UBound(aPNG)
      ReDim Preserve aPics(UBound(aPics) + 1)
      aPics(UBound(aPics)) = aPNG(i)
    Next i
  End If
  If Not IsArray(aPics) Then Exit Sub
  aPics = Filter(aPics, "back", False, vbTextCompare) 'not case sensitive
  If Not IsArray(aPics) Then Exit Sub
  'MsgBox Join(aPics, vbLf): Exit Sub
  
  'Random sort aPics array:
  FYShuffle aPics
  'MsgBox Join(aPics, vbLf): Exit Sub
  
  'Resize aPics array, 0 based so redim one less for total pics.
  If UBound(aPics) > 11 Then ReDim Preserve aPics(11) '12 pics total
  
  'Resize cells and embed file:
  Columns("A").ColumnWidth = 16
  Set c = Cells(Rows.Count, "A").End(xlUp).Offset(1)
  For i = 0 To UBound(aPics)
    Rows(c.Row).RowHeight = 50
    Set s = ActiveSheet.Shapes.AddPicture _
      (aPics(i), msoFalse, msoTrue, _
        c.Left, c.Top, c.Width, c.RowHeight) 'embed files
    s.LockAspectRatio = False
    'With ActiveSheet.Pictures.Insert(aPics(i)) 'link files
    '  .ShapeRange.LockAspectRatio = False
    '  .Width = c.Width
    '  .Height = c.RowHeight
    '  .Top = c.Top
    '  .Left = c.Left
    'End With
    Set c = c.Offset(1)
  Next i
End Sub
 
Function Get_Folder(Optional FolderPath As String, _
  Optional HeaderMsg As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If FolderPath = "" Then
          .InitialFileName = Application.DefaultFilePath
          Else
          .InitialFileName = FolderPath
        End If
        .Title = HeaderMsg
        If .Show = -1 Then
            Get_Folder = .SelectedItems(1)
        Else
            Get_Folder = ""
        End If
    End With
End Function

'shg, https://www.mrexcel.com/forum/excel-questions/986723-run-x-number-random-draws-calculate-totals-against-pre-defined-set.html#post4735639
Sub FYShuffle(av As Variant)
  ' shg 2015
  
  ' In-situ Fisher-Yates shuffle of 1D array av
  ' VBA only

  Dim iLB           As Long
  Dim iTop          As Long
  Dim vTmp          As Variant
  Dim iRnd          As Long

  iLB = LBound(av)
  iTop = UBound(av) - iLB + 1

  Do While iTop
    iRnd = Int(Rnd * iTop)
    iTop = iTop - 1
    vTmp = av(iTop + iLB)
    av(iTop + iLB) = av(iRnd + iLB)
    av(iRnd + iLB) = vTmp
  Loop
End Sub

 

[AkaTrouble]

It i

Thank you for reply .. it will take me a little while to work with your provided code so i will comment back later.

i totally agree with you it was a big ask and had several separate parts, I would not have been disappointed without any replies as I have learned so much and had lots of help Here.

I made post straight up in full in order not to fall into the trap of answering my own question or offering a solution when asking a question. Every project I tackle seems to only yield more confirmation of how much i do not know and how much more Excel can do often beyond even the designers intent.

i apologise if it came across that i was being lazy and asking for a complete multi part solution for an entire complicated problem, which technically i was, I do really appreciate any help offered and i do study solutions offered and find how and why they work, I keep a Snippets list and use this to try and help others on the forums yes i only tackle the simpler questions and often simply translate question into a more understandable form to yield assistance from others.

having taken so called qualifications in excel to join here and learn that i was only an amateur was a surprise, as it turns out a pleasant one as Excel is so much more powerful than they teach. This forum i believe has advanced me to intermediate level which i shall have to remain at as so many possibilities have been opened up to be learned.

again Thank You for your help and i will report bak once i have had some time with it.

Regards

 

[AkaTrouble]

I

have had a play with code and it does seem to tick most of boxes that i asked for, some clever methods included to, I have made few changes / tweaks for my own need and still absorbing it.

you have managed to provide the majority of what i was after, Therefore i Thank You Very Very much.

will be several days of trial and error for my exact needs and to learn how it works and why

Many Thanks again

regards

 

[AkaTrouble]

just to follow up if anyone is interested

i modified the code to display images 3 wide and four deep and changed start point of first image to fixed cell reference. I did this to allow images to appear in a fixed area as i wanted other info around them.

the edited code is below (old code simply commented out)

Sub MainEmbed()
  Dim fldr$, aJPG, aPNG, aPics, i&, j&, c As Range, s As Shape
  
  'Get folder name:
  fldr = Get_Folder("C:", "Select Pics Root Folder")
  If fldr = "" Then Exit Sub
  fldr = fldr & Application.PathSeparator
  
  'Make aPics array:
  aJPG = aFFs(fldr & "*.jpg", "/A:-D", True)
  aPNG = aFFs(fldr & "*.png", "/A:-D", True)
  If IsArray(aJPG) Then aPics = aJPG
  If IsArray(aPNG) Then
    For i = 0 To UBound(aPNG)
      ReDim Preserve aPics(UBound(aPics) + 1)
      aPics(UBound(aPics)) = aPNG(i)
    Next i
  End If
  If Not IsArray(aPics) Then Exit Sub
  aPics = Filter(aPics, "back", False, vbTextCompare) 'not case sensitive
  aPics = Filter(aPics, "album", False, vbTextCompare)
  aPics = Filter(aPics, "cd", False, vbTextCompare)
  aPics = Filter(aPics, "folder", False, vbTextCompare)
  If Not IsArray(aPics) Then Exit Sub
  'MsgBox Join(aPics, vbLf): Exit Sub
  
  'Random sort aPics array:
  FYShuffle aPics
  'MsgBox Join(aPics, vbLf): Exit Sub
  
  'Resize aPics array, 0 based so redim one less for total pics.
  If UBound(aPics) > 15 Then ReDim Preserve aPics(15) '12 pics total
  
  'Resize cells and embed file:
  'Columns("A").ColumnWidth = 36
    
  '.set c = Cells(Rows.Count, "A").End(xlUp).Offset(1)
  Set c = Range("F4")
  
  
  For i = 0 To UBound(aPics)
     On Error GoTo getout
     
    For j = 1 To 3
    
    'Rows(c.Row).RowHeight = 150
    'Columns(c.Column).ColumnWidth = 35
    
    Set s = ActiveSheet.Shapes.AddPicture _
      (aPics(i), msoFalse, msoTrue, _
        c.Left, c.Top, 150, 150)
       ' c.Left, c.Top, c.Width, c.RowHeight)'embed files
    s.LockAspectRatio = False
    'With ActiveSheet.Pictures.Insert(aPics(i)) 'link files
    '  .ShapeRange.LockAspectRatio = False
    '  .Width = c.Width
    '  .Height = c.RowHeight
    '  .Top = c.Top
    '  .Left = c.Left
    'End With
    Set c = c.Offset(0, 3)
    i = i + 1
    Next j
    Set c = c.Offset(10, -9)
    
    
  Next i
  
getout:
  
 
  
  
End Sub