Foto invoegen obv naam uit cel + Hyperlinks mbv Excel VBA

Sub Picture()
 Dim picname As String
    
 Dim pasteAt As Integer
 Dim lThisRow As Long
    
    lThisRow = 6
    
    Do While (Cells(lThisRow, 6) <> "")
       
        Range("D6").Select 'This is where picture will be inserted
        pasteAt = Cells(lThisRow, 4)
        Cells(pasteAt, 1).Select 'This is where picture will be inserted
           
         picname = Range("E6") 'This is the picture name
         'picname = Cells(lThisRow, 2) 'This is the picture name
            
        ActiveSheet.Pictures.Insert("D:\Foto's 100% inventerisatie" & picname & ".jpg").Select 'Path to where pictures are stored
   
        ' This resizes the picture
        
        With Selection
            '.Left = Range("A6").Left
            '.Top = Range("A6").Top
            .Left = Cells(pasteAt, 1).Left
            .Top = Cells(pasteAt, 1).Top
               
            .ShapeRange.LockAspectRatio = msoFalse
            .ShapeRange.Height = 100#
            .ShapeRange.Width = 80#
            .ShapeRange.Rotation = 0#
        End With
           
        lThisRow = lThisRow + 1
       
    Loop
       
    Range("E6").Select
    Application.ScreenUpdating = True
       
    Exit Sub
       
ErrNoPhoto:
    MsgBox "Unable to Find Photo" 'Shows message box if picture not found
    Exit Sub
    Range("B20").Select

End Sub