---

Manche Befehle in Autocad ürde man ja schon gerne in ein VBA einbauen. Auch wenn Sendcommand (zu Recht)verpönt ist.
Aber bevor man wegen einer Kleinigkeit, Vektorrechnung beidhändig schwingt...

Ich wollte Biegformen für Betonbau aus Polygonne erzeugen und mit Biegeradien versehen. Kann man Polygone auslesen, Bulgen berechnen ...
Und wenn man die nachher beschriften will - darf ma die Biegerollenradein erst mal entfernenn...

Der Tip ist auch interessant wenn man ne Menge Polygone runden will
Und nicht jedes einzeln anklicken mag.
Der Trick ist per VBA das entity handle des Objektes der Begierde auszulesen und dem Befehl "unterzujubeln".

Sub POLY_FILLET_Selection_set(selectionset As AcadSelectionSet, rad As Double)
    Dim entity As AcadEntity
    Dim entity2 As AcadEntity
    Dim SS  As AcadSelectionSet
    Dim E() As Object
    Call layer_clone("HLP", "0")
    ReDim E(0)
    Dim SSn As String
    SSn = "SS" & REPLACE(time(), " ", "")
    SSn = "SS" & REPLACE(SSn, ":", "")
    SSn = "SS" & REPLACE(SSn, "_", "")
    SSn = "SS" & REPLACE(SSn, " ", "")
   
    Set SS = Selection_set_create(SSn)
    For Each entity In selectionset
        If InStr(LCASE(entity.objectname), "poly") > 0 Then
            If InStr(LCASE(entity.objectname), "3d") = 0 Then
                Set entity2 = POLY_FILLET(entity, rad, True)
                entity2.COLOR = acYellow
                entity.LAYER = "HLP"
                Set E(0) = entity2
               

On Error Resume Next
SS.Add E(0)
            End If
        End If
    Next
  ' Call selection_set_activate_by_xdata(SS)
    Selection_set_delete_all
End Sub
Function POLY_FILLET(entity As AcadEntity, rad As Double, Optional copy As Boolean) As AcadEntity
    ThisDrawing.SetVariable "FILLETRAD", rad
    If copy Then
        Set POLY_FILLET = entity.copy
    Else
        Set POLY_FILLET = entity
    End If
    Dim s As String
'ACHTUNG HIER KOMMTS mit handent !!! (Lisp reingemogelt)
    s = "_fillet" & vbLf & "P" & vbLf & "(handent " & Chr(34) & POLY_FILLET.handle & Chr(34) & ")" & vbLf
    ThisDrawing.SendCommand s
    On Error GoTo 0
End Function

Happy coding

Thomas

------------------
Wer es nicht versucht, hat schon verlorn 
Und bei 3 Typos gibts den vierten gratis !
<<< for sale !

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP