XL 2010 Adresse cellule incluant une image

herve62

XLDnaute Barbatruc
Supporter XLD
Bonsoir
Je ne sais plus si c'est possible ?
De récupérer l'adresse d'une cellule contenant une image si l'on clique dessus donc via la sub worksheets Selection_change et certainement l'intersect ?
 

herve62

XLDnaute Barbatruc
Supporter XLD
Oui j'ai déjà vu ce post mais j'arrive pas à adapter car :
[c65536].End(3)(2) = s.TopLeftCell.Address ; Je pige pas ???
Ce que je retrouve pas c'est comment cliquer sur l'image et qui me donne l'adresse de la cellule contenant l'image? donc ici C5
 

Pièces jointes

  • Adr_pict.xlsm
    19.5 KB · Affichages: 6

laurent950

XLDnaute Accro
Bonsoir @herve62 , @GALOUGALOU

' Avec Application.Caller

MsgBox ActiveSheet.Shapes(1).TopLeftCell.Address
1 est la première image de la Feuille inséré. etc 2,3,4,5.... (Ranger par Ordre dans la feuille)
Ensuite si votre Image "Shapes(1)" s'appel "Image 1"
il faut substituer le 1 avec le nom de l'image soit : Shapes("Image 1") ' écrit en dur dans le code
Application.Caller donne le nom de l'image est donc : Shapes(Application.Caller) ' écrit en variable dans le code

VB:
Sub image()
    MsgBox ActiveSheet.Shapes(Application.Caller).TopLeftCell.Address
End Sub
 

laurent950

XLDnaute Accro
Bonjour @herve62 , @GALOUGALOU

Titre : Pour récupérer l'adresse d'une cellule contenant une Shape si l'on clique dessus.

Deux Modules :
- ThisWorkbook (Le Module de class du classeur Excel)
- EventsShapes (Un Module de class : renommé "EventsShapes")

Création d'un module de class pour rendre indépendant les événements qui sont liées à une feuille
- C'est a dire pour ne pas utiliser (les module de classe des feuilles du classeur Excel)

Le Principe

pour :
- ThisWorkbook (Dans ce Module)
des l'ouverture du classeur Excel :
Création d'une variable Objet du type application (Excel)
Instance de cette variable Objet
Création des liens (sur tous les shapes de la feuille active)

Code ci-dessous (A recopier dans ThisWorkbook)
VB:
Option Explicit
' Déclaration de variable privé de type application
Private xlApp As EventsShapes
'
Private Sub Workbook_Open()
' Instance de la variable de class à l'ouverture du classeur
' en Premier
    Set xlApp = New EventsShapes
' Créations des liens sur les Shapes à l'ouverture du classeur
    xlApp.CreatHyperLinks
End Sub

Pour :
- EventsShapes (dans ce module)
Deux Variables qui correspondent :
Private clsShp As Shape ' ................... Variable objet de type Shape
Private clsRgn As Range ' ................... Variable objet de type Range
La Variable WithEvents
Private WithEvents xlApp As Application ' ... Variable de la classe Application

Initialisation de la variable : avec Class_Initialize
Set xlApp = Application

- Lancement de la procédure a l'ouverture du classeur de la création de tous les liens hyperlien sur les shapes (de la feuille active)
Moyen pour déclencher l'événement change avec l'application (Excel)

- La procédure (qui a était personnalisé avec la classe pour lire les adresses de la shape selectionnée avec :
Private Sub xlApp_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

- Les deux variables clsShp & clsRgn ci-dessus pour lecture depuis cette class avec la Propriété : Property Get
Property Get Rgn() As Range
Property Get Shp() As Shape

Code ci-dessous (A recopier dans le module de classe créer est renommé "EventsShapes")
VB:
Option Explicit
' Pour le Module de classe
Private clsShp As Shape                        ' Variable objet de type Shape
Private clsRgn As Range                        ' Variable objet de type Range
Private WithEvents xlApp As Application         ' Variable de la classe Application
'
Private Sub Class_Initialize()
   Set xlApp = Application                  ' Instance de la Variable WithEvents de la class Application
End Sub
'
Private Sub xlApp_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
 Dim Flag As Boolean
On Error Resume Next
    ' Test si c'est bien une shape si non rien faire
    ' si c'est le Shape consignes les 2 objets
    ' Target qui est l'address active du Shape sélèctionné
    ' sh (n'est pas pris en charge avec l'action change sur le Shape
    ' Est l'objet Shape est identifié avec la boucle si dessous
        Dim Objshape As Shape
        For Each Objshape In Target.Worksheet.Shapes
        ' Si l'adress Target (de selection) Correspond avec l'adress du Shape
            If Target.Address = Objshape.TopLeftCell.Address Then
                Debug.Print Objshape.TopLeftCell.Address & "C'est l'address du Shape dans la Feuille Active)"
                Set clsShp = Objshape ' Le Shape sélèctionné (Consigné dans le Module de Classe pour réutilisation ultérieur)
                Set clsRgn = Target   ' Le Range sélèctionné (Consigné dans le Module de Classe pour réutilisation ultérieur)
                ' si le Test est Vrai alors sortie de la boucle For
                Flag = True
                Exit For
            End If
        Next Objshape
        '
        If Flag = False Then
        ' Si le test est Faux alors :
        ' Decharge la variable (dans le module de class) si la selection ne correspond pas au shape
            Set clsShp = Nothing
            Set clsRgn = Nothing
        End If
        ' Gestion d'erreur ci dessous (pour la collection et autre variable objet déjà vide)
        On Error Resume Next
        ' Ci dessous exemple pour test
        ' Pour Test (Exemple)
            MsgBox "Colonne : " & Me.Rgn.Column & " | " & "Ligne : " & Me.Rgn.Row   ' col & row
            MsgBox "Adresse : " & Me.Rgn.Address                                    ' L'adresse
            MsgBox "Name Shape : " & Me.Shp.Name                                    ' Le nom du Shape
            Me.Shp.Select                                                           ' Selection du shape
End Sub
'
Property Get Rgn() As Range
'' Lecture du Range sélèctionné (Consigné dans le Module de Classe pour réutilisation ultérieur)
    Set Rgn = clsRgn
End Property
'
Property Get Shp() As Shape
' Lecture du Shape sélèctionné (Consigné dans le Module de Classe pour réutilisation ultérieur)
    Set Shp = clsShp
End Property
'
Sub CreatHyperLinks()
' Création des hyperliens sur les Shapes de la Feuille active.
' Création à l'ouverture du classeur (Voir le Module ThisWookbook)
' Feuille (Active)
    Dim FActive As Worksheet
' Création du lien (Sur les shapes de la feuilles actives)
    Dim ObjHyplink As Hyperlink
    Dim ObjHyplinks As Hyperlinks
' Les Objets Shapes de la "Feuille Active" pour création de lien de déclenchement dévénement"
    Dim Objshape As Shape
    Dim ObjRgn As Range
' La feuille Active
    Set FActive = ActiveSheet
' Création de lien fictif sur l'image pour déclenchement de l'évement
    For Each Objshape In FActive.Shapes
        Debug.Print Objshape.Name                   ' Connaitre le Nom ds Shapes !
        Debug.Print Objshape.TopLeftCell.Address    ' Connaitre l'adresse ds Shapes !
        ' Pour Ajouter un hyperLiens a tous les Shapes de la feuille active
        Set ObjHyplink = FActive.Hyperlinks.Add _
                       (Anchor:=Objshape, _
                        Address:="", _
                        SubAddress:="'" & FActive.Name & "'" & "!" & Objshape.TopLeftCell.Address(0, 0), _
                        ScreenTip:=CStr(Objshape.Name))
    Next Objshape
End Sub

Nota : si vous créez des shapes sur une autre feuille, ou que le classeur s'ouvre sur une feuille qui n'a pas les Shape
Sélectionner la feuille active qui contient les shapes
Enregistrer et fermer le classeur
Une fois le classeur ouvert cela fonctionne

On peut créer d'autres événement comme par exemple au changement de feuille pour recréer les liens
exemple ci-dessous
Toujours dans le même module de classe ajouter ce code en complément
VB:
Private Sub xlApp_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    ' Création d'hyperLiens sur tous les shapes au changement de feuille (bien sur si il y a des shapes sur cette feuille créer)
    CreatHyperLinks
End Sub
 
Dernière édition:

job75

XLDnaute Barbatruc
Bonsoir à tous,

Je peux me tromper mais il me semble qu'herve62 ne cherche pas des choses compliquées :
VB:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim p As Object
For Each p In Pictures
    p.OnAction = "Feuil1.Adr" 'affecte la macro
Next
End Sub

Sub Adr()
With Shapes(Application.Caller).TopLeftCell
    MsgBox "Ligne " & .Row & vbLf & "Colonne " & Split(.Address, "$")(1), , "Adresse"
End With
End Sub
Avec TopLeftCell on a vite fait le tour !

A+
 

Pièces jointes

  • Adr_pict(1).xlsm
    25 KB · Affichages: 7

herve62

XLDnaute Barbatruc
Supporter XLD
Bonsoir
Je reprends juste ; @laurent950 : c'est très bien ce que tu as fais , merci pour tout cela , mais comme le dit bien JOB , dans ce cas j'ai juste fait un petit prog pour un ami qui voulait en cliquant sur des photos dans une cellule
recopier des infos en rapport
Donc j'ai simplement fait une extraction de chaine ( 2 lignes ) pour avoir les 2 N° : col & row
C'est vrai que souvent je soumets des cas plus complexes , mais là non !!!
Vraiment Désolé pour le temps passé , car je me suis un peu précipité sur la fin sur une dernière question que j'ai résolu
@job75 oui très succinct , je note et case dans mon grenier, car je ne maîtrise pas ce type d'instruction
Encore merci et à la prochaine !!!!
 

Discussions similaires

Réponses
1
Affichages
78
Compte Supprimé 979
C

Statistiques des forums

Discussions
311 730
Messages
2 081 981
Membres
101 855
dernier inscrit
alexis345