Joindre 2 LWpolylignes !

[Pako]

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

[didier]

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