Tracé d'une flèche selon un angle

P

pascal82

XLDnaute Occasionnel
Bonjour à tous,

J'aimerai visualiser par tracé d' une flèche la direction du vent en automatique mais je ne sais pas comment procéder ni par ou commencer.
PS: Je n'ai pas besoin d'une très grande précision, juste un aspect visuel

Merci pour votre aide
 

Pièces jointes

  • Orientationduvent.xls
    29 KB · Affichages: 157
  • Orientationduvent.xls
    29 KB · Affichages: 153
  • Orientationduvent.xls
    29 KB · Affichages: 155
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
On peut se passer du cercle et utiliser une cellule (B8) de préférence carrée :
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B1:B2]) Is Nothing Then Exit Sub
Dim Cx#, Cy#, ventMax#, vent#, d#, A#, Ar#, Q As Byte
Dim FlipH As Boolean, FlipV1 As Boolean, FlipV2 As Boolean
Dim x1#, y1#, x2#, y2#

With [B8] 'cellule carrée
    Cx = .Left + .Width / 2 'centre
    Cy = .Top + .Height / 2
    ventMax = .Height 'cette taille correspond à la vitesse maximum de 40 m/s
End With

vent = ventMax * [B2] / 40 'amplitude du vent en points
d = -vent / 2 'centre de la flèche au centre du carré en points
A = [B1] Mod 360 'angle en degrés
Ar = A * Application.Pi / 180 'angle en radians
Q = 1 + Int(A / 90) 'quart utilisé

With ActiveSheet.Shapes("Vent") 'j'ai renommé la shape
    FlipH = Q < 3 And [Quart] > 2 Or Q > 2 And [Quart] < 3
    FlipV1 = (Q = 1 Or Q = 4) And ([Quart] = 2 Or [Quart] = 3)
    FlipV2 = (Q = 2 Or Q = 3) And ([Quart] = 1 Or [Quart] = 4)
    If FlipH Then .Flip msoFlipHorizontal
    If FlipV1 Or FlipV2 Then .Flip msoFlipVertical
    ThisWorkbook.Names.Add "Quart", Q 'mémorisation
    x1 = Cx + d * Sin(Ar)
    y1 = Cy - d * Cos(Ar)
    x2 = Cx + (d + vent) * Sin(Ar)
    y2 = Cy - (d + vent) * Cos(Ar)
    .Width = Abs(x1 - x2)
    .Height = Abs(y1 - y2)
    .Left = Application.Min(x1, x2)
    .Top = Application.Min(y1, y2)
End With

End Sub
 

Pièces jointes

  • Orientation du vent.xlsm
    21 KB · Affichages: 6
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour lanier2, le forum,

Bon voyez le fichier joint avec 6 flèches dans 6 cellules.

Pour adapter la macro il suffit de faire une boucle de 1 à 6 :
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B1:G2]) Is Nothing Then Exit Sub
Dim n%, Cx#, Cy#, ventMax#, vent#, d#, A&, Ar#, Q As Byte
Dim Quart As Byte, FlipH As Boolean, FlipV1 As Boolean, FlipV2 As Boolean
Dim x1#, y1#, x2#, y2#

For n = 1 To 6 'pour 6 cellules et 6 flèches

    With [A5].Offset(, n) 'cellule carrée
        Cx = .Left + .Width / 2 'centre
        Cy = .Top + .Height / 2
        ventMax = .Height 'cette taille correspond à la vitesse maximum de 40 m/s
    End With

    vent = ventMax * [A2].Offset(, n) / 40 'amplitude du vent en points
    d = -vent / 2 'centre de la flèche au centre du carré en points
    With [A1].Offset(, n)
        If .Value < 0 Then .Value = Abs(.Value) 'nombre positif
        A = .Value Mod 360 'angle en degrés entier
    End With
    Ar = A * Application.Pi / 180 'angle en radians
    Q = 1 + Int(A / 90) 'quart utilisé

    With ActiveSheet.Shapes("Vent" & n) 'j'ai renommé la shape
        Quart = Evaluate("Quart" & n) 'nom défini
        FlipH = Q < 3 And Quart > 2 Or Q > 2 And Quart < 3
        FlipV1 = (Q = 1 Or Q = 4) And (Quart = 2 Or Quart = 3)
        FlipV2 = (Q = 2 Or Q = 3) And (Quart = 1 Or Quart = 4)
        If FlipH Then .Flip msoFlipHorizontal
        If FlipV1 Or FlipV2 Then .Flip msoFlipVertical
        ThisWorkbook.Names.Add "Quart" & n, Q 'mémorisation
        x1 = Cx + d * Sin(Ar)
        y1 = Cy - d * Cos(Ar)
        x2 = Cx + (d + vent) * Sin(Ar)
        y2 = Cy - (d + vent) * Cos(Ar)
        .Width = Abs(x1 - x2)
        .Height = Abs(y1 - y2)
        .Left = Application.Min(x1, x2)
        .Top = Application.Min(y1, y2)
    End With
    
Next

End Sub
A+
 

Pièces jointes

  • Orientation du vent.xlsm
    22.2 KB · Affichages: 9
Vote positif 0 Vote négatif
L

lanier2

XLDnaute Nouveau
job75 à dit:
On peut se passer du cercle et utiliser une cellule (B8) de préférence carrée :
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B1:B2]) Is Nothing Then Exit Sub
Dim Cx#, Cy#, ventMax#, vent#, d#, A#, Ar#, Q As Byte
Dim FlipH As Boolean, FlipV1 As Boolean, FlipV2 As Boolean
Dim x1#, y1#, x2#, y2#

With [B8] 'cellule carrée
    Cx = .Left + .Width / 2 'centre
    Cy = .Top + .Height / 2
    ventMax = .Height 'cette taille correspond à la vitesse maximum de 40 m/s
End With

vent = ventMax * [B2] / 40 'amplitude du vent en points
d = -vent / 2 'centre de la flèche au centre du carré en points
A = [B1] Mod 360 'angle en degrés
Ar = A * Application.Pi / 180 'angle en radians
Q = 1 + Int(A / 90) 'quart utilisé

With ActiveSheet.Shapes("Vent") 'j'ai renommé la shape
    FlipH = Q < 3 And [Quart] > 2 Or Q > 2 And [Quart] < 3
    FlipV1 = (Q = 1 Or Q = 4) And ([Quart] = 2 Or [Quart] = 3)
    FlipV2 = (Q = 2 Or Q = 3) And ([Quart] = 1 Or [Quart] = 4)
    If FlipH Then .Flip msoFlipHorizontal
    If FlipV1 Or FlipV2 Then .Flip msoFlipVertical
    ThisWorkbook.Names.Add "Quart", Q 'mémorisation
    x1 = Cx + d * Sin(Ar)
    y1 = Cy - d * Cos(Ar)
    x2 = Cx + (d + vent) * Sin(Ar)
    y2 = Cy - (d + vent) * Cos(Ar)
    .Width = Abs(x1 - x2)
    .Height = Abs(y1 - y2)
    .Left = Application.Min(x1, x2)
    .Top = Application.Min(y1, y2)
End With

End Sub
Cliquez pour agrandir...
Merci beaucoup
Top
David
 
Vote positif 0 Vote négatif
L

lanier2

XLDnaute Nouveau
job75 à dit:
Bonjour lanier2, le forum,

Bon voyez le fichier joint avec 6 flèches dans 6 cellules.

Pour adapter la macro il suffit de faire une boucle de 1 à 6 :
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B1:G2]) Is Nothing Then Exit Sub
Dim n%, Cx#, Cy#, ventMax#, vent#, d#, A&, Ar#, Q As Byte
Dim Quart As Byte, FlipH As Boolean, FlipV1 As Boolean, FlipV2 As Boolean
Dim x1#, y1#, x2#, y2#

For n = 1 To 6 'pour 6 cellules et 6 flèches

    With [A5].Offset(, n) 'cellule carrée
        Cx = .Left + .Width / 2 'centre
        Cy = .Top + .Height / 2
        ventMax = .Height 'cette taille correspond à la vitesse maximum de 40 m/s
    End With

    vent = ventMax * [A2].Offset(, n) / 40 'amplitude du vent en points
    d = -vent / 2 'centre de la flèche au centre du carré en points
    With [A1].Offset(, n)
        If .Value < 0 Then .Value = Abs(.Value) 'nombre positif
        A = .Value Mod 360 'angle en degrés entier
    End With
    Ar = A * Application.Pi / 180 'angle en radians
    Q = 1 + Int(A / 90) 'quart utilisé

    With ActiveSheet.Shapes("Vent" & n) 'j'ai renommé la shape
        Quart = Evaluate("Quart" & n) 'nom défini
        FlipH = Q < 3 And Quart > 2 Or Q > 2 And Quart < 3
        FlipV1 = (Q = 1 Or Q = 4) And (Quart = 2 Or Quart = 3)
        FlipV2 = (Q = 2 Or Q = 3) And (Quart = 1 Or Quart = 4)
        If FlipH Then .Flip msoFlipHorizontal
        If FlipV1 Or FlipV2 Then .Flip msoFlipVertical
        ThisWorkbook.Names.Add "Quart" & n, Q 'mémorisation
        x1 = Cx + d * Sin(Ar)
        y1 = Cy - d * Cos(Ar)
        x2 = Cx + (d + vent) * Sin(Ar)
        y2 = Cy - (d + vent) * Cos(Ar)
        .Width = Abs(x1 - x2)
        .Height = Abs(y1 - y2)
        .Left = Application.Min(x1, x2)
        .Top = Application.Min(y1, y2)
    End With
   
Next

End Sub
A+
Cliquez pour agrandir...
Génial ca
Exactement mon besoin
Bonne journée
David
 
Vote positif 0 Vote négatif
L

lanier2

XLDnaute Nouveau
lanier2 à dit:
Génial ca
Exactement mon besoin
Bonne journée
David
Cliquez pour agrandir...
Juste une modif
J'ai essayé en mettant les données en colonne
Et j'ai un message d'erreur

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [E15:F20]) Is Nothing Then Exit Sub
Dim n%, Cx#, Cy#, ventMax#, vent#, d#, A&, Ar#, Q As Byte
Dim Quart As Byte, FlipH As Boolean, FlipV1 As Boolean, FlipV2 As Boolean
Dim x1#, y1#, x2#, y2#

For n = 1 To 6 'pour 6 cellules et 6 flèches

With [A5].Offset(, n) 'cellule carrée
Cx = .Left + .Width / 2 'centre
Cy = .Top + .Height / 2
ventMax = .Height 'cette taille correspond à la vitesse maximum de 40 m/s
End With

vent = ventMax * [F14].Offset(, n) / 40 'amplitude du vent en points
d = -vent / 2 'centre de la flèche au centre du carré en points
With [E14].Offset(, n)
If .Value < 0 Then .Value = Abs(.Value) 'nombre positif
A = .Value Mod 360 'angle en degrés entier
End With
Ar = A * Application.Pi / 180 'angle en radians
Q = 1 + Int(A / 90) 'quart utilisé

With ActiveSheet.Shapes("Vent" & n) 'j'ai renommé la shape
Quart = Evaluate("Quart" & n) 'nom défini
FlipH = Q < 3 And Quart > 2 Or Q > 2 And Quart < 3
FlipV1 = (Q = 1 Or Q = 4) And (Quart = 2 Or Quart = 3)
FlipV2 = (Q = 2 Or Q = 3) And (Quart = 1 Or Quart = 4)
If FlipH Then .Flip msoFlipHorizontal
If FlipV1 Or FlipV2 Then .Flip msoFlipVertical
ThisWorkbook.Names.Add "Quart" & n, Q 'mémorisation
x1 = Cx + d * Sin(Ar)
y1 = Cy - d * Cos(Ar)
x2 = Cx + (d + vent) * Sin(Ar)
y2 = Cy - (d + vent) * Cos(Ar)
.Width = Abs(x1 - x2)
.Height = Abs(y1 - y2)
.Left = Application.Min(x1, x2)
.Top = Application.Min(y1, y2)
End With

Next

End Sub
 
Vote positif 0 Vote négatif
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour tout le monde,
"Just for the fun" en utilisant ShapeRange.Rotation,
1727610961090.png
 

Pièces jointes

  • Orientationduvent.xls
    192 KB · Affichages: 3
Dernière édition:
Vote positif 0 Vote négatif
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
Re,
Et comme vous utilisez à priori une version inférieure à 2013 (fichier xls) alors vous pouvez aussi avoir un mouvement de l'aiguille de la boussole.
( au delà cette fonctionnalité a été supprimée )
Test4.gif
 

Pièces jointes

  • Copie de Orientationduvent V4.xls
    276 KB · Affichages: 2
Dernière édition:
Vote positif 0 Vote négatif
jurassic pork

jurassic pork

XLDnaute Occasionnel
Hello,
Si on doit tracer des flèches dans des cellules qui sont petites et rectangulaires voici une procédure qui fait ce tracé :
DrawArrow(Cellule, Nom, Taille, rotangle)
Cellule est la cellule où l'on doit tracer la flèche qui sera placée au milieu de la cellule. La longueur de la flèche sera fixe et égale à la hauteur de la ligne moins 4 pixels.
Nom est le nom qui sera donné à la forme.
Taille permet de choisir la taille de la flèche 0 petite , 1 moyenne, 2 grande à choisir en fonction de la taille des cellules.
rotangle permet de choisir l'angle de rotation de la flèche . 0 = 0° = vent du nord poisson mort
VB: 
Sub DrawArrow(Cellule, Nom, Taille, rotangle)
    Dim arrowType As MsoConnectorType
    arrowType = msoConnectorStraight
    ActiveSheet.Shapes.AddConnector(arrowType, _
        Cellule.Left + (Cellule.Width / 2), Cellule.Top + 2, _
        Cellule.Left + (Cellule.Width / 2), Cellule.Top + Cellule.Height - 2).Select
    Select Case Taille
        Case 0 ' small
           Selection.ShapeRange.Line.EndArrowheadLength = msoArrowheadShort
           Selection.ShapeRange.Line.EndArrowheadWidth = msoArrowheadNarrow
           Selection.ShapeRange.Line.Weight = 0.75
        Case 1 ' medium
           Selection.ShapeRange.Line.EndArrowheadLength = msoArrowheadLengthMedium
           Selection.ShapeRange.Line.EndArrowheadWidth = msoArrowheadWidthMedium
           Selection.ShapeRange.Line.Weight = 1
        Case 2 ' wide
           Selection.ShapeRange.Line.EndArrowheadLength = msoArrowheadLong
           Selection.ShapeRange.Line.EndArrowheadWidth = msoArrowheadWide
           Selection.ShapeRange.Line.Weight = 1.5
    End Select
    Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle
    Selection.ShapeRange.Line.ForeColor.RGB = RGB(0, 128, 255)
    Selection.Name = Nom
    CenterRotation ActiveSheet.Shapes(Nom), rotangle
End Sub
Sub CenterRotation(shape As shape, ByVal rotangle As Double)
    Dim rad As Double, x As Double, y As Double
    Dim x1 As Double, x2 As Double
    x = shape.Top: y = shape.Left
    x1 = (shape.Width / 2) * -1
    x2 = shape.Height
    rad = rotangle * Atn(1) / 45
    With shape
        .Top = x + (.Height - .Width / 2 - x1 - x2) * (1 - Cos(rad)) / 2
        .Left = y + (.Height - .Width / 2 - x1 - x2) * Sin(rad) / 2
        .Rotation = rotangle
    End With
End Sub
Sub TracerFlèches()
Dim Cell, i As Integer, a As Double
i = 0: a = 0
For Each Cell In ActiveSheet.Range("A1:H1")
    DrawArrow Cell, "Flèche" & CStr(i), 0, a
    i = i + 1: a = a + 45
Next
a = 0
For Each Cell In ActiveSheet.Range("A2:H2")
    DrawArrow Cell, "Flèche" & CStr(i), 1, a
    i = i + 1: a = a + 45
Next
a = 0
For Each Cell In ActiveSheet.Range("A3:H3")
    DrawArrow Cell, "Flèche" & CStr(i), 2, a
    i = i + 1: a = a + 45
Next
End Sub
Flèches.png

Ami calmant, J.P
 
Dernière édition:
Vote positif 0 Vote négatif
L

lanier2

XLDnaute Nouveau
Un petit souci
Si je mets n=5 ca fonctionne pour 5 fleche, n=6 ca fonctionne pour 6, mais n=7 ca fonctionne pas meme en creant 1 fleche nommée Vent7

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [E15:F21]) Is Nothing Then Exit Sub
Dim n%, Cx#, Cy#, ventMax#, vent#, d#, A&, Ar#, Q As Byte
Dim Quart As Byte, FlipH As Boolean, FlipV1 As Boolean, FlipV2 As Boolean
Dim x1#, y1#, x2#, y2#

For n = 1 To 7 'pour 6 cellules et 6 flèches

With [D14].Offset(n) 'cellule carrée
Cx = .Left + .Width / 2 'centre
Cy = .Top + .Height / 2
ventMax = .Height 'cette taille correspond à la vitesse maximum de 40 m/s
End With

vent = ventMax * [F14].Offset(n) / 13 'amplitude du vent en points
d = -vent / 2 'centre de la flèche au centre du carré en points
With [E14].Offset(n)
If .Value < 0 Then .Value = Abs(.Value) 'nombre positif
A = .Value Mod 360 'angle en degrés entier
End With
Ar = A * Application.Pi / 180 'angle en radians
Q = 1 + Int(A / 90) 'quart utilisé

With ActiveSheet.Shapes("Vent" & n) 'j'ai renommé la shape
Quart = Evaluate("Quart" & n) 'nom défini
FlipH = Q < 3 And Quart > 2 Or Q > 2 And Quart < 3
FlipV1 = (Q = 1 Or Q = 4) And (Quart = 2 Or Quart = 3)
FlipV2 = (Q = 2 Or Q = 3) And (Quart = 1 Or Quart = 4)
If FlipH Then .Flip msoFlipHorizontal
If FlipV1 Or FlipV2 Then .Flip msoFlipVertical
ThisWorkbook.Names.Add "Quart" & n, Q 'mémorisation
x1 = Cx + d * Sin(Ar)
y1 = Cy - d * Cos(Ar)
x2 = Cx + (d + vent) * Sin(Ar)
y2 = Cy - (d + vent) * Cos(Ar)
.Width = Abs(x1 - x2)
.Height = Abs(y1 - y2)
.Left = Application.Min(x1, x2)
.Top = Application.Min(y1, y2)
End With

Next

End Sub
 
Vote positif 0 Vote négatif

Discussions similaires

F
  • Question
XL 2019 Attribuer une notre selon un critère donné ?
Réponses
6
Affichages
789
Deadpool_CC
Deadpool_CC
M
  • Résolu(e)
Microsoft 365 enregistrement copie du classeur ouvert avec mot de passe et incrémentation
2
Réponses
27
Affichages
1 K
meyscal
M
chostra
  • Question
Microsoft 365 problème navigation et selection dans Combobox-Liste de choix
Réponses
4
Affichages
2 K
chostra
chostra
S
  • Résolu(e)
XL 2016 Automatisé un planning bénévole pour un tournoi
5 6 7
Réponses
94
Affichages
8 K
simo161616
S
XLSM75
  • Question
XL 2019 Extraire données d'un classeur vers un autre en réorganisant et renommant les colonnes
Réponses
10
Affichages
2 K
XLSM75
XLSM75
A
  • Question
Microsoft 365 Insérer nom de l'onglet dans un chemin
Réponses
5
Affichages
2 K
vgendron
vgendron
L
  • Résolu(e)
XL 2016 Couper/coller avancé + SUPP ligne si possible
Réponses
9
Affichages
1 K
LumberJAAK
L
A
  • Question
XL 2016 Affecter une couleur en fonction d'une tranche horaire / un état
Réponses
3
Affichages
2 K
Arthur_A
A
L
  • Résolu(e)
XL 2019 Liaison de données Word Excel et "méthode range de l'objet global a échoué"
Réponses
12
Affichages
3 K
Staple1600
Staple1600
B
  • Question
Compter le nombre d'occurrences d'une valeur avec un critère OU un autre OU un autre
Réponses
5
Affichages
905
R@chid
R@chid

Membres actuellement en ligne

8 membres et 69 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 638
Messages
2 111 468
Membres
111 161
dernier inscrit
KARIMTAPSO