Insertion d'objet sous forme d'icone [Résolu/Fermé]

Signaler
-
 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

Messages postés
7036
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
13 novembre 2020
573
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

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)
Messages postés
7036
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
13 novembre 2020
573
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

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 !
Messages postés
7036
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
13 novembre 2020
573
Toutes les extensions ne sont pas reconnues, voici un exemple:


Messages postés
7036
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
13 novembre 2020
573
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
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.
Messages postés
7036
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
13 novembre 2020
573
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
Fonctionne pas non plus, peut importe ce que je mets comme extension de fichier (word, pdf, image ...)
Messages postés
7036
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
13 novembre 2020
573
Voilà un exemple

https://www.cjoint.com/c/HFBhpx3wF1Q

@+ Le Pivert
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)
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
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 :)
Messages postés
7036
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
13 novembre 2020
573
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

Cela ne fonctionne toujours pas, ca m'affiche le menu contextuelle de la cellule, voici moncode, peut être que j'ai fait un erreur ?

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("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"))
SendKeys "{NUMLOCK}"

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

If Chemin = False Then Exit Sub


Set Emplacement = ActiveCell
Set shp = ActiveSheet.Shapes(i)




shp.Select
Application.CommandBars("cell").ShowPopup


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


'----------------------------------------------------------------------------------------------------
End Sub
Messages postés
7036
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
13 novembre 2020
573
si tu as d'autres shapes cela fausse tout

il est préférable de faire ceci:

Dim nbre As Integer
nbre = ActiveSheet.Shapes.Count ' nombre total de shapes
ActiveSheet.Shapes(nbre).Select 'derniere shape
afficherMenuContextuel


@+
Fonctionne toujours pas :( :( :(
J'ai l'impression que je ne sélectionne pas mon dernier icone :(

Mon code :
Dim Chemin As Variant
Dim Emplacement As Range
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:01")) '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

Set Emplacement = ActiveCell








Range("E1") = i + 1
Application.ScreenUpdating = True
Dim nbre As Integer

nbre = ActiveSheet.Shapes.Count
Set shp = ActiveSheet.Shapes(nbre)
shp.Select
Application.Wait (Now + TimeValue("0:00:02"))
Application.CommandBars("cell").ShowPopup



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



Je pense que c'est la ligne Application .commandBars ("cell").showPupup qui ne convient pas, si je lit cell c'est que c'est la popup d'une cellule et moi je veux la même chose mais pour le dernier objet ajouté.

Fonctionne pas non plus avec sendkeys ("+{F10}") qui correspondrait à un clic droit. je pense qu'il me manque la sélection de ce satané objet :P
Messages postés
7036
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
13 novembre 2020
573
Cela fonctionne très bien chez moi

pour essai tu fais Insertion- Formes tu choisi une forme.
ensuite dans un bouton tu mets ceci:

Private Sub CommandButton7_Click()
Dim nbre As Integer
Dim shp As Shape
nbre = ActiveSheet.Shapes.Count
Set shp = ActiveSheet.Shapes(nbre)
shp.Select
Application.Wait (Now + TimeValue("0:00:02"))
Application.CommandBars("cell").ShowPopup
End Sub


Quand le menu contextuel apparaît tu cliques sur Couper
Sauf que dans mon code ma forme s'incère automatiquement avec la ligne Application.Dialogs(xlDialogInsertObject).Show
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 ?
Messages postés
7036
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
13 novembre 2020
573
C'est faisable, je te laisse chercher:

http://www.gcexcel.com/trouver-la-cellule-associee-a-une-forme/

Bon courage
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
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 ...
Messages postés
7036
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
13 novembre 2020
573
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
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
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