Insertion d'objet sous forme d'icone

Option Explicit
Private Sub CommandButton1_Click()
Dim Obj As OLEObject
Dim Chemin As Variant
Dim Nomfichier As String
Dim Emplacement As Range
Dim derniereLigne As Integer
derniereLigne = Range("D" & Rows.Count).End(xlUp).Row + 1 'n° de la première ligne vide de la colonne D
Chemin = Application.GetOpenFilename(Title:="Insertion du fichier complémentaire aux explications")
If Chemin = False Then Exit Sub
Application.ScreenUpdating = False
 Set Emplacement = Range("D" & derniereLigne)
 With ActiveSheet
Set Obj = .OLEObjects.Add(Filename:=Chemin, Link:=False, DisplayAsIcon:=True)
End With
With Obj.ShapeRange
    .LockAspectRatio = msoFalse
    .Left = Emplacement.Left
    .Top = Emplacement.Top
    .Height = Emplacement.Height
    .Width = Emplacement.Width
End With
Range("D" & derniereLigne) = Obj.ShapeRange.Name
End Sub

Option Explicit
Private Sub CommandButton1_Click()
Dim Obj As OLEObject
Dim Chemin As Variant
Dim Nomfichier As String
Dim Emplacement As Range
Dim derniereLigne As Integer
derniereLigne = Range("C" & Rows.Count).End(xlUp).Row + 1 'n° de la première ligne vide de la colonne C
ActiveCell.Offset(0, 1).Select
Chemin = Application.GetOpenFilename(Title:="Insertion du fichier complémentaire aux explications")
If Chemin = False Then Exit Sub
Application.ScreenUpdating = False
 Set Emplacement = ActiveCell
 With ActiveSheet
Set Obj = .OLEObjects.Add(Filename:=Chemin, Link:=False, DisplayAsIcon:=True)
End With
With Obj.ShapeRange
    .LockAspectRatio = msoFalse
    .Left = Emplacement.Left
    .Top = Emplacement.Top
    .Height = Emplacement.Height
    .Width = Emplacement.Width
End With
ActiveCell.Offset(1, -1).Select
ActiveCell = Obj.ShapeRange.Name
End Sub

Private Sub CommandButton2_Click()

Range("c65536").Select
Selection.End(xlUp).Select
ActiveCell.Offset(0, 1).Select


SendKeys ("^{TAB}")
SendKeys ("{TAB}")
SendKeys ("{TAB}")
SendKeys ("{TAB}")
SendKeys ("{TAB}")
SendKeys (" ")
SendKeys ("{TAB}")
SendKeys ("{TAB}")
SendKeys ("{TAB}")
SendKeys ("~")

Application.Dialogs(xlDialogInsertObject).Show
Dim i As Integer

i = ActiveSheet.Range("H1").Value + 1
ActiveSheet.Range("H1").Value = i


ActiveSheet.Shapes.Range(Array("Object i")).Select









End Sub

Dim Obj As OLEObject
Dim Chemin As Variant
Dim Nomfichier As String
Dim Emplacement As Range
Dim derniereLigne As Integer
Dim i As Integer
i = Range("A1")
derniereLigne = Range("C" & Rows.Count).End(xlUp).Row + 1 'n° de la première ligne vide de la colonne C
ActiveCell.Offset(0, 1).Select
Chemin = Application.GetOpenFilename("Tout fichiers (*.*), *.*")
If Chemin = False Then Exit Sub
Application.ScreenUpdating = False
 Set Emplacement = ActiveCell
 With ActiveSheet
Set Obj = .OLEObjects.Add(Filename:=Chemin, _
            Link:=False, DisplayAsIcon:=True, iconIndex:=0, iconLabel:=Chemin)
End With
With Obj.ShapeRange
    .LockAspectRatio = msoFalse
    .Left = Emplacement.Left
    .Top = Emplacement.Top
    .Height = Emplacement.Height
    .Width = Emplacement.Width
    .Name = "mashape " & i
End With
Range("A1") = i + 1

Dim Chemin As Variant

Dim i As Integer
Dim shp As Shape



i = Range("E1")
Range("c65536").Select
Selection.End(xlUp).Select
ActiveCell.Offset(0, 1).Select

SendKeys ("^{TAB}")            'Sert à sélectionner les coches et afficher la boite parcourir tout de suite sans que l'opérateur n'ait à le faire
SendKeys ("{TAB}")
SendKeys ("{TAB}")
SendKeys ("{TAB}")
SendKeys ("{TAB}")
SendKeys (" ")
SendKeys ("{TAB}")
SendKeys ("{TAB}")
SendKeys ("{TAB}")
SendKeys ("~")

Application.Wait (Now + TimeValue("0:00:02")) 'temps d'attente pour réactiver le pavé numérique
SendKeys "{NUMLOCK}"

Chemin = Application.Dialogs(xlDialogInsertObject).Show 'affichage de la boite de dialogue d'ajout d'objet

If Chemin = False Then Exit Sub
Application.ScreenUpdating = False

    
Range("E1") = i + 1
Application.ScreenUpdating = True

Set shp = ActiveSheet.Shapes(i)
shp.Select
    With Selection
        .Placement = xlMoveAndSize
        .PrintObject = True
    End With



'----------------------------------------------------------------------------------------------------
End Sub

Private Sub CommandButton2_Click()


Dim Chemin As Variant
Dim i As Integer
Dim shp As Shape
Dim cpt As Integer



    cpt = Range("G1").Value
    Range("c65536").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(0, cpt).Select

    If ActiveCell.Offset(-1, cpt).Value = "" Then DoEvents
    

    If cpt > 5 Then
    Range("G1").Value = 1
    MsgBox " Limite d'ajout de fichiers par problème dépassée !", 64, "Erreur"
    Exit Sub
    End If
    
    
    
    If cpt <= 5 Then

    i = ActiveSheet.Shapes.Count
    Range("c65536").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(0, cpt).Select

    SendKeys ("^{TAB}")            'Sert à sélectionner les coches et afficher la boite parcourir tout de suite sans que l'opérateur n'ait à le faire
    SendKeys ("{TAB}")
    SendKeys ("{TAB}")
    SendKeys ("{TAB}")
    SendKeys ("{TAB}")
    SendKeys (" ")
    SendKeys ("{TAB}")
    SendKeys ("{TAB}")
    SendKeys ("{TAB}")
    SendKeys ("~")

    Application.Wait (Now + TimeValue("0:00:02")) 'temps d'attente pour réactiver le pavé numérique suite à la désactivation intempestive
    SendKeys "{NUMLOCK}"

    Chemin = Application.Dialogs(xlDialogInsertObject).Show 'affichage de la boite de dialogue d'ajout d'objet
    If Chemin = False Then Exit Sub

    Application.ScreenUpdating = False
    
    Set shp = ActiveSheet.Shapes(i)

    shp.Select         'Déplacement avec la cellule de l'objet ajouté en dernier
    With Selection
        .Placement = xlMoveAndSize
        .PrintObject = True
    End With
    
    Range("G1").Value = Range("G1").Value + 1
    Application.ScreenUpdating = True
    End If


End Sub