Calcul de longueur

[azrael]

Bonjour,

 

Bonjour,

 

Voici un petit programme (qui n'est pas de moi) permettant de calculer la somme des lignes dans un layer bien précis (LINO PERIM). Malheureusement, avec la version 2008, celà bug presque à chaque fois !

 

Si quelqu'un peut me dépanner, je l'en remercie d'avance :D

 

Option Explicit

 

Sub ad_TotalLines()

Dim adLine As AcadObject

Dim adTotalLen As Double

Dim adWorkLayer As String

adWorkLayer = "LINO PERIM"

adTotalLen = 0

For Each adLine In ThisDrawing.ModelSpace

If adLine.ObjectName = "AcDbLine" Then

If adLine.Layer = adWorkLayer Then

adTotalLen = adTotalLen + adLine.Length

End If

End If

Next adLine

adTotalLen = Round(adTotalLen, 2)

MsgBox "Total of line segments" & vbCr & _

"on layer " & adWorkLayer & " is:" & vbCr & _

adTotalLen

End Sub

 

Public Function Round(adNum As Double, adPlaces As Integer) As Double

Dim adTmp As Integer

adNum = CDbl(adNum)

adTmp = Fix(adNum)

adNum = CInt((adNum - adTmp) * 10 ^ adPlaces)

Round = adTmp + adNum / 10 ^ adPlaces

End Function

[didier]

coucou

 

c'est souvent ardu de lire le programme d'un autre,

et là, c'est le cas.

 

en revanche, souhaites-tu la même chose en VBA pour AutoCad ?

 

amicalement

[azrael]

Didier,

 

Désolé pour cette réponse tardive mais j'ai eu quelques problèmes avec mon PC. Oui, ce n'est pas toujours facile de lire le programme d'un autre. Si tu as quelques choses pour moi en lisp ou en VBA, cela serait avec grand plaisir.

 

Merci d'avance !

 

Azrael

[(gile)]

Salut,

 

Peut être une réponse en LISP : Long_Line sur cette page.

[azrael]

Gile,

 

C'est bien mieux qu'une réponse. C'est super car on peut choisir la couche !

 

Merci beaucoups !

 

Azrael

[tecnopat]

Salut

 

Moi j'ai fait une macro qui permet de calculer la longueur des objets (arcs, lignes ou polylignes)que l'on peut sélectionner, c'est très souple. Celà affiche le résultat dans une Message Box.

Je vous file le code :

 

Sub longueurtotale()
' Create the selection set
Dim sset As Object
'ThisDrawing.SelectionSets("SS1").Delete
Set sset = ThisDrawing.SelectionSets.Add("SS1")

' Prompt the user to select objects
sset.SelectOnScreen


' Define the variable
Dim compteur As Single

' Loop through all entities in the selection
' set and assign the xdata to each entity
Dim obj As AcadEntity
Dim obj2 As AcadObject
Dim Line As AcadLine
Dim arc As AcadArc
Dim poly As AcadLWPolyline

For Each obj In sset
'MsgBox ("type de l'objet : " & obj.EntityType)
If obj.EntityType = 19 Then
Set Line = obj
compteur = compteur + Line.Length
End If
If obj.EntityType = 4 Then
Set arc = obj
compteur = compteur + arc.ArcLength
End If
If obj.EntityType = 24 Then
Set poly = obj
compteur = compteur + poly.Length
End If
Next obj

MsgBox ("longueur totale :" & compteur & "m")
ThisDrawing.SelectionSets("SS1").Delete

End Sub 

 

Bonne utilisation. Toutes les suggestions d'amélioration sont les bienvenues.

J'ai fait la même chose pour les surfaces (hachures et polylignes fermées), et j'ai fait des macros aussi pour calculer des données technique à partir du nombre de blocs sélectionnés...

Si çà intéresse des gens, qu'ils me le disent, je leur donnerai mon code.

 

A++

[lili2006]

Bonsoir à toutes et tous,

 

Que trop peu d'occasion sur ce forum pour voir des solutions en VBA, alors

Si çà intéresse des gens, qu'ils me le disent, je leur donnerai mon code.

 

OUIOUIoui,

 

Marche très bien sur une V2008 full (longueurtotale).

Merci du partage.

[speedy]

Bonjour

 

y a ce code qui est en liaison avec un fichier excel....

Sub Longueur_poly()

Dim Baselect As AcadSelectionSet

Dim BaObjet As Object

Dim length As Long

Dim lengthT As Long

Dim MyXL As Object

Dim feuille As Worksheet

Dim cellule As Range

 

'Adapté par Michel a "multi selection"

 

lengthT = 0

length = 0

Set Baselect = ThisDrawing.SelectionSets.Add("ac")

Call Baselect.SelectOnScreen

For Each BaObjet In Baselect

length = BaObjet.length

lengthT = lengthT + length

Next

' ne pas oublier de créer le fichier excel

Set MyXL = GetObject("d:\Classeur1.XLS")

MyXL.Application.Visible = True

MyXL.Parent.Windows(1).Visible = True

Set feuille = MyXL.Worksheets("Feuil1")

'enregistre dans la cellule B2

feuille.Cells(2, 2).Value = lengthT

'Quitte excel qui demandera un enregistrement éventuel

MyXL.Application.Quit

 

'ThisDrawing.SelectionSets.Item("ac").Delete

MsgBox lengthT

 

End Sub

 

pourrait on l'améliorer....

 

Michel a

[lili2006]

Bonjour à toutes et tous,

 

speedy, sur une V2008, j'ai ce message, ou bien ais-je oublié quelque chose ?

 

<!--url{0}-->

[mdsv31]

Bonsoir Lili2006

 

Pour ton soucis, il faut que dans l'editeur VBA d'autocad, que tu ailles dans le menu Outils, ensuite Référence, et dans la liste il faut selectionner la librairie qui est en relation avec Excel.

 

Ensuite le code devrais marcher (Normalement)

 

 

@+

MDSV31

 

[lili2006]

Bonsoir à toutes et tous,

 

En effet, mdsv31, j'avais complétement oublié !

 

Par contre, maintenant, j'i ce message =>

 

<!--url{0}-->

[nazemrap]

Hello,

 

ça c 'est le debogage, est-ce un message comme ça ?

 

http://www.premiumwanadoo.com/technaulogis/cadxp/msg_err_01.jpg

[lili2006]

Re,

 

Absolument nazemrap, une idée ?

[nazemrap]

Hello,

 

je ne veux pas interpréter le code fourni par Speedy, mais cette avant dernière ligne:

 'ThisDrawing.SelectionSets.Item("ac").Delete

est marquée comme un commentaire donc pas exécutée.

Or elle est censé "détruire" la sélection créée en haut.

Ceci n 'ayant pas été fait, à la nouvelle exécution du code, le jeu de sélection existant déjà, un message d 'erreur est généré.

[lili2006]

Bonjour à toutes et tous,

 

nazemrap, si je veux tester ce code, que doi-je rajouter pour que celui-ci fonctionne ?

 

Merci d'avance.

 

[lesourd2]

Salut

 

si je veux tester ce code, que doi-je rajouter pour que celui-ci fonctionne

 

Enlever l'apostrophe au tout debut de la ligne.

 

 'ThisDrawing.SelectionSets.Item("ac").Delete

 

@+

[lili2006]

Re,

 

Merci lesourd2

 

Maintenant, j'ai cette erreur =>

 

<!--url{0}-->

[nazemrap]

Bonjour,

 

Sans doute n 'as-tu pas créé le classeur demandé à l 'endroit souhaité.

En effet, dans le cas présent, le classeur doit exister.

[speedy]

Bonsoir

 

tu dois créer un fichier excel ...le nommer comme tu veux à condition de modifier la ligne...

Set MyXL = GetObject("lecteur:\nom_du_fichier.XLS")

 

 

@+

 

Michel a

[lili2006]

Bonsoir à toutes et tous,

 

Merci pour vos réponses, c'était bien ça !

 

Set MyXL = GetObject("lecteur:\nom_du_fichier.XLS")

 

J'ai ainsi créé mon propre fichier.

 

@+

[tecnopat]

Bonjour Lili2006

 

Je reviensà la macro longeurtotale, pour arrondir le récultat on peut faire :

 

MsgBox ("longueur totale :" & Format(compteur, "0.00") & "m") 

 

à la place de :

 

 MsgBox ("longueur totale :" & compteur & "m")

 

c'est plus sympa, non ?

 

D'autre part, voici l'équivalent de "longueurtotale" pour les surfaces (hachures, objets fermés):

 

Sub airetotale()
' Create the selection set
Dim sset As Object
'ThisDrawing.SelectionSets("SS2").Delete
Set sset = ThisDrawing.SelectionSets.Add("SS2")

' Prompt the user to select objects
sset.SelectOnScreen

' Define the variable
Dim compteur As Single
compteur = 0

' Loop through all entities in the selection
' set and assign the xdata to each entity
Dim obj As AcadEntity
Dim Line As AcadLine
Dim arc As AcadArc
Dim poly As AcadLWPolyline
Dim hach As AcadHatch

For Each obj In sset
'MsgBox ("type de l'objet : " & obj.EntityType)
If obj.EntityType = 24 Then
'MsgBox ("polyligne trouvée !!")
Set poly = obj
If poly.Closed = True Then
compteur = compteur + poly.Area
End If
End If
If obj.EntityType = 17 Then
'MsgBox ("hachure trouvée !!")
Set hach = obj
compteur = compteur + hach.Area
End If
Next obj
If compteur <> 0 Then
MsgBox ("aire totale :" & Format(compteur, "0.00") & "m²")
End If
ThisDrawing.SelectionSets("SS2").Delete

End Sub 

 

Voili, voilou...

[lili2006]

Bonsoir à toutes et tous,

 

Ca marche super !

 

sachant que je cote en cm dans l'EO, comment puis-je avoir la surface en m² ? En fait, il faut que je divise par 10 000 (ou bien multiplié par 0.0001).

 

Merci d'avance.