akasha2114
Messages postés vendredi 11 mai 2007Date d'inscription
22 août 2007
Dernière intervention
-
1 juin 2007 à 15:07 - Dernière réponse : akasha2114
Messages postés vendredi 11 mai 2007Date d'inscription
22 août 2007
Dernière intervention
- 5 juin 2007 à 14:57
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 !!
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
akasha2114
Messages postés vendredi 11 mai 2007Date d'inscription
22 août 2007
Dernière intervention - 5 juin 2007 à 14:57
3
Merci
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
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.
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)...
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 !
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
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.
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.
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 ....
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.
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.
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
a aidé 85 internautes ce mois-ci