Discussion :

[benyouyou]

Bonjour,
Dans le cadre de mon stage, je suis amené à coder en VBA, langage que je ne connaissais pas du tout et que je trouve à présent génial! Cependant, je rencontre une grosse difficulté :
Je souhaite récupérer les coordonnées de deux points choisis par l'utilisateur, pour cela j'utilise la fonction GetCursorPos puis je fais appel à la fonction ActiveSheet.Shapes.AddLine pour tracer une ligne entre ces deux points mais au final j'obtiens une ligne qui n'est pas du tout au bon endroit, de même lorsque je souhaite tracer un cercle en prenant comme centre un point choisi par l'utilisateur avec la fonction ActiveSheet.Shapes.AddShape.
J'ai essayé de changer l'origine du repère et de convertir les coordonnées obtenues par GetCursorPos en Pixels (et en Twisps car je ne sais pas en quelle échelle sont les résultats de la fonction GetCursorPos) mais je n'ai eu aucun bons résultats . Voici mon code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
 
Option Explicit
Private Type POINTAPI
    X As Long
    Y As Long
End Type
Global pt1 As POINTAPI
Global pt2 As POINTAPI
 
Sub Add_pipe()
MsgBox "Placez votre curseur à l'endroit du 1er point de votre canalisation et appuyez sur entrée"
 
' L'utilisateur choisit le 1er point pour tracer la canalisation
 
GetCursorPos pt1
 
 
MsgBox "Placez votre curseur à l'endroit du 2eme point de votre canalisation et appuyez sur entrée"
 
 
' L'utilisateur choisit le 2eme point de la canalisation qui sera relié au 1er point pour tracer la canalisation
GetCursorPos pt2
 
ActiveSheet.Shapes.AddLine(pt1.X, pt1.Y, pt2.X, pt2.Y).Select
 
End Sub

Vous remarquerez surement que la façon dont je demande à l'utilisateur de choisir ces points est un petit peu étrange, en effet je n'ai pas trouvé comment obtenir les coordonnées d'un point en cliquant dessus, si vous avez également une solution pour ce problème je suis également preneur

Merci pour votre aide

[parmi]

Bonjour,

Et si tu te servais des coordonnées des cellules ?
Est-ce que ce serait suffisant pour tes besoins ?

du genre

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Dim Pt1Gauche As Double, Pt1Haut As Double, Pt2Gauche As Double, Pt2Haut As Double
 
Sub Macro()
    MsgBox "Double-cliquer une cellule de début, puis une cellule de fin"
End Sub
 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 
    If Pt1Gauche = 0 Then
        Pt1Gauche = ActiveCell.Left + (ActiveCell.Width / 2)  'centre de la cellule
        Pt1Haut = ActiveCell.Top + (ActiveCell.Height / 2)
    ElseIf Pt2Gauche = 0 Then
        Pt2Gauche = ActiveCell.Left + (ActiveCell.Width / 2)
        Pt2Haut = ActiveCell.Top + (ActiveCell.Height / 2)
    End If
 
    If Pt1Gauche > 0 And Pt2Gauche > 0 Then
        ActiveSheet.Shapes.AddLine Pt1Gauche, Pt1Haut, Pt2Gauche, Pt2Haut
        Pt1Gauche = 0: Pt1Haut = 0
        Pt2Gauche = 0: Pt2Haut = 0
    End If
 
    Cancel = True  'désélectionne la cellule
End Sub

[benyouyou]

Bonjour,
Merci pour ta réponse.
le soucis c'est que je souhaite tracer cette ligne et ce cercle sur une image, or quand on insère une image on ne peut plus du tout sélectionner les cellules.
A un moment je pense que le problème peut venir du fait que la fonction GetCursorPos prend comme origine le coin haut gauche de l'écran alors que la fonction pour tracer prend comme origine le coin haut gauche de la feuille excell, j'ai alors écrit :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
' les entier 28 et 210 correspondent aux coordonnées du coin haut gauche de la feuille, étant donné que GetCursorPos prend comme origine le coin haut gauche de l'écran
' alors que la fct Shape.Addline prend comme origine le coin haut gauche de la feuille, il faut soustraire les cooordonnées du coin haut gauche de la feuille aux points
' séléctionnés par l'utilisateur pour avoir un bon tracé
ActiveSheet.Shapes.AddLine(Range("A104").Value - 25, Range("A105").Value - 209, Range("A106").Value - 25, Range("A107").Value - 209).Line.DashStyle = msoLineSingle

Mais sa ne marchait toujours pas. J'ai pensé que ça pouvait être un problème d'unité et que la fonction GetCursorPos donnait des coordonnées en Pixels mais quand je les onvertit en points rien ne s'affiche
Peut être que le problème vient de la conversion des pixels en points, voici le code que j'utilise pour faire cette conversion :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
' convertir les twips en pixels et vice versa
 
Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, _
  ByVal hdc As Long) As Long
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, _
  ByVal nIndex As Long) As Long
 
Const HWND_DESKTOP As Long = 0
Const LOGPIXELSX As Long = 88
Const LOGPIXELSY As Long = 90
 
'--------------------------------------------------
Function TwipsPerPixelX() As Single
'--------------------------------------------------
'Returns the width of a pixel, in twips.
'--------------------------------------------------
  Dim lngDC As Long
  lngDC = GetDC(HWND_DESKTOP)
  TwipsPerPixelX = 1440& / GetDeviceCaps(lngDC, LOGPIXELSX)
  ReleaseDC HWND_DESKTOP, lngDC
End Function
 
'--------------------------------------------------
Function TwipsPerPixelY() As Single
'--------------------------------------------------
'Returns the height of a pixel, in twips.
'--------------------------------------------------
  Dim lngDC As Long
  lngDC = GetDC(HWND_DESKTOP)
  TwipsPerPixelY = 1440& / GetDeviceCaps(lngDC, LOGPIXELSY)
  ReleaseDC HWND_DESKTOP, lngDC
End Function