Hasco dixitTu pourras identifier tes 'ovals' en mettant quelque chose de commun dans leur nom.
Sub test()
Dim s As Shape
For Each s In ActiveSheet.Shapes
MsgBox s.AutoShapeType
Next
End Sub
Au fait, je n'ai salué, ni Pascal, ni Hubert, ni mRomain,ni Pierre-jean
Sub Appel()
Dim chap As Shapes
For Each chit In Sheets
If chit.Name <> "bdd" Then
For n = 1 To chit.Shapes.Count
chit.Select
chit.Shapes(n).Select
If TypeName(Selection) <> "Oval" Then
Selection.OnAction = "Rivière"
Else
Selection.OnAction = "Ville"
End If
Next
End If
Next
End Sub
Sub Ville()
Dim vv
v = Application.Caller
vil = v & vbLf & "traversée par : " & vbLf
With Sheets("bdd").Range("H:Z")
Set vv = .Find(v, LookIn:=xlValues)
If Not vv Is Nothing Then
firstAddress = vv.Address
Do
vil = vil & Sheets("bdd").Cells(vv.Row, 1) & vbLf
Set vv = .FindNext(vv)
Loop While Not vv Is Nothing And vv.Address <> firstAddress
End If
End With
MsgBox vil
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Dim s As Shape
'nom = ActiveCell.Value
'Sheets("Seine").Activate
'For Each s In ActiveSheet.Shapes
's.Select
'Selection.ShapeRange.Line.ForeColor.SchemeColor = 12
'Next
'ActiveSheet.Shapes(nom).Select
'Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
'ActiveSheet.Cells(1, 1).Select
'Selection = nom
If Target.Column = 1 Or Target.Column = 2 Then
For Each sh In Sheets
If sh.Name <> "bdd" Then
Application.ScreenUpdating = False
For n = 1 To sh.Shapes.Count
sh.Select
sh.Shapes(n).Select
Selection.ShapeRange.Line.ForeColor.SchemeColor = 12
If sh.Shapes(n).Name = Target.Value Then
Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
ActiveSheet.Cells(1, 1).Select
trouve = True
GoTo fin
End If
Next n
End If
Next sh
End If
fin:
If Not trouve Then
Sheets("bdd").Select
MsgBox ("Pas encore repertorié")
Else
[COLOR=blue]Call test1(Target.Value)[/COLOR]
End If
Application.ScreenUpdating = True
End Sub
[COLOR=blue]Sub test1(Riv)[/COLOR]
[COLOR=blue]ActiveSheet.Shapes(Riv).Select[/COLOR]
[COLOR=blue]taillepage = ActiveSheet.Rows(1).Height * 34[/COLOR]
[COLOR=blue]ActiveWindow.Zoom = Int(taillepage * 95 / Selection.Height)[/COLOR]
[COLOR=blue]ActiveWindow.ScrollRow = Selection.Top / ActiveSheet.Rows(1).Height[/COLOR]
[COLOR=blue]End Sub[/COLOR]
Sub test1(Riv)
ActiveSheet.Shapes(Riv).Select
taillepage = ActiveSheet.Rows(1).Height * 34
Zoom = Int(taillepage * 95 / Selection.Height)
If Zoom > 200 Then Zoom = 200
ActiveWindow.Zoom = Zoom
ActiveWindow.ScrollRow = Int(Selection.Top / ActiveSheet.Rows(1).Height)
If Int(Selection.Left / ActiveSheet.Columns(1).Width) > 0 Then
ActiveWindow.ScrollColumn = Int(Selection.Left / ActiveSheet.Columns(1).Width)
End If
End Sub
Sub test()
Dim laShape As Shape, celluleCentre As Range, centreT As Double, centreL As Double, i As Long
Dim nbColAffichees As Long, nbLigAffichees As Long, decalageCol As Long, decalageLig As Long
'définir la forme
Set laShape = Sheets("Feuil1").Shapes("Forme libre 1")
'calculer les "coordonnées" du centre de la forme
centreT = laShape.Top + laShape.Height / 2
centreL = laShape.Left + laShape.Width / 2
'calculer la cellule correspondante aux "coordonnées"
Set celluleCentre = Sheets("Feuil1").Range("A1")
While celluleCentre.Offset(0, 1).Left < centreL
Set celluleCentre = celluleCentre.Offset(0, 1)
Wend
While celluleCentre.Offset(1, 0).Top < centreT
Set celluleCentre = celluleCentre.Offset(1, 0)
Wend
'vériffier le nombre de lignes et colonnes affichées
nbColAffichees = ActiveWindow.VisibleRange.Columns.Count
nbLigAffichees = ActiveWindow.VisibleRange.Rows.Count
'calculer la cellule (colonne et ligne) à afficher en haut à droite
decalageCol = IIf(celluleCentre.Column - CInt(nbColAffichees / 2) + 1 < 1, 1, celluleCentre.Column - CInt(nbColAffichees / 2) + 1)
decalageLig = IIf(celluleCentre.Row - CInt(nbLigAffichees / 2) + 1 < 1, 1, celluleCentre.Row - CInt(nbLigAffichees / 2) + 1)
'positionner la fenêtre (bugge depuis VBE, la macro doit être lancée depuis le excel)
ActiveWindow.ScrollColumn = decalageCol
ActiveWindow.ScrollRow = decalageLig
End Sub