Sub Immagine()

Application.ScreenUpdating = False 'con questo comando fai in modo che non vedi i movimenti a video quando cambia fogli

Dim valore As String
Dim riga As Integer
Dim colonna As String
Dim colonna_foto As String

'riga = n° riga da dove iniziare a inserire immagini
riga = TextBox3
colonna = TextBox4
colonna_foto = TextBox5

'inizia il ciclo

Do

'seleziona cella da dove prendere nome foto e lo copia in "valore"
    Range("" & colonna & "" & riga & "").Select
    valore = ActiveCell.FormulaR1C1
' seleziona cella da dove mettere la foto
    Range("" & colonna_foto & "" & riga & "").Select
    
    If valore = "" Then Exit Do 'esce dal ciclo quando finiscono le celle con valore
    
' inserisce immagine da percorso
    On Error Resume Next
    ActiveSheet.Pictures.Insert( _
        "" & TextBox1 & "" & valore & "." & TextBox2 & "").Select

On Error Resume Next 'se non trova l'immagine passa alla successiva

' comprime immagine (non funziona)
    'Selection.ShapeRange.PictureFormat.Brightness = 0.5
    'Selection.ShapeRange.PictureFormat.Contrast = 0.5
    'Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic
    'Selection.ShapeRange.PictureFormat.CropLeft = 0#
    'Selection.ShapeRange.PictureFormat.CropRight = 0#
    'Selection.ShapeRange.PictureFormat.CropTop = 0#
    'Selection.ShapeRange.PictureFormat.CropBottom = 0#

' ridimensiona immagine
    Selection.ShapeRange.LockAspectRatio = msoTrue

 
    Selection.ShapeRange.Width = 60
    If Selection.ShapeRange.Height > 41 Then
    
    Selection.ShapeRange.Height = 40
    End If
         
    Selection.ShapeRange.Rotation = 0#
        
' sposta immagine
    Selection.ShapeRange.IncrementTop 2.25
    Selection.ShapeRange.IncrementLeft 2.25


riga = riga + 1

'se la check box2 è barrata copia l'immagine

If CheckBox2 = True Then

Dim fso
Dim file As String, sfol As String, dfol As String
file = valore & "." & TextBox2 ' immagine (la prende dalla cella
sfol = TextBox1 & "" ' da dove prende le foto
dfol = TextBox6 & "" ' dove mettere le foto
Set fso = CreateObject("Scripting.FileSystemObject")
   fso.CopyFile (sfol & file), dfol, True
End If

'se la check box è barrata inserisce una sola immagine
If CheckBox1 = True Then Exit Do

Loop

'se la check box3 è barrata rinomina le foto copiate

If CheckBox3 = True Then

mFolder = TextBox6 & ""
r = TextBox3
Do Until Cells(r, 5) = ""
    OldName = mFolder & Cells(r, 5).Value & ".jpg"
    NewName = mFolder & Cells(r, 18) & " - " & Cells(r, 5) & " - " & Cells(r, 19) & ".jpg"
    If Dir(OldName) <> "" Then
        Name OldName As NewName
    End If
    r = r + 1
Loop
End If

'Loop

MsgBox "inserimento terminato"
End Sub