punky0147

Je finalise et j'envoie (j'ai pas trop le temps de bosser dessus ces jours). Par contre, c'est vrai qu'un des avantages de la version de sechanbask, c'est que l'execution est rapide (la mienne est très longue...).

Je suis à la fois content et décu que tu aies posté cette appli, je travaillais sur un projet similaire (quasiment abouti). J'espère ne pas dire de bétise, mais bon, j'ai l'impression que ca n'est pas encore 100% au point. Je m'explique : j'ai un fond de plan archi, après nettoyable du plan (toutes options cochées), j'ai encore des objets qui n'ont pas la couleur du calque (couleur 8) (textes, polyligne, éléments à l'intérieurs de blocs)... le calque n'est pas vérouillé ni rien... je vois pas trop de quoi ca vient. Les hachures ne sont pas toutes déplacées non plus sur un calque --hachures. Bref, je crois que je vais finaliser ma version plutot que d'essayer de finaliser le code d'un autre. Le prend pas mal, ton code est déjà bien abouti.

ce que je trouve aussi qui complique beaucoup les choses, c'est le nombres d'entités différentes que l'ont peut trouvé sur autocad (lignes, polypignes, multilignes, cercles, splines, ...). Une solution très lourde serait peut-être de décomposé tous les éléments pour revenir à des entités "de base", et ensuite, de poser des boucles qui testent pour tous les points de ces éléments, les distances et angles relatif. Je ne sais pas si c'est réalisable et si ca donnerait qqch

Je crois avoir déjà vu un post évoquant ce genre d'application, mais sans occune solution apportée. Peut-être une personne a-t-elle eu le courage depuis de développer une macro de ce genre : l'objectif : à partir d'une forme connue (composée de divers objets), être capable de reconstituer sous forme de blocs toutes les formes similaires (quelque soit la rotation, et éventuellement l'échelle des objets en question).

Je cherche à faire une extraction d'attributs un peu plus poussée que celle proposée par AutoCAD. Pour celà, j'aimerai recréer une interface similaire à celle de l'extraction d'attributs. Je n'arrive pas à trouver de contrôle me permettant d'avoir des checkbox dans ma liste (style listebox avec multiselect) qui me permette à la fois de cocher ou non la case qui m'intéresse et de sélectionner la ligne qui m'intéresse pour acceder au éléments propre à cet élément. (cf interface d'extraction d'attributs). Existe-t-il un contrôle qui permette de réaliser cette interface d'une manière simple et directe ?

Je cherche à passer tous les éléments d'un document sur un même calque (calque 0 par exemple) et avec pour couleur "du calque", y compris les éléments internes aux blocs. Pour celà, je modifie toutes les définitions des blocs (thisdrawing.blocks) en mettant le calque à 0 et la couleur à "du calque", ensuite, je passe tous les objets du document (lignes, blocs, ...) que je met sur le calque 0 avec la couleur "du calque", je fait un update pour les blocs. Cependant, dans le cas de blocs imbriqués, les attributs se trouvant dans un bloc imbriqué ne changent pas de propriété (malgrés la redéfinition des blocs), et je ne peux pas faire un update, puisque je n'ai pas accès à ces attributs (du fait qu'ils font parti d'un bloc imbriqué dans un autre). Quelle est la solution ? Par exemple : j'ai un bloc A qui contient divers objets, dont un bloc B. Ce bloc B a des attributs. Comment forcé les propriétés de ces attributs ? Comment accèder aux objets qui constitue les bloc A sans décomposé celui-ci ? Si celà semble un peu flou, n'ésitez pas à me demander des précisions.

Merci beaucoup, effectivement, celà fonctionne pour le tracé d'une ligne, mais pour aller plus loin : est-il ou non possible de mettre en stand by l'execution d'une macro pour laisser l'utilisateur agir sur le document ouvert et reprendre ensuite l'execution par appuis par exemple sur un bouton "ok" dans une fenetre non modale affichée. ??? (ou plus simplement par exemple si je veux que l'utilisateur dessine dynamique un cercle, avec le même aspet visuel dynamique que la commande cercle)

Si quelqu'un a une solution, celà m'intéresserait beaucoup, celà fait maintenant bien longtemps que je cherche ce genre de code dans l'aide ou sur le net. Une question un peu différente mais permettant le même genre de gestion utilisateur : Est-il possible de mettre en attente l'application vba jusqu'à la fin d'une commande ; exemple : 1-Le programme tourne 2-On demande à l'utilisateur de tracer une polyligne 3-L'utilisateur dessine sa polyligne (et éventuellement valide par appuie sur un bouton d'une fenetre (fenetre non modale à priori) 4-l'application reprend (on sait alors récupérer le dernier objet tracé (voir tous les objets tracés pendant l'interruption) Merci, celà m'aiderait beaucoup

Peux tu expliquer plus présisément pourquoi ce n'est pas bon quand tu remplaces les points d'insertions des attributs du nouveau bloc par celui des anciens ?

la ligne a copiée est sélectionnée par l'utilisateur ? le dessin2 est un nouveau dessin ou un dessin existant déjà ouvert sous autocad ? Je te donne une réponse dès que je peux, je connais plus le code de tête, mais j'ai déjà fait ce genre de manip, c'est pas très compliqué

Je dirais que tu ne peux pas. Une solution pourrait consister à faire lors du lancement de des macros via tes boutons, une copie des programmes en question soit faite en local et que lorsque la personne le modifie, tu aies ensuite un bouton de mise à jour qui écrase la version commune (qui ne sera donc plus en lecture seule puisque copiée et executée en local). Si quelqu'un a une meilleure idée....

je comprends pas trop pourquoi ca ne marche pas chez toi, moi pour le peux que j'ai testé (4 cas possibles), j'ai pas une erreur, et les lignes sont tracées quand il le faut, ajustées quand il le faut. Je commente un peu le code alors : Sub ligne(x1, y1, X2, y2) Dim sel As AcadSelectionSet Dim P1(0 To 2) As Double Dim P2(0 To 2) As Double Dim listpoint(0 To 9) As Double Dim interpoints As Variant Dim intcodes(0) As Integer Dim varvaleurs(0) As Variant Dim ob As Object Correction_axe_x = 1 'la je met juste la valeur à un, c'était pour moi, pour le tester P1(0) = Log(x1) * Correction_axe_x P1(1) = Log(y1) P1(2) = 0 P2(0) = Log(X2) * Correction_axe_x P2(1) = Log(y2) P2(2) = 0 'Toutes les coordonnées vont servir à tracer une polyligne dénissant les limites du tracé listpoint(0) = X_min listpoint(1) = Y_min listpoint(2) = X_min listpoint(3) = Y_maxi listpoint(4) = X_maxi listpoint(5) = Y_maxi listpoint(6) = X_maxi listpoint(7) = Y_min listpoint(8) = X_min listpoint(9) = Y_min 'on créé trois éléments : 'zone, qui est une polyligne représentant les limites du tracé 'point1, qui est le point de départ de ta ligne (qui sera testé par la suite) 'point2, qui est le point de terminaison de ta ligne (qui sera testé par la suite) Set zone = ThisDrawing.ModelSpace.AddLightWeightPolyline(listpoint) Set point1 = ThisDrawing.ModelSpace.AddPoint(P1) Set point2 = ThisDrawing.ModelSpace.AddPoint(P2) point1.Update point2.Update zone.Update 'On vérifie si la sélection "test" existait déjà ou non deja = 0 For Each sel In ThisDrawing.SelectionSets If sel.Name = "test" Then deja = 1 End If Next sel 'Si la sélection "test" n'existait pas, on la créée If deja = 0 Then Set sel = ThisDrawing.SelectionSets.Add("test") End If Set sel = ThisDrawing.SelectionSets("test") 'On efface la sélection (des fois qu'elles existaient avant) sel.Clear 'On va a présent sélectionner les objets de type "POINT" à l'intérieur des limites donnée par 'X_min, Y_min, ... (je met -1000 et 1000 en axe z, puisqu'il faut définir un espace de sélection à 3 dimensions) intcodes(0) = 0 varvaleurs(0) = "POINT" P1(0) = X_min P1(1) = Y_maxi P1(2) = -1000 P2(0) = X_maxi P2(1) = Y_min P2(2) = 1000 sel.Select acSelectionSetWindow, P1, P2, intcodes, varvaleurs 'La sélection est à présent créée, on vérifie si les points créés (point1 et point2) sont dans cette 'sélection (et donc dans la zone limite de tracage). si point1 est dedant, alors p1ok sera égal à 1 'idem pour point2 (j'utilise le handle des objets pour vérifier si ce sont bien les mêmes) p1ok = 0 p2ok = 0 For Each ob In sel If point1.Handle = ob.Handle Then p1ok = 1 End If If point2.Handle = ob.Handle Then p2ok = 1 End If Next ob 'ensuite, selon le cas, on a besoin de connaitre les coordonnées des intersections entre la zone 'délimitées et la ligne que tu veux tracer 'On trace donc la ligne dans un premier temps Set lineobj = ThisDrawing.ModelSpace.AddLine(point1.Coordinates, point2.Coordinates) 'On récupère les coordonnées des intersections (si il y en a) interpoints = zone.IntersectWith(lineobj, acExtendNone) If UBound(interpoints) <> -1 Then 'si des intersections ont été trouvées If p1ok + p2ok = 0 Then 'si les deux points que tu as donné sont en dehors de la zone lineobj.Delete 'on efface la ligne tracé précédemment et on en retrace une entre P1(0) = interpoints(0) 'les deux points d'intersections P1(1) = interpoints(1) P1(2) = interpoints(2) P2(0) = interpoints(3) P2(1) = interpoints(4) P2(2) = interpoints(5) Set lineobj = ThisDrawing.ModelSpace.AddLine(P1, P2) End If If p1ok = 0 And p2ok = 1 Then 'si uniquement le point2 est dans la zone lineobj.Delete 'on efface la ligne tracée précédemment et on en retrace une P1(0) = interpoints(0) 'entre l'intersection trouvée et point2 P1(1) = interpoints(1) P1(2) = interpoints(2) Set lineobj = ThisDrawing.ModelSpace.AddLine(P1, point2.Coordinates) End If If p1ok = 1 And p2ok = 0 Then 'si uniquement le point1 est dans la zone lineobj.Delete 'on efface la ligne tracée précédemment et on en retrace une P1(0) = interpoints(0) 'entre l'intersection trouvée et point1 P1(1) = interpoints(1) P1(2) = interpoints(2) Set lineobj = ThisDrawing.ModelSpace.AddLine(P1, point1.Coordinates) End If zone.Delete 'on efface la zone tracée point1.Delete 'on efface le premier point dessiné point2.Delete 'on efface le deuxième point dessiné lineobj.Update Else '(si aucune intersection n'a été trouvée) If p1ok + p2ok = 0 Then 'si les deux points étaient en dehors de la zone, on efface tout zone.Delete 'ce qu'on avait dessiné et on ne trace rien point1.Delete point2.Delete lineobj.Delete Update Else 'si les deux points étaient dans la zone, on efface la zone, les zone.Delete 'deux points, mais on conserve la ligne qui avait été tracée point1.Delete point2.Delete lineobj.Update End If End If End Sub bon, j'suis pas très doué pour les commentaires sur les codes, j'espère que t'as saisi un peu la méthode que j'ai utilisée, je ne vois vraiment pas pk ca marche pas chez toi.... bref, redis moi si j'ai fait une bonne gaffe au milieu... c'est toujours bon à savoir

chez moi pas de plantage. tu aurais pas une variable globale de déclarée qui s'appellerait point1 ? (un tableau...) je dis peut-être une bétise, mais je vois pas d'ou ca peut venir ce message d'erreur sinon.... j'sais pas trop, essaye de voir de ton coté, au pire, essaye en rennomant ma variable point1 par un autre nom... tiens moi au courant

je pense répondre à tes attentes avec le code suivant, certains trouveront peut-être ca un peu bourrin, c'est certainement optimisable, je l'ai fait vite fait : Sub ligne(x1, y1, X2, y2) Dim sel As AcadSelectionSet Dim P1(0 To 2) As Double Dim P2(0 To 2) As Double Dim listpoint(0 To 9) As Double Dim interpoints As Variant Dim intcodes(0) As Integer Dim varvaleurs(0) As Variant Dim ob As Object Correction_axe_x = 1 P1(0) = Log(x1) * Correction_axe_x P1(1) = Log(y1) P1(2) = 0 P2(0) = Log(X2) * Correction_axe_x P2(1) = Log(y2) P2(2) = 0 listpoint(0) = X_min listpoint(1) = Y_min listpoint(2) = X_min listpoint(3) = Y_maxi listpoint(4) = X_maxi listpoint(5) = Y_maxi listpoint(6) = X_maxi listpoint(7) = Y_min listpoint(8) = X_min listpoint(9) = Y_min Set zone = ThisDrawing.ModelSpace.AddLightWeightPolyline(listpoint) Set point1 = ThisDrawing.ModelSpace.AddPoint(P1) Set point2 = ThisDrawing.ModelSpace.AddPoint(P2) point1.Update point2.Update zone.Update deja = 0 For Each sel In ThisDrawing.SelectionSets If sel.Name = "test" Then deja = 1 End If Next sel If deja = 0 Then Set sel = ThisDrawing.SelectionSets.Add("test") End If Set sel = ThisDrawing.SelectionSets("test") sel.Clear intcodes(0) = 0 varvaleurs(0) = "POINT" P1(0) = X_min P1(1) = Y_maxi P1(2) = -1000 P2(0) = X_maxi P2(1) = Y_min P2(2) = 1000 sel.Select acSelectionSetWindow, P1, P2, intcodes, varvaleurs p1ok = 0 p2ok = 0 For Each ob In sel If point1.Handle = ob.Handle Then p1ok = 1 End If If point2.Handle = ob.Handle Then p2ok = 1 End If Next ob Set lineobj = ThisDrawing.ModelSpace.AddLine(point1.Coordinates, point2.Coordinates) interpoints = zone.IntersectWith(lineobj, acExtendNone) If UBound(interpoints) <> -1 Then If p1ok + p2ok = 0 Then lineobj.Delete P1(0) = interpoints(0) P1(1) = interpoints(1) P1(2) = interpoints(2) P2(0) = interpoints(3) P2(1) = interpoints(4) P2(2) = interpoints(5) Set lineobj = ThisDrawing.ModelSpace.AddLine(P1, P2) End If If p1ok = 0 And p2ok = 1 Then lineobj.Delete P1(0) = interpoints(0) P1(1) = interpoints(1) P1(2) = interpoints(2) Set lineobj = ThisDrawing.ModelSpace.AddLine(P1, point2.Coordinates) End If If p1ok = 1 And p2ok = 0 Then lineobj.Delete P1(0) = interpoints(0) P1(1) = interpoints(1) P1(2) = interpoints(2) Set lineobj = ThisDrawing.ModelSpace.AddLine(P1, point1.Coordinates) End If zone.Delete point1.Delete point2.Delete lineobj.Update Else If p1ok + p2ok = 0 Then zone.Delete point1.Delete point2.Delete lineobj.Delete Update Else zone.Delete point1.Delete point2.Delete lineobj.Update End If End If End Sub dis moi si ca marche et si c'est bien ca que tu voulais

voyant que tu n'as pas eu de réponse satisfaisante pour l'instant, je veux bien me pencher sur le problème. Envoie moi un mail avec un fichier contenant ces polylignes. Je verrai si je peux faire qqch pour toi....