MACRO PER INSERIRE IMMAGINI

Hai un problema con Excel?

Nuova discussione

MACRO PER INSERIRE IMMAGINI
di Silver (utente non iscritto) data: 21/04/2016 11:59:05
Ciao
ho una macro per inserire immagini in foglio excel, le immagini vengono ridimensionate in base all'altezza della cella di destinazione, quello che vorrei è bloccare le proporzioni in modo che la larghezza dell'immagine sia funzione dell'altezza ovvero funzione del range dell'altezza della cella.
grazie

Sub InsImg()
Application.ScreenUpdating = False
ActiveSheet.Shapes.SelectAll
Selection.Delete
mPath = "E:immagini_webcroci_img"
R = 16
Lr = Range("A" & Rows.Count).End(xlUp).Row
For I = R To Lr
    Mfoto = Cells(I, 1) '' INSERIRE IL NUMERO DELLA CELLA CHE CONTIENE IL CODICE
    NFile = Dir(mPath & "" & "*" & Mfoto & "*" & ".jpg")
    
    If Len(Mfoto & "") <> 0 Then
        If NFile = "" Then Mfoto = "mancante"
        If NFile = "" Then NFile = "mancante.jpg"
        If Dir(mPath & "" & NFile) <> "" Then '
   
              ''With ActiveSheet.Pictures.Insert(mPath & "" & mFoto & ".jpg")
              '' SELEZIONARE LA CELLA DI DESTINAZIONE
                 With ActiveSheet.Shapes.AddPicture((mPath & "" & NFile), False, True, 100, 50, 400, 300)
                 ''ActiveSheet.Pictures.Insert (mPath & "" & Nfile)
                .Top = Range("O" & I).Top
                .Left = Range("O" & I).Left
                .Height = Range("O" & I).Height
                .Width = Range("O" & I).Width
                
            End With
        End If
    End If
Next I
Application.ScreenUpdating = True
End Sub

di patel data: 21/04/2016 14:32:39
prova così

Sub InsImg()
Application.ScreenUpdating = False
ActiveSheet.Shapes.SelectAll
Selection.Delete
mPath = "E:immagini_webcroci_img"
R = 16
Lr = Range("A" & Rows.Count).End(xlUp).Row
For I = R To Lr
    Mfoto = Cells(I, 1) '' INSERIRE IL NUMERO DELLA CELLA CHE CONTIENE IL CODICE
    NFile = Dir(mPath & "" & "*" & Mfoto & "*" & ".jpg")
    
    If Len(Mfoto & "") <> 0 Then
        If NFile = "" Then Mfoto = "mancante"
        If NFile = "" Then NFile = "mancante.jpg"
        If Dir(mPath & "" & NFile) <> "" Then '
                  With ActiveSheet.Shapes.AddPicture((mPath & "" & NFile), False, True, 100, 50, 400, 300)
                .LockAspectRatio = msoTrue
                .Top = Range("O" & I).Top
                .Left = Range("O" & I).Left
                .Height = Range("O" & I).Height
            End With
        End If
    End If
Next I
Application.ScreenUpdating = True
End Sub

di silver (utente non iscritto) data: 21/04/2016 17:44:19
non funziona
mi pare pero' che così invece funzioni

Sub InsImg()
Application.ScreenUpdating = False
ActiveSheet.Shapes.SelectAll
Selection.Delete
mPath = "E:immagini_webcroci_img"
Dim Height As Single
Dim Width As Single

R = 2 ''riga dalla quale iniziare  la ricerca
Lr = Range("A" & Rows.Count).End(xlUp).Row
For I = R To Lr
    Mfoto = Cells(I, 1) '' INSERIRE IL NUMERO DELLA CELLA CHE CONTIENE IL CODICE
    NFile = Dir(mPath & "" & "*" & Mfoto & "*" & ".jpg")
    
    If Len(Mfoto & "") <> 0 Then
        If NFile = "" Then Mfoto = "mancante"
        If NFile = "" Then NFile = "mancante.jpg"
        If Dir(mPath & "" & NFile) <> "" Then '
   
              ''With ActiveSheet.Pictures.Insert(mPath & "" & mFoto & ".jpg")
              '' SELEZIONARE LA CELLA DI DESTINAZIONE
                 With ActiveSheet.Shapes.AddPicture((mPath & "" & NFile), False, True, 100, 50, 400, -1)
                 ''ActiveSheet.Pictures.Insert (mPath & "" & Nfile)
                Height = .Height
                
                Width = .Width
                
                .Top = Range("O" & I).Top
                .Left = Range("O" & I).Left
                .Height = Range("O" & I).Height
             
                .Width = Width / (Height / Range("O" & I).Height)
                
                ''.Width = Range("O" & I).Width
                 
                Width = .Width
            End With
        End If
    End If
Next I
Application.ScreenUpdating = True
End Sub

Vuoi Approfondire?