1. Accueil
  2. Forum Codes-Sources
  3. Visual Basic
  4. Visual Basic 6

Arc de cercle dans une feuille excel [Résolu]

Signaler
Messages postés
14
Date d'inscription
vendredi 11 mai 2007
Statut
Membre
Dernière intervention
22 août 2007
 -
Messages postés
14
Date d'inscription
vendredi 11 mai 2007
Statut
Membre
Dernière intervention
22 août 2007
 -
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!!
A voir également:

38 réponses

1 2
Réponse 1 / 38
Messages postés
18
Date d'inscription
samedi 2 juin 2007
Statut
Membre
Dernière intervention
22 août 2008
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
Réponse 2 / 38
Messages postés
14
Date d'inscription
vendredi 11 mai 2007
Statut
Membre
Dernière intervention
22 août 2007
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
Réponse 3 / 38
Messages postés
7668
Date d'inscription
samedi 5 novembre 2005
Statut
Membre
Dernière intervention
22 août 2014
 26
Bonjour,
Tu ne peux tout simplement pas faire celà  de façon simple (raison : absence de hdc de ta Form sous VBA).
Réponse 4 / 38
Messages postés
14
Date d'inscription
vendredi 11 mai 2007
Statut
Membre
Dernière intervention
22 août 2007
lol ok
il n'y a bien que les tuteurs de stages pour donner des trucs tordus à faire!!
Réponse 5 / 38
Messages postés
3172
Date d'inscription
dimanche 15 février 2004
Statut
Membre
Dernière intervention
9 avril 2017
 30
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
Réponse 6 / 38
Messages postés
7668
Date d'inscription
samedi 5 novembre 2005
Statut
Membre
Dernière intervention
22 août 2014
 26
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)...
Réponse 7 / 38
Messages postés
883
Date d'inscription
vendredi 3 novembre 2000
Statut
Membre
Dernière intervention
3 mars 2009
 7
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.
Réponse 8 / 38
Messages postés
492
Date d'inscription
jeudi 5 avril 2007
Statut
Membre
Dernière intervention
2 juillet 2012
 3
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
Réponse 9 / 38
Messages postés
883
Date d'inscription
vendredi 3 novembre 2000
Statut
Membre
Dernière intervention
3 mars 2009
 7
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.
Réponse 10 / 38
Messages postés
492
Date d'inscription
jeudi 5 avril 2007
Statut
Membre
Dernière intervention
2 juillet 2012
 3
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.
Réponse 11 / 38
Messages postés
7668
Date d'inscription
samedi 5 novembre 2005
Statut
Membre
Dernière intervention
22 août 2014
 26
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 ...
Réponse 12 / 38
Messages postés
7668
Date d'inscription
samedi 5 novembre 2005
Statut
Membre
Dernière intervention
22 août 2014
 26
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.
Réponse 13 / 38
Messages postés
3172
Date d'inscription
dimanche 15 février 2004
Statut
Membre
Dernière intervention
9 avril 2017
 30
VBA, ... ScaleMode, que nénie.
Pas de ScaleMode en VBA ; Tout en points.






__________
Kenji

(


Réponse 14 / 38
Messages postés
7668
Date d'inscription
samedi 5 novembre 2005
Statut
Membre
Dernière intervention
22 août 2014
 26
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 ....
Réponse 15 / 38
Messages postés
3172
Date d'inscription
dimanche 15 février 2004
Statut
Membre
Dernière intervention
9 avril 2017
 30
Allez, mon Excel va être ton cobaye. Ne le tue pas par contre
J'attend les instructions.







__________
Kenji

(


Réponse 16 / 38
Messages postés
7668
Date d'inscription
samedi 5 novembre 2005
Statut
Membre
Dernière intervention
22 août 2014
 26
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.
Réponse 17 / 38
Messages postés
7668
Date d'inscription
samedi 5 novembre 2005
Statut
Membre
Dernière intervention
22 août 2014
 26
Ah t'es là ...
Merci.
Réponse 18 / 38
Messages postés
3172
Date d'inscription
dimanche 15 février 2004
Statut
Membre
Dernière intervention
9 avril 2017
 30
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

(


Réponse 19 / 38
Messages postés
7668
Date d'inscription
samedi 5 novembre 2005
Statut
Membre
Dernière intervention
22 août 2014
 26
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
Réponse 20 / 38
Messages postés
7668
Date d'inscription
samedi 5 novembre 2005
Statut
Membre
Dernière intervention
22 août 2014
 26
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...)


 
Répondre Posez votre question