Bentornato
C'e' un motivo per complicarsi la vita mettendo un numero ignoto di immagini in un numero ignoto di controlli da creare su una userform?
In attesa di una valida risposta ti propongo una alternativa che usa un foglio excel, come fatto sul file scaricabile qui:
https://www.dropbox.com/s/0ugkpmtput9ul ... B.xls?dl=0Si tratta del tuo file, inutilizzato, con l'aggiunta del foglio Catalogo e il mio codice su Modulo3 del vba.
In particolare ho riciclato quanto fatto in passato (esempio qui:
viewtopic.php?f=26&p=655725#p655725) per ottenere l'elenco delle immagini (vedi Function RecurDir su Modulo3)
Uso la Function RecurDir all'interno della macro principale, Sub CreaCatalogo
Questa macro crea su un foglio specifico (io ho usato Catalogo) l'elenco delle immagini presenti a partire da un certo percorso; in particolare inserisce:
-in colonna A, la directory con hyperlink per aprire quel percorso
-in colonna B, il nome immagine
-in colonna C, l'immagine con hyperlink per aprire l'immagine
All'occorrenza puoi applicare il filtro sul contenuto di colonna A per selezionare solo ad esempio le immagini presenti in "Cartelli Emergenza", immaginando che il nome cartella sia "parlante"
Il codice della macro principale:
- Codice: Seleziona tutto
Sub CreaCatalogo()
Dim FArr() As String, Catag As Worksheet, AllPics
Dim cPic, mPW As Single
'
Set Catag = Sheets("Catalogo") '<<< Il foglio Catalogo
AllPics = Array("jpg", "png", "gif") '<<< Altri formati di immagini?
StrDir = "D:\DDownloads\byBG66_C11125\Immagini" '<<< Il Percorso iniziale
'
'Pulisce l'area:
Catag.Select
Range("A:A").Hyperlinks.Delete
Range("A:A").RowHeight = 15
Call ClearPic
Range("A:C").Clear
'Compila l'elenco delle Immagini:
ReDim FArr(1 To 1)
Call RecurDir(StrDir, AllPics, FArr)
'
'Compila percorso, nome immagine e mostra immagine:
For i = 1 To UBound(FArr)
mysplit = Split(FArr(i) & " ", "\", , vbTextCompare)
ub = UBound(mysplit)
If ub > 0 Then
Cells(i + 1, 1) = Trim(mysplit(ub - 1))
Cells(i + 1, 2) = Trim(mysplit(ub))
'imposta h.link su percorso:
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 1, 1), Address:= _
Replace(FArr(i), Cells(i + 1, 2).Value, "", , , vbTextCompare), TextToDisplay:= _
Cells(i + 1, 1).Value
Rows(i + 1).RowHeight = 100 'Imposta l'altezza riga
'
'Posiziona l'immagine:
myT = Cells(i + 1, 3).Top + 5
myL = Cells(i + 1, 3).Left + 5
myH = Cells(i + 1, 3).Height - 5
'
Set cPic = ActiveSheet.Shapes.AddPicture(FArr(i), False, True, myL, myT, True, True)
cPic.LockAspectRatio = msoTrue
cPic.ScaleHeight (myH / cPic.Height), msoTrue
cPic.Placement = xlMove
If cPic.Width > mPW Then mPW = cPic.Width
cPic.Name = "FOTO_DA_" & Cells(i + 1, 3).Address(0, 0)
'Imposta H.Link su immagine:
ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Shapes(cPic.Name), Address:=FArr(i)
End If
Next i
'Intestazioni su riga 1:
Range("A1:C1").Value = Array("Percorso", "NomeImmagine", "Picture")
'Formatta colonne:
Columns("A:B").EntireColumn.AutoFit
With Rows("1:1")
.HorizontalAlignment = xlCenter
.Font.Bold = True
End With
With Range("C:C")
.ColumnWidth = 10
acw = .Width
.ColumnWidth = mPW * .ColumnWidth / acw
End With
End Sub
Come sempre, le istruzioni marcate <<< in testa sono "parametri" da impostare secondo la tua situazione.
Così fatto mi sembra molto piu' semplice di come l'avevi immaginata, vedi quanto riesci a riciclare
Ciao
... fortunatamente quello che Anthony mi ha insegnato mi ha permesso di andare avanti per un pò!!
