Aller au contenu

Joindre 2 LWpolylignes !


Pako

Messages recommandés

Public Sub PLJoin()

 

....Dim objSelSet As AcadSelectionSet

....Dim objPLW As AcadLWPolyline

....Dim objSpace As AcadBlock

....Dim varData(0) As Variant

....Dim IntType(0) As Integer

....Dim dblPnts() As Double

....Dim varVal As Variant

....Dim varPnts As Variant

....Dim intCnt As Integer

 

........Set objSelSet = ThisDrawing.PickfirstSelectionSet

........IntType(0) = 0

........varData(0) = "LWPOLYLINE"

 

........'Pour cette méthode

............'VOUS DEVEZ SÉLECTIONNER LE POLYLINES DANS L'ORDRE

............'QUE VOUS VOULEZ LES JOINDRE.

 

........objSelSet.SelectOnScreen IntType, varData

........If ThisDrawing.ActiveSpace = acModelSpace Then

............Set objSpace = ThisDrawing.ModelSpace

........Else

............Set objSpace = ThisDrawing.PaperSpace

........End If

 

........For Each objPLW In objSelSet

............varPnts = objPLW.Coordinates

............For Each varVal In varPnts

................ReDim Preserve dblPnts(intCnt)

................ dblPnts(intCnt) = varVal

................intCnt = intCnt + 1

............Next varVal

........Next objPLW

........objSpace.AddLightWeightPolyline dblPnts

........objSelSet.Erase

 

End Sub

l'ACADien ! http://img124.exs.cx/img124/7999/start.gif

Lien vers le commentaire
Partager sur d’autres sites

Je te salue Ô Pako,

 

Merci de mettre à notre disposition de manière spontanée

tes travaux sur le VBA.

 

Je me suis permis de vérifier le code que tu proposes,

un défaut apparaît,

lorsque le sommet de fin d'une Poly

et le sommet de début de la prochaine sont identiques,

ton programme duplique ce sommet.

 

Aussi je suis parti de ton code pour écrire celui que je livre ci-après,

et dans lequel, je teste les sommets pour les intégrer ou les ignorer,

maintenant, la prochaine évolution est le test du sens des polylignes.

 

amicalement

 

Public Sub PLJoin2()

Dim SelPoly As AcadSelectionSet

Dim PolyObj As AcadLWPolyline

Dim objSpace As AcadBlock

Dim varData(0) As Variant

Dim IntType(0) As Integer

Dim TableauPolyObjNouv() As Double

Dim Tempo As Variant

Dim TempoVal As Variant

Dim Compteur As Integer

Dim NumObj As Integer

Set SelPoly = ThisDrawing.PickfirstSelectionSet

IntType(0) = 0

varData(0) = "LWPOLYLINE"

ReDim Preserve TableauPolyObjNouv(999)

SelPoly.SelectOnScreen IntType, varData

 

NumObj = Int(SelPoly.Count)

 

TempoVal = SelPoly.Item(0).Coordinates

 

TableauPolyObjNouv = SelPoly.Item(0).Coordinates

Compteur = UBound(TableauPolyObjNouv)

testxfin = TableauPolyObjNouv(Compteur - 1)

testyfin = TableauPolyObjNouv(Compteur)

ReDim Preserve TableauPolyObjNouv(999)

 

Compteur = Compteur + 1

For i = 1 To NumObj - 1

TempoVal = SelPoly.Item(i).Coordinates

 

If TempoVal(0) = testxfin And TempoVal(1) = testyfin Then

For ii = 2 To UBound(TempoVal)

TableauPolyObjNouv(Compteur) = TempoVal(ii)

Compteur = Compteur + 1

Next ii

Else

For ii = 0 To UBound(TempoVal)

TableauPolyObjNouv(Compteur) = TempoVal(ii)

Compteur = Compteur + 1

Next ii

End If

ReDim Preserve TableauPolyObjNouv(Compteur - 1)

Compteur = UBound(TableauPolyObjNouv)

testxfin = TableauPolyObjNouv(Compteur - 1)

testyfin = TableauPolyObjNouv(Compteur)

ReDim Preserve TableauPolyObjNouv(999)

Compteur = Compteur + 1

Next i

 

ReDim Preserve TableauPolyObjNouv(Compteur - 1)

Set PolyObjNouv = ThisDrawing.ModelSpace.AddLightWeightPolyline(TableauPolyObjNouv)

PolyObjNouv.color = "1"

 

SelPoly.Erase

 

End Sub

 

Lien vers le commentaire
Partager sur d’autres sites

Créer un compte ou se connecter pour commenter

Vous devez être membre afin de pouvoir déposer un commentaire

Créer un compte

Créez un compte sur notre communauté. C’est facile !

Créer un nouveau compte

Se connecter

Vous avez déjà un compte ? Connectez-vous ici.

Connectez-vous maintenant
×
×
  • Créer...

Information importante

Nous avons placé des cookies sur votre appareil pour aider à améliorer ce site. Vous pouvez choisir d’ajuster vos paramètres de cookie, sinon nous supposerons que vous êtes d’accord pour continuer. Politique de confidentialité