Associare Immagine su Foglio XL

[Making]

Ciao,
mi aiutate a creare una macro che inserisce nel foglio XL l'immagine corrispondente ad ogni cella della colonna A.

Il codice può essere di 11 o 13 caratteri, le foto corrispondenti (.jpg) sono in una cartella ed hanno come nome lo stesso nome della cella della colonna A del foglio XL. La foto dev'essere inserita nell'ultima cella a dx vuota (in questo caso colonna P)

http://www.filedropper.com/esempio

[Anthony47]

Prova con questo codice:

Codice: Seleziona tutto

Sub MettImmZZ()
    Dim mPath As String, mFoto As String, myArea As String, Cella As Range
Dim myT As Long, myL As Long, myH As Long, myCol As String, picPath As String
'
myCol = "P"                     '<<< La colonna dove si inseriranno le foto
mPath = "D:\provaz\pippo"       '<<< Il percorso delle foto
'
myArea = Range(Range("A3"), Cells(Rows.Count, 1).End(xlUp)).Address
For Each Cella In Range(myArea)
    On Error Resume Next
        ActiveSheet.Shapes("FOTO_DA_" & Cella.Address(0, 0)).Delete
    On Error GoTo 0
    If Cella.Value <> "" Then
            mFoto = Cella.Value
            If Dir(mPath & "\" & mFoto & ".jpg") <> "" Then ' Si controlla se la foto esiste
                Application.ScreenUpdating = False
                '
                myT = Cella.Top + 5
                myL = Cells(Cella.Row, myCol).Left + 5
                myH = Cella.Height - 5
                '
                Set CPic = ActiveSheet.Shapes.AddPicture(mPath & "\" & mFoto & ".jpg", False, True, myL, myT, True, True)
                CPic.LockAspectRatio = msoTrue
                CPic.ScaleHeight (myH / CPic.Height), msoTrue
                CPic.Name = "FOTO_DA_" & Cella.Address(0, 0)
                Application.ScreenUpdating = True
            Else
                MsgBox ("Immagine non trovata: " & Cella.Value) ' <<====== QUI scrivi il messaggio che vuoi sia inviato
            End If
    End If
Next Cella
MsgBox ("Completato inserimento...")
End Sub


Va inserito in un Modulo Standard del tuo progetto Vba; le istruzioni marcate <<< vanno personalizzate come da commento.
Poi selezioni il foglio "giusto" e avvii la Sub MettImmZZ
Non hai detto come fare con le dimensioni delle foto, quindi ho inventato che esse saranno ridimensionate rispettando l'altezza della riga

Ciao

[Making]

grazie, funziona tutto alla perfezione. Non devo ridimensionare le immagini perché sono troppo piccole, mi servono così come sono. Come faccio?

[Anthony47]

Elimina l'istruzione CPic.ScaleHeight (myH / CPic.Height), msoTrue che comunque, se le immagini sono di partenza piccole, non dovrebbe fare male e ne impedisce la sovrapposizione verticale.

Ciao

[Making]

ma così non rifà il resize della riga, le foto vengono copiate una sopra l'altra. E' possibile mantenere l'i sruzione precedente ingrandendo la foto del triplo (con il resize della riga)?

[Making]

in altre parole, se mantengo la macro iniziale come faccio ad ingrandire a mio piacimento le foto e conseguentemente avere anche il resize della riga?

[Making]

Infine, per le due istruzioni in basso è possibile creare un popup di inserimento per la prima e di selezione della cartella per la seconda?

myCol = "R" '<<< La colonna dove si inseriranno le foto
mPath = "C:\Temp\img" '<<< Il percorso delle foto

[Anthony47]

Per l'altezza dell'immagine, lascia la macro come proposta e aggiungi una istruzione che imposta l'altezza della riga che ti serve, l'immagine sara' adattata alla riga:

Codice: Seleziona tutto

                Application.ScreenUpdating = False
                '
                Cella.RowHeight = 30        '<<< Aggiungi: imposta l'altezza che vuoi
                myT = Cella.Top + 5

In questo modo decidi tu l'altezza della riga e l'immagine si adatta

Infine, per le due istruzioni in basso è possibile creare un popup di inserimento per la prima e di selezione della cartella per la seconda?

Codice: Seleziona tutto

myCol = "R" '<<< La colonna dove si inseriranno le foto
mPath = "C:\Temp\img" '<<< Il percorso delle foto


Elimina quelle due istruzioni e sostituiscile con

Codice: Seleziona tutto

Rispo = Application.InputBox("In quale colonna (A-AZ) vanno posizionate le immagini?", "Rispondi", , , , , , 2)
If Rispo = False Then
    MsgBox ("Processo abortito")
    Exit Sub
Else
    myCol = Rispo
End If
MsgBox ("Ora selezionerai la directory da cui prelevare le immagini")
With Application.FileDialog(msoFileDialogFolderPicker)
   .Show
    If .SelectedItems.Count = 0 Then
        MsgBox ("Nessuna voce selezionata, processo abortito")
        Exit Sub
    End If
    mPath = .SelectedItems.Item(1)
End With


Ciao

[Making]

Application.ScreenUpdating = False
'
Cella.RowHeight = 30 '<<< Aggiungi: imposta l'altezza che vuoi
myT = Cella.Top + 5


ok ma dove la inserisco esattamente?

[Making]

Sono riuscito, ho solo aggiunto l'istruzione "Cella.RowHeight = 30 '<<< Aggiungi: imposta l'altezza che vuoi" in basso sopra la precedente che era già nella macro iniziale, grazie!

Ultima cosa, è possibile attivare/disattivare la finestra che dice che l'immagine non è stata trovata?

[Anthony47]

Sono riuscito

Bravo...

Ultima cosa, è possibile attivare/disattivare la finestra che dice che l'immagine non è stata trovata?

Per non avere le interruzioni sulle immagini mancanti, modifica l'ultima parte della macro, da Else in avanti:

Codice: Seleziona tutto

            Else
                If Len(Missing) < 100 Then
                    Missing = Missing & Cella.Value & vbCrLf
                Else
                    cippa = "....." & vbCrLf
                End If
            End If
    End If
Next Cella
If Len(Missing) < 2 Then
    myMSG = "Completato inserimento"
Else
    myMSG = "Completato inserimento; immagini non trovate:" & vbCrLf & Missing & cippa
End If
MsgBox (myMSG)
End Sub


In questo modo ci sara' un messaggio finale che all'occorrenza elenchera' tutte le immagini mancanti (o le prime N, se sono tante)

Ciao

[Making]

Fatto, ottimo!