coordonnes xyz des points sommets des polylignes

[ch.zara]

bonjour,

je cherche un programme lisp ou vba autocad qui permet de créer un fichier coordonnées xyz des sommets des polylignes 3d ,

la commande liste de autocad semble trop fastidiieuse à l'utliser comme j'ai bcp bcp de polylignes(pour mon cas ,mes polylignes sont des courbes de niveau )

 

j'en serais tres reconnaisante si vous pourriez m'aider

[lovecraft]

Bonsoir,

Voici en lisp:

 

 ;Programme pour creer un listing en cliquant une polyligne


(defun c:xypoly ()

(setq ent (car (entsel "\nCliquez une polyligne :")))
(setq bdent (entget ent))
(setq typent (cdr (assoc 0 bdent)))
(if (= typent "LWPOLYLINE")
   (progn
(setq nomfic "C:/XYPOLY2D.txt")
(setq fic (open nomfic "w"))
(setq i 0)
(repeat (length bdent)
	(setq entit (nth i bdent))
	(setq codeentit (car entit))
	(if (= codeentit 10)
		(progn
			(setq xentit (car (cdr entit)))
			(setq yentit (cadr (cdr entit)))
			(setq xyentit (strcat (rtos xentit 2 3) " " (rtos yentit 2 3)))
			(write-line xyentit fic)
		);fin du progn
	);fin du if
(setq i (+ i 1))
);fin du repeat
   );fin du progn
);fin du if

(if (= typent "POLYLINE")
   (progn
(setq nomfic "C:/XYPOLY3D.txt")
(setq fic (open nomfic "w"))
(setq i 0)
(setq ent1 (entnext ent))
(setq bdent1 (entget ent1))
(setq typent1 (cdr (assoc 0 bdent1)))
(while (= typent1 "VERTEX")
	(setq code10 (cdr (assoc 10 bdent1)))
	(setq xentit (car code10))
	(setq yentit (cadr code10))
	(setq zentit (caddr code10))
	(setq xyzentit (strcat (rtos xentit 2 3) " " (rtos yentit 2 3) " " (rtos zentit 2 3)))
	(write-line xyzentit fic)
	(setq ent1 (entnext ent1))
	(setq bdent1 (entget ent1))
	(setq typent1 (cdr (assoc 0 bdent1)))
);fin du while
   );fin du progn
);fin du if

(close fic)

);fin du defun c:xypoly

 

et voici sous excel

Attention il faut ouvrir excel en premier.

 

 Sub RECUP_XYZ()

Static applicationexcel As Object
Static classeurexcel As Object
Static feuilleexcel As Object
Dim valeur As String

Set applicationexcel = GetObject(, "excel.application") ' ouvre le classeur courant
Set applicationexcel = CreateObject("excel.application")


applicationexcel.Application.Visible = True
Set classeurexcel = applicationexcel.Workbooks.Add
Set feuilleexcel = applicationexcel.ActiveSheet


Dim selObj As AcadObject

Dim retCoord As Variant
Dim k, l As Integer
Dim nbr_of_segments As Long
Dim nbr_of_vertices As Long
Dim segment As Long
On Error Resume Next
ThisDrawing.Utility.GetEntity selObj, "Sélectionner une polyligne."



retCoord = selObj.Coordinates
h = selObj.Count

segment = 0
k = LBound(retCoord)
l = UBound(retCoord)
nbr_sommet = (((l - k) + 1) / 3)

'Ecriture dans excel
Dim i As Integer 'boucle x
Dim ii As Integer
Dim u As Integer 'boucle y
Dim j As Integer 'boucle z


'presentation tableau
feuilleexcel.Cells(6, 1).Value = "X"
feuilleexcel.Cells(6, 1).HorizontalAlignment = xlCenter
feuilleexcel.Cells(6, 2).Value = "Y"
feuilleexcel.Cells(6, 2).HorizontalAlignment = xlCenter
feuilleexcel.Cells(6, 3).Value = "Z"
feuilleexcel.Cells(6, 3).HorizontalAlignment = xlCenter

ii = 0
For i = k To l Step 3
feuilleexcel.Cells(7 + ii, 1).Value = retCoord(i)
ii = ii + 1
Next i

ii = 0
For u = 1 To l Step 3
feuilleexcel.Cells(7 + ii, 2).Value = retCoord(u)
ii = ii + 1
Next u

ii = 0
For j = 2 To l Step 3
feuilleexcel.Cells(7 + ii, 3).Value = retCoord(j)
ii = ii + 1
Next j

' Determine the number of segments in the polyline.
If selObj.Closed Then
nbr_of_segments = nbr_sommet
Else
nbr_of_segments = nbr_sommet - 1
End If

MsgBox "La polyligne sélectionnée est composée de " & nbr_of_segments & " segments."





End Sub

 

Bonne utilisation

 

LB

 

 

 

 

 

 

[ch.zara]

merci bien

quoique j'aurais bien aimé que ta routine soit conçue avec vba autocad au lieu de vba exel,et de stocker les coordonnées après dans un fichier texte, ça serait plus pratique , n'est ce pas!

oh ca reste une suggestion,en tout cas merci

[fabdo]

lovecraft,

 

Peut-on reprendre cette vba d' excel et la transformer pour vba microstation?

 

Salut.

[lovecraft]

Bonsoir,

 

je ne connais pas tres bien microstation il faudrait demander a des spécialiste pour qu'il adapte cette routine ou voir en creer une nouvelle.

 

@plus

 

LB

[fabdo]

salut,

 

Ok lovecraft merci tout de même.

 

bye