Centrer fenètre sur Shape

Bonjour,

Je cherche désespéramment à permettre de cibler l'écran VisibleRange sur une shape.

Elles sont déjà tous affecté à une macro, j'ai trouvé sur le net comment centré sur une cellule mais pas sur une shape.

Il faudrait que la référence soit le Nom de la shape (Nomsch) pour que lorsque celle-ci est utilisé soit par sélection clic sur image, soit par sélection manuelle (liste déroulante), la shape soit centré vers (si possible) le centre de la fenêtre.. (sans être déplacé, que ce soit la feuille qui se centre sur la forme libre (quand c'est possible) et non l'inverse)

L’intérêt est que suivant l'image (puisqu'il y en aura plusieurs sur le fichier final) ou un quelconque zoom, la sélection apparaisse toujours à l'écran.

Ça fait quelques heures que je cherche sur Internet et je ne trouve rien pour m'aiguiller ..

Est-ce au moins possible réellement ? :/

Je vous transmet le fichier si ca peut aider..

Bonjour,

Je n'ai pas testé mais j'ai trouvé ce lien :

https://www.mrexcel.com/board/threads/center-shape-and-or-picture-on-active-screen.200260/

L'appel de la procédure :

Call CenterShape(Me.Shapes("Rectangle 1")) 

la procédure :

Sub CenterShape(o As Shape) 
  o.Left = ActiveWindow.VisibleRange(1).Left + (ActiveWindow.VisibleRange.Width / 2 - o.Width / 2) 
  o.Top = ActiveWindow.VisibleRange(1).Top + (ActiveWindow.VisibleRange.Height / 2 - o.Height / 2) 
End Sub

Décidément toujours toi aha :p

Alors j'ai regardé sur les test la macro a l'air d'être validé, je n'ai pas de remonté d'erreur mais aucun changement sur le fonctionnement de base. aucun centrage n'est fait.

Sur la fonction d'appel, j'ai testé en ciblant un rectangle Test et rien ne se passe..

Je ne sais si je fais quelques chose de mal. :/

Bonjour à tous,

Ce code-ci semble fonctionner à l'exception que le nombre de colonnes à gauche semble trop petit.

Il faudrait placer l'avion plus bas et plus à droite pour avoir suffisamment de lignes et de colonnes pour pouvoir "scroller" suffisamment. Bon amusement ...

Sub testPositionnement()
Call CentreShape(ActiveSheet.Shapes("14 - Partie centrale"))
End Sub

Sub testPositionnementavant()
Call CentreShape(ActiveSheet.Shapes("11 - Fuselage avant"))
End Sub

Sub CentreShape(SH As Shape)
Dim R As Range
Dim x&
Dim y&
'---
SH.Visible = msoTrue
ActiveCell.Select 'nécessaire pour le rafraîchissement de la Shape
Set R = SH.TopLeftCell
With ActiveWindow
  .ScrollRow = R.Row
  .ScrollColumn = R.Column
  '---
  Set R = .VisibleRange
  y& = (R.Rows.Count \ 2) - 2
  If R.Row < y& Then y& = R.Row - 1
  x& = (R.Columns.Count \ 2) - 1
  If R.Column < x& Then x& = R.Column - 1
  .ScrollRow = R.Row - y&
  .ScrollColumn = R.Column - x&
End With
Set SH = Nothing
End Sub

ric

J'ai surement du louper un truc parce que je n'y arrive pas de mon côté ...

Tu l'as testé avec succès sur mon fichier ? :/

Bonjour à tous,

Je te retourne ton fichier. Si tu cliques sur un élément de l'avion, le déplacement s'effectue.

J'ai trouvé le bogue dont je parlais.

Teste cela ...

En passant : Je ne suis pas l'auteur du code, c'est une trouvaille de mon ami "Google" que j'ai adapté. Ça semble correspondre à ton besoin. Dû moins, je l'espère.

ric

Ah oui c'est bon en effet ça fonctionne sauf que ...

Le centrage je le souhaiterai quand je selectionne au niveau de la liste déroulante aha

Bonjour à tous,

Woualllllllla ....

ric

Je regarde ça demain !

Merci pour ton travail !

++

Parfait ça ! La curiosité m'as fait me lever pour vérifier Aha ^^

Merci encore pour le temps accordé

ric

Bonjour,

Bon je reviens vers vous quand même, par rapport à ce que je pensais j'aimerai au final que ca s'actualise seulement sur l'axe Y avec un défilement vertical

Si je laisse comme ça, ca devient compliqué de gérer la cellule liste déroulante de sélection.

Je trouve que ce n'est pas très esthétique :/

Mais si j'enlève dans la macro les informations concernant X il y a un décalage qui gêne...

Le Y s'aligne sur la 2ème ligne (la première étant figé)

et je chercherai donc à avoir le Y callé sur le milieu du visibleRange. Ainsi que je zoom ou dezoom, il faudrait qu'il soit au centre de X,

mais je me dis qu'il faut surement une autre macro pour jouer sur un seul axe

Je vais google voir aha

Une idée ?

Cordialement

Bonjour,

Pour un déplacement uniquement vertical ... peut-être ainsi ...

Sub CentreShape(SH As Shape)
Dim R As Range
Dim x&
Dim y&
'---
SH.Visible = msoTrue
ActiveCell.Select 'nécessaire pour le rafraîchissement de la Shape
Set R = SH.TopLeftCell
With ActiveWindow
  .ScrollRow = R.Row
''  .ScrollColumn = R.Column
  '---
  Set R = .VisibleRange
  y& = (R.Rows.Count \ 2) - 1
  If R.Row < y& Then y& = R.Row - 1
  x& = (R.Columns.Count \ 2) - 1
  If R.Column < x& Then x& = R.Column '- 1
'''  .ScrollRow = R.Row - y&
'''  .ScrollColumn = R.Column - x&
End With
Set SH = Nothing
End Sub

ric

Merci pour ta réactivité je n'ai même pas eu le temps de modifier mon message originel

Donc je viens de tester.

Il y a bien le défilement vertical mais comme je l'ai dit dans le message modifié la cellule de référence est la première sur y et je ne comprend pas dans la macro ce qui va donner la référence pour cibler un y au milieu du visibleRange.

J'ai trouvé pas mal de code, mais à chaque fois que j'ai trouvé quelques chose qui pouvait correspondre à ma recherche, celle ci fait remonter une erreur ici

Private Sub Worksheet_Change(ByVal Target As Range)

Test fait avec celui ci

Sub test() Dim VR As Range Set VR = ActiveWindow.VisibleRange With ActiveSheet.Shapes("cdr") .Left = VR.Left + (VR.Width / 2) - (.Width / 2) .Top = VR.Top + ((VR.Height - 15) / 2) - (.Height / 2) 'les "15" c'est pour la ligne d'entete colonne(les lettres) qui fait parti de l'activewindow End With End Sub

Je suis pommé

J'ai trouvé ! tout a l'air de collé pour l'instant, je ferai mes test sur mon fichier final demain !

Il fallait juste que j'enlève le commentaire sur la ligne :

.ScrollRow = R.Row - y&

Je vous met le code !

Sub CentreShape(SH As Shape) Dim R As Range Dim x& Dim y& '--- SH.Visible = msoTrue ActiveCell.Select 'nécessaire pour le rafraîchissement de la Shape Set R = SH.TopLeftCell With ActiveWindow .ScrollRow = R.Row '' .ScrollColumn = R.Column '--- Set R = .VisibleRange y& = (R.Rows.Count \ 2) - 1 If R.Row < y& Then y& = R.Row - 1 x& = (R.Columns.Count \ 2) - 1 If R.Column < x& Then x& = R.Column '- 1 .ScrollRow = R.Row - y& ''' .ScrollColumn = R.Column - x& End With Set SH = Nothing End Sub

Encore merci pour votre patience