arc de cercle dans une feuille excelRésolu

Question

bonjour,

Je cherche à tracer un arc de cercle sur une feuille excel. je connais le centre et les points des départ et d'arrivée de l'arc.
j'ai essayé l'API arc mais le problème c'est que je n'ai pas de handle sur ma feuille
j'ai aussi essayé la shape Arc mais elle me trace un quart de cercle et je ne sais pas comment la modifier pour obtenir l'arc que je veux.
J'ai cherché sur le site, mais je n'ai pas trouvé. si je rejoins un autre message, dites moi lequel !!

Merci d'avance!!

Satanas09 · Accepted Answer

Bonsoir,

S'il sagit de dessiner sur une feuille excel, 

tu peu utiliser les " objets de forme libre" d'Excel..

Sub TraceArcDeCercle()
       'Utilise Trois points , haut-gauche d5 / haut-Gauche E3 / Haut-Gauche F5
    With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, [d5].Left, [d5].Top)
        .AddNodes msoSegmentCurve, msoEditingAuto, [E3].Left, [C3].Top
        .AddNodes msoSegmentCurve, msoEditingAuto, [F5].Left, [F5].Top
        .ConvertToShape.Select
    End With
End Sub

Satanas09 ..... Sapristi, saprista, souris grise et face de rat

jmfmarques · Answer

Bonjour,
Tu ne peux tout simplement pas faire celà  de façon simple (raison : absence de hdc de ta Form sous VBA).

akasha21 · Answer

lol ok
il n'y a bien que les tuteurs de stages pour donner des trucs tordus à faire!!

Utilisateur anonyme · Answer

Salut, 



Fait, quelques recherches, tu obtiendras une solution pour obtenir l'hwnd de ton formulaire.
D'autre recherche te permettront de déterminer l'hdc depuis l'hwnd.



__________
 Kenji

jmfmarques · Answer

Je n'ai pas VBA et ne peux donc vérifier si ceci marche ... pauvre de moi...

Mais toi oui :

(je cherche la fenêtre en 1er plan et, quand je l'ai, j'en extrais le hdc (je crois...) en cliquant sur command1

Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long


Private Sub Command1_Click()
  Do While monhdc = 0
    monhdc = GetForegroundWindow()
    monhdc = GetDC(monhdc)
  Loop
  MsgBox monhdc
End Sub

Ce n'est là qu'une tentative modeste d'un aveugle absolu (puisque je ne peux essayer !)
Essaye et dis-moi (çà m'intéresse quand même de savoir si cela va sous VBA)...

Julien237 · Answer

Mouais, j'avais dja essayé de récupérer le handle d'un userform vba afin de dessiner dessus pour faire des petits jeux où du directx sur les pc de mon ancienne école secondaire et je n'étais arrivé à aucun résultat, il y avait sans cesse des plantage... 
Si tu arrive à quelque chose ca m'intéresse !

 Julien.

cs_lermite222 · Answer

bonjour à tous,
quelques essais et Youpiii,  

Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private MonHdc As Long
Private Declare Function Arc Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long, ByVal X4 As Long, ByVal Y4 As Long) As Long
Private Declare Function ArcTo Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long, ByVal X4 As Long, ByVal Y4 As Long) As Long


Je l'ai mis dans l'évènement activer par facilité, mais comme cela la courbe se redessine à chaque fois. Voir pour la mettre dans ThisWorkbook




Private Sub Worksheet_Activate()
Dim B As Long
MonHdc = 0
  Do While MonHdc = 0
    MonHdc = GetForegroundWindow()
    B = MonHdc
    MonHdc = GetDC(MonHdc)
  Loop
  Range("A1").Value = B
  Range("B1").Value = MonHdc
  
    B = Arc(MonHdc, 120, 500, 320, 400, 320, 400, 780, 500)
End Sub
Evidemment les points sont à adaptés, mais l'arc se dessine bien sur la feuille


Salut jmfmarques , ton idée est la bonne. 
A+
louis

Julien237 · Answer

Mmh j'avais pas du chercher très longtemps dans ma jeunesse ainsi ^^
Merci et pense à valider les réponses de jmfmarques et kenji !

<hr width="100%" size="2" />Julien.

cs_lermite222 · Answer

Mouais........ mais ca ne marche qu'à moitié.
le dessin suis la feuille dans les mouvements de déplacement, mais si la feuille est déplacée plus loin que le dessin et qu'elle revient à l'emplacement d'origine le dessin est disparu, idem si changement de feuille.
Peut donc servir dans une feuille figée (scrool enlevés) et la fonction mise dans activeSheet  
a+
louis


PS: reste encore à trouver les API pour la couleur et l'épaisseur.

jmfmarques · Answer

Etape par étape, Lermitte222, si tu veux bien...
J'attends que réagisse akasha21...


J'espère que tu te rends compte que, dans cette affaire (puisque je ne possède pas VBA), je vais devoir travailler totalement "en aveugle" ?


Tu as un avantage sur moi : tu as VBA ...

Tu peux alors peut-être, te lancer le défi de tenter d'y parvenir, non (en profitant de ton avantage) ? Ca te dit ?
Su oui : welcome to the club ...

jmfmarques · Answer

Tiens lermitte, si tu veux te rendre utile dans ma recherche "à l'aveugle" :
Dis-moi donc quels sont les scalemode possibles d'une Userform sous VBA, s'il te plait...
Toi ou un autre... 
J'ai besoin de le savoir.

Utilisateur anonyme · Answer

VBA, ... ScaleMode, que nénie.
Pas de ScaleMode en VBA ; Tout en points.






__________
Kenji

(

jmfmarques · Answer

Ben voilà, Charles, MERCI pour cette information primordiale ...
Points ? Tout en points ?
C'est un Scalemode, çà !

Je réfléchis et reviens....
Tu veux me servir d'yeux pour essayer et me dire ? (je n'ai pas VBA) ...
Tu veux bien ?
Si oui, je reviens dans moins de 10 minutes avec un essai à te faire faire ...
Dis-moi ....

Utilisateur anonyme · Answer

Allez, mon Excel va être ton cobaye. Ne le tue pas par contre 
J'attend les instructions.







__________
Kenji

(

jmfmarques · Answer

Hé !
DING DING DING ! Plus personne ?
Bip bip ...

Bon alors, qui veut bien me servir d'yeux avec ce code à mettre dans un userforim

Const PS_SOLID =  0
Private Type POINTAPI
  X As Long
  Y As Long
End Type
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Byte
Private monhdc As Long


Private Sub  form _MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  Do While monhdc  = 0
        monhdc = GetForegroundWindow()
        monhdc = GetDC(monhdc)
    Loop
 If Button <> 1 Then Exit Sub
   SetPixelV monhdc, X * 1.32, Y * 1.32, RGB(255, 0, 0)
   DoEvents
End Sub

1) changer Form par ce qui convient sous VBA (je crois que c'est UserForm...)
2) lancer
3) dessiner ( lentement à ce stade s'il vous plait) avec le bouton gauche de la souris gardé enfonce
4) me dore siu quelquechose se dessine et si c'est bien en rouge.

Merci à celui qui voudra bien essayer et me rapporter ce qu'il voit (ou non...)...

Je suis vraiment malheureux de ne pas avoir VBA... pour tester moi-même.

jmfmarques · Answer

Ah t'es là ...
Merci.

Utilisateur anonyme · Answer

Résutat du teste :
Ca dessine des p'tit points rouges sous la souris, hihi ^^
Ma form a la varicelle maintenant.

Le code est parfait, tout marche nickel pour l'instant.







__________
Kenji

(

jmfmarques · Answer

Merci Charles,

on tient donc le "bon bout" apparemment...
Je vais donc avoir du boulot sur la planche pour peaufiner tout celà (je sais que ce ne sera pas facile, mais je suis un entêté de première catégorie)...
Je reviendrai donc sur ce post après un dur labeur (combien de temps ? je n'en ai encore aucune idée... mais ne vais pas lacher... ce n'est pas dans mes habitudes).

Merci d'avoir bien voulu essayer et me rapporter.
Merci également pour cette bonne nouvelle.

Jacques Marqués

jmfmarques · Answer

Allez, Charles, si tu veux bien,

on va maintenant tenter autre chose (ce ne sera plus la varicelle met une peur verte, peut-petre) 

Peux-tu maintenant essayer ceci (avant d'aller dormir) ? C'est la 2ème étape...

Const PS_SOLID =  0
Private Type POINTAPI
  X As Long
  Y As Long
End Type
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long


Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Byte
Private monhdc As Long


Private Sub  form _MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
   Do While monhdc  = 0
        monhdc = GetForegroundWindow()
        monhdc = GetDC(monhdc)
    Loop
   If Button <> 1 Then Exit Sub
   hRPen = CreatePen(PS_SOLID, 10, RGB(0, 255, 0))
   DeleteObject SelectObject(Me.hdc, hRPen)
   LineTo Me.hdc, X * 1.32, Y * 1.32
   DoEvents
End Sub

Et me dire

(j'abuse de toi, hein ?... pardonne-moi...)

akasha21 · Answer

voici mon code, il aidera peut-être d'autres personnes(désolée pour la mise en page, je ne sais pas comment faire autrement)

Private Sub arcdecercle(x1 As Single, y1 As Single, x2 As Single, y2 As Single, x3 As Single, y3 As Single, Optional x4 As Single, Optional y4 As Single, Optional x5 As Single, Optional y5 As Single)

Set ws = ActiveSheet

With ws.Shapes.BuildFreeform(msoEditingAuto, x1, y1)
    .AddNodes msoSegmentCurve, msoEditingAuto, x2, y2
    .AddNodes msoSegmentCurve, msoEditingAuto, x3, y3
    .AddNodes msoSegmentCurve, msoEditingAuto, x4, y4
    .AddNodes msoSegmentCurve, msoEditingAuto, x5, y5
    .ConvertToShape
End With

End Sub

Arc de cercle dans une feuille excel

38 réponses

Votre réponse

Discussions similaires