Insertion d'objet sous forme d'icone

Résolu
ptitdal -  
Bonjour,

Je suis face à un problème sur un fichier excel.
Je précise que je connait VBA depuis une semaine alors je ne suis pas très fort :)

J'ai créer un userform pour que certaines opération se fasse automatiquement, l'idée étant d'insérer un fichier de n'importe quel extension associé à son icone et au bon endroit.
Pour ce qui de la sélection de la cellule, c'est ok
Pour ce qui est d'afficher une boite de dialog pour insrer l'objet c'est ok

Cependant quand j'insère l'objet il est de taille très grande et toujours blanc sans l'image de l'icone ni le texte associé en dessous.

J'ai utilisé ceci

Private Sub CommandButton2_Click()

Range("c65536").Select 'sélection de la cellule voulu
Selection.End(xlUp).Select
ActiveCell.Offset(0, 1).Select

Dim Obj As OLEObject
Dim Chemin As Variant
Dim Nomfichier As String

Chemin = Application.GetOpenFilename(Title:="Insertion du fichier complémentaire aux explications")
If Chemin = False Then Exit Sub
Application.ScreenUpdating = False

With ActiveSheet
Set Obj = .OLEObjects.Add(Filename:=Chemin, Link:=False, DisplayAsIcon:=True)

End With

End Sub

Sauf que cela ne fonctionne pas comme décrit plus haut et le code "Application.Dialogs(xlDialogInsertObject).Show" ne me permet pas de gérer ce que j'obtiens avec une variable pour faire de la mise en page, donc impossible à utiliser sauf si quelqu'un me donne une astuce pour récupérer l'objet qui est ajouté.
En fouillant il y a bien un numéro d'objet qui s'incrémente de 1 à chaque ajout mais comment je peux faire la mise en page selon l'objet que j'ajoute en dernier...

Enfin j'espère que je suis claire :)

MErci de votre aide

12 réponses

Résumé de la discussion

La discussion porte sur l’insertion d’un fichier via VBA dans Excel à partir d’un formulaire, avec DisplayAsIcon et xlDialogInsertObject, et l’objet apparaît comme un grand rectangle blanc sans icône ni texte. Plusieurs réponses expliquent des méthodes pour récupérer et mettre en page l’objet inséré, notamment en utilisant la boîte de dialogue xlDialogInsertObject puis en repérant le dernier Shape inséré. En pratique, il faut compter les objets, récupérer la forme par index puis la sélectionner pour définir son placement et l’activer en PrintObject, afin d’enchaîner les ajouts dans la cellule adjacente. En pratique, il est ensuite possible d’ajouter plusieurs fichiers dans la même cellule en répétant l’opération, sans bouton supplémentaire, toutefois certaines extensions restent non reconnues par la boîte de dialogue.

Bobot (l’IA à votre service)
  1. ptitdal
    J'ai finalement réussi !
    Ci joint mon code, qui permet d'ajouter 5 fichiers sous forme d'icones dans 5 cellules adjacentes à une cellule rempli. Au bout du cinquième ajout, un message d'erreur apparait pour vous indiquer que le nombre maximum d'ajout de fichier sur cette ligne est dépassé.

    Merci Le Pivert pour ton aide précieuse :) j'ai passé beaucoup de temps là dessus ! 


    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
    1. ptitdal
      J'ai regardé ta page, honnêtement j'ai rien compris ^^ En tout cas je n'ai pas réussi à la transposer pour ce que je veux faire ...
      1. cs_Le Pivert Contributeur
        bon plus simple avec un compteur dans le même esprit que pour comptabiliser les shapes
        Mettre 1 dans la cellule G1 

        Dim compteur As Integer
compteur = Range("G1")
Range("c65536").Select
Selection.End(xlUp).Select
ActiveCell.Offset(0, compteur).Select
Range("G1") = compteur + 1


        a adapter à ton code
      2. ptitdal
        J'ai fait un truc pas mal qui sélectionne bien les bonne cellule tout et qui ne gère plus le nombre d'objet en fonction d'une valeur de cellule mais en fonction du nombre d'objet

        Tout cela s'ajoute bien dans les bonne cellules, par contre ca le fait automatiquement, je voudrais que la boucle qui ouvre la fenêtre de dialogue se fasse à chaque clic et non en boucle.
        En d'autre terme a chaque clic je dois effectuer ce qu'il y a après le while cpt > 5

        Voici mon code : 

        Private Sub CommandButton2_Click()

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

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

        While cpt > 5
        cpt = 1
        Exit Sub
        Wend

        While cpt < 5

        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
            cpt = Range("U1").Value + 1
            Application.ScreenUpdating = True
        Wend

        End Sub
    2. ptitdal
      J'ai réussi d'une façon beaucoup plus simple en fait :) 

      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


      Maintenant je voudrais que si je clic une nouvelle fois sur le bouton j'ajoute un autre objet dans la cellule adjacente, cette action se répèterait tant que je n'ai pas rempli une nouvelle ligne, ce qui permettrais d'ajouter plusieurs fichiers.

      C'est faisable ou il faut créer un bouton à chaque fois ?
      2. ptitdal
        Je comprends pas tout ! :P

        En tout cas merci beaucoup pour ton aide, ca fait quand même une semaine que je bloquais sur ce problème !
        je cherche un peu et je posterais mon code pour les gens qui seraient intéressés
    3. cs_Le Pivert Contributeur
      Pour faire ce que tu veux, il faut nommer ta shape et l'incrémenter à chaque fois comme ceci: 

      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

      1. ptitdal
        Le truc c'est que je ne peux pas utiliser OLEObject parce que l'icone qui ressort est un grand rectangle blanc sans le nom ni l'image de l'icone qui correspond à l'extension du fichier que j'ajoute ...
        C'est pour ca que dans mon code j'utilise la fonction "Application.Dialogs(xlDialogInsertObject).Show", qui me corrige tous ces problèmes ... Les sendkeys c'est pour éviter 15 clics dans le fenêtre de dialogue, c'est plus rapide pour l'utilisateur.

        Je cherche simplement une manière de sélectionner le dernier objet qui sort de cette boite de dialogue, soit avec un raccourcis clavier, soit en sélectionnant une cellule et en déclarant que je veux sélectionner l'objet qui est dedans ou une autre méthode que je connait pas, ou alors c'est impossible et là je changerais de manière de faire .. mais en tout cas quand j'utilise ton code j'obtiens pas du tout ce que je veux.

        Merci pour ton aide en tout cas, j'avance et je touche du bout du doigt la solution :)
      2. cs_Le Pivert Contributeur
        J'ai trouvé, il faut démarrer sans aucune shape sur la feuille et mettre 1 dans la cellule A1. c'est cette cellule qui va incrémenter le numéro de la dernière shape: 

        Dim Obj As OLEObject
Dim Chemin As Variant
Dim Nomfichier As String
Dim Emplacement As Range
Dim derniereLigne As Integer
Dim i As Integer
Dim shp As Shape
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.Dialogs(xlDialogInsertObject).Show
If Chemin = False Then Exit Sub
Application.ScreenUpdating = False
 Set Emplacement = ActiveCell
Set shp = Feuil1.Shapes(i) 'adapter le nom de la feuille numero de la dernière  shape correspond à A1
With shp
    .LockAspectRatio = msoFalse
    .Left = Emplacement.Left
    .Top = Emplacement.Top
    .Height = Emplacement.Height
    .Width = Emplacement.Width
    .Name = "mashape " & i
End With
Range("A1") = i + 1


        Voilà

        @+ Le Pivert
      3. ptitdal
        Alors par contre ma cellule A1 correspond à autre chose, j'ai mis ton code pour définir i en H1 du coup, mais ca me met un erreur sur la ligne set shp = feuil1.shapes(i)
        L'index de cette collection est en dehors de ses limites
        I = 16 pour infos parce que l'objet ajouté en dernier et le 16eme (vu par macro enregistrée et en sélectionnant l'objet)
        Même chose, j'ai repris ma manière de selectionner la cellule, la tienne me selectionne autre chose je ne sais pas pourquoi mais le résultat est correcte avec le code suivant.

        j'ai ajouté les sendkeys pour aller plus vite dans la boite de dialogue.

        du coup j'ai ça : 

        Dim Obj As OLEObject
        Dim Chemin As Variant
        Dim Nomfichier As String
        Dim Emplacement As Range
        Dim derniereLigne As Integer
        Dim i As Integer
        Dim shp As Shape

        i = Range("H1")
        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 ("~")
        Chemin = Application.Dialogs(xlDialogInsertObject).Show
        If Chemin = False Then Exit Sub
        Application.ScreenUpdating = False
         Set Emplacement = ActiveCell
        Set shp = ActiveSheet.Shapes(i) 'adapter le nom de la feuille numero de la dernière  shape correspond à A1
        With shp
            .Name = "mashape " & i
        End With
        Range("H1") = i + 1
      4. ptitdal
        Pour infos, j'ai l'erreur quand i arrive à la valeur 5, en dessous le code a l'air de bien vouloir se faire
      5. cs_Le Pivert Contributeur
        Avec ce code je n'ai aucun problème: 

        Dim Chemin As Variant
Dim Emplacement As Range
Dim i As Integer
Dim shp As Shape

i = Range("H1")
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 ("~")
Chemin = Application.Dialogs(xlDialogInsertObject).Show
If Chemin = False Then Exit Sub
Application.ScreenUpdating = False
Set Emplacement = ActiveCell
Set shp = ActiveSheet.Shapes(i) 'adapter le nom de la feuille numero de la dernière shape correspond à A1
With shp
    .LockAspectRatio = msoFalse
    .Left = Emplacement.Left
    .Top = Emplacement.Top
    .Height = Emplacement.Height
    .Width = Emplacement.Width
    .Name = "mashape " & i
End With
Range("H1") = i + 1


        Par contre tes SendKeys désactivent le verrouillage numérique! 

        SendKeys "{NUMLOCK}"


        pour le remettre
    5. ptitdal
      J'arrive à quelques chose d'assez bien avec les sendkeys mais je bloque sur un nouveau problème, j'aimerais mettre une variable en tant que numéro d'objet qui s'incrémente de 1.
      Sauf que quand je mets le nom de ma variable pour sélectionner le dernier objet ajouté (qui porte le numéro de la variable du coup) ca me met une erreur et qui l'objet est inconnu. Des idées ?

      Voici le code 

      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


      L'idée ici est de pouvoir selectionner le dernier objet ajouté avec la variable qui s'incrémente de 1 et de faire des sendkeys à nouveau pour faire ma mise en page automatique. Et j'aurais fini :)
      1. ptitdal
        Peut être que je pourrais réutiliser la ligne Application.Dialogs(xlDialogInsertObject).Show
        Et après avec des sendkeys faire automatiquement le boulot que je veux faire pour mettre le fameux fichier
        1. ptitdal
          Chez moi ca ne fonctionne pas ... par contre quand je fais un clic droit, objet acrobat (pour un documents pdf) et juste ok, là l'icone s'affiche alors que je ne modifie rien dans les propriété, on pourrait le faire en code VBA cette action ?
          Et j'aimerais aussi que la case déplacer et dimmensionner avec les cellule dans format d'objet/onglet propriété soit activé automatiquement aussi

          Peut être avec des sendkeys ?

          (l'enregistreur de macro ne m'a pas aidé pour tout cela)
          1. cs_Le Pivert Contributeur
            Toutes les extensions ne sont pas reconnues, voici un exemple:


            1. ptitdal
              Je ne vois rien :D
            2. cs_Le Pivert Contributeur
              Tu ne vois pas sur l'image les icônes et le nom du fichier! C'est petit.

              Je ne sais pas ce que tu cherches à faire, mais je pense qu'il faut que tu voies la chose autrement. Car les images ne sont pas très explicites
            3. ptitdal
              En fait quand j'ajoute la fichier j'aimerais voir l'icone du fichier correspondant à l'extension et en dessous le chemin d'accès par exemple (comme en utilisant la boite de dialog d'insertion d'objet ==> Insertion/objet)
              Quand j'ajoute via OLEObject, je peux gérer la variable en sortie mais je n'arrive pas à voir les icones, c'est juste un carré blanc. Et l'idée c'est que ce soit visible sans que l'opérateur n'ai à faire de mise en page ou de retouche dans le fichier.
            4. cs_Le Pivert Contributeur
              Toutes les extensions ne sont pas reconnues

              change ceci: 

              Set Obj = .OLEObjects.Add(Filename:=Chemin, Link:=False, DisplayAsIcon:=True)


              par cela: 

              Set Obj = .OLEObjects.Add(Filename:=Chemin, DisplayAsIcon:=True, IconLabel:=Chemin)


              c'est plus net!

              voici les extensions reconnues chez moi
              TEXTE
              IMAGE JPG
              EXCEL
              IMAGE GIF
              IMAGE PNG
            5. ptitdal
              Fonctionne pas non plus, peut importe ce que je mets comme extension de fichier (word, pdf, image ...)
          2. ptitdal
            Ca marche plutot bien, je l'ai adapté légèrement pour ce que je veux.
            J'ai encore un problème, mon icone de fichier ne s'affiche pas et le nom du fichier non plus (ou l'emplacement peut importe)
            Normalement c'est avec iconlabel ou iconasdisplay mais mais mêmùe en changeant ces valeurs je me retrouve toujours avec un icone blanc et de grand taille !
            1. cs_Le Pivert Contributeur
              Voilà 

              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

              1. ptitdal
                Alors, ca pourrais le faire, sauf que ma selection de denrière ligne ne peux pas se faire autrement que comme je l'ai fait, parce que toutes les cellules de ma colonne D sont vide par définition (même si un objet peut y être inséré) excel considère la cellule comme vide.

                Merci de ton aide en tout cas :)

                Il y a un syntaxe pour remplacer ce que tu as mis dans la variable derniereligne par ce que j'ai fait plus haut ? (c'est a dire dernière ligne remplie de la colonne c et se décaler d'une cellule vers la droite)

                Autre chose, dans ton code, l'ajout de fichier prend toutes la cellule, je doit pouvoir en ajouter plusieurs (au moins 3) dans la même cellule, avec des petits icones de préférence comme avec la boite de dialog d'ajout d'objets (insertion/objet)
                1. cs_Le Pivert Contributeur
                  Bonjour,

                  Comme ceci: 

                  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

                  Discussions similaires

                  Symbole Attention dans Word
                  Nortec59

                  33 réponses