Objekteigenschaften (Autodesk/Rund um AutoCAD)

Hi,

ich mach sowas mit nem VBA script
Quickseelct _filter und die CADSTANDARTS sind auch nette helferlein

Anbei ein Grundgeruest
Man kann so ziemlich alles einfach mit der Methode aufrauemen.
Es ist klar das dieses script angepasst werden muss.
Zeiggt aber die prinzipielle vorgehensweise

Sub start_SETENTITYTOLAYERDEFAULTS()
Dim myselectionset, selectionsetobject As AcadSelectionSet
Dim myselectionSets As AcadSelectionSets
If ThisDrawing.PickfirstSelectionSet.count = 0 Then
MsgBox "SELECT ITEMS FIRST"
Exit Sub
End If
If ThisDrawing.PickfirstSelectionSet.count > 0 Then Set selectionsetobject = ThisDrawing.PickfirstSelectionSet
Call SETENTITYTOLAYERDEFAULTS(selectionsetobject)
'Call Selection_set_delete_all
'ThisDrawing.Application.Update
End Sub

Sub SETENTITYTOLAYERDEFAULTS(ByVal selectionsetobject As AcadSelectionSet)

Dim entity As AcadEntity
Dim blockref As AcadBlockReference
Dim attlist As Variant

Dim hatchobj As AcadHatch
Dim patternName As String
Dim PatternType As Long
Dim bAssociativity As Boolean
Dim objlayer As AcadLayer
Dim P1, p2, P3, ang As Variant
Dim x, y, z, r, D, pi1, td As Double
Dim eLayer As AcadLayer
Dim WIDTH As Double
Dim I As Integer
Dim Koord As Variant
Dim v As String
Dim b As String
Dim crlf As String
Dim text As String

FORM$ = "#.###"
Dim nrow As Integer
Dim NCol As Integer
Dim Facenr As Double
Dim test As String
Dim layers As String
Dim layertext As String
Dim ltype, linetypetext, LS() As String

' Call Layers_on

For Each entity In selectionsetobject
entity.Visible = True
'If InStr(layers, entity.layer) = 0 Then
' Debug.Print entity.Lineweight
layertext = entity.layer
linetypetext = UCase(ThisDrawing.layers(layertext).linetype)

If InStr(ltype, linetypetext) = 0 Then
ltype = ltype & " " & linetypetext
Debug.Print linetypetext
End If
If InStr(linetypetext, "AUSGEZOGEN") > 0 Then linetypetext = "CONTINUOUS"
If InStr(linetypetext, "CONTI") > 0 Then linetypetext = "CONTINUOUS"
If InStr(linetypetext, "BY") > 0 Then linetypetext = "CONTINUOUS"
If InStr(linetypetext, "STRICHLI") > 0 Then linetypetext = "HIDDEN"
If InStr(linetypetext, "DASHED") > 0 Then linetypetext = "HIDDEN"
If InStr(linetypetext, "HIDDEN") > 0 Then linetypetext = "HIDDEN"
If InStr(linetypetext, "STRICHP") > 0 Then linetypetext = "DASH-DOT1"
If InStr(linetypetext, "DASH-DOT") > 0 Then linetypetext = "DASH-DOT1"
If InStr(linetypetext, "MITTE") > 0 Then linetypetext = "DASH-DOT1"
If InStr(linetypetext, "PHANTOM") > 0 Then linetypetext = "PHANTOM"
If InStr(linetypetext, "$0$") > 0 Then
LS = Split(linetypetext, "$0$")
linetypetext = LS(UBound(LS))
Debug.Print LS(UBound(LS))
End If

If InStr(UCase(layertext), "axis") > 0 Then linetypetext = "DASH-DOT1"
If InStr(UCase(layertext), "HIDDEN") > 0 Then linetypetext = "DASH-DOT1"

'If InStr(ltype, linetypetext) = 0 Then linetypetext = "CONTINUOUS"
On Error Resume Next
ThisDrawing.layers(layertext).linetype = linetypetext
On Error GoTo 0

If entity.color = acByLayer Then
entity.color = ThisDrawing.layers(layertext).color
End If
If entity.lineweight = acLnWtByLayer Then
entity.lineweight = ThisDrawing.layers(layertext).lineweight
End If
If entity.linetype = "BYLAYER" Then
entity.linetype = ThisDrawing.layers(layertext).linetype
End If
entity.linetype = ThisDrawing.layers(layertext).linetype
'look for object types
Select Case LCASE(entity.ObjectName)

Case "acdbblockreference"
Case "acdbpolyline"
Case "acdbarc"
Case "acdbline"
Case "acdbellipse"
Case "acdbspline"
Case "acdbradialdimension"
Case "acdbhatch"
Set hatchobj = entity

hatchobj.SetPattern acHatchPatternTypePreDefined, "SOLID"
' hatchobj.AssociativeHatch = True

Case "acdbmtext"
Case "acdbcircle"
Case "acdbrotateddimension"
Case "acdbtext"
Case "acdbaligneddimension"
Case "acdbordinatedimension"
Case "acdbleader"
Case "acdbsolid"
Case "acdbregion"
Case "acdbattributedefinition"
Case "acdbface"
Case "acdb2dpolyline"
Case "acdbminsertblock"
Case "acdbzombieentity"
Case "acdb3dpolyline"
Case "acdbPOINT"
Case Else
If InStr(test, entity.ObjectName) = 0 Then
Debug.Print "Case " & Chr(34) & LCASE(entity.ObjectName) & Chr(34)
test = test & " " & entity.ObjectName

End If
End Select
Next entity

If 1 = 2 Then

For Each blockdef In ThisDrawing.BLOCKS
If Not blockdef.IsLayout Then

Koord0 = blockdef.ORIGIN

For Each entity In blockdef

entity.Visible = True
'If InStr(layers, entity.layer) = 0 Then
' Debug.Print entity.Lineweight
layertext = entity.layer
linetypetext = UCase(ThisDrawing.layers(layertext).linetype)

If InStr(UCase(layertext), "axis") > 0 Then linetypetext = "DASH-DOT1"
If InStr(UCase(layertext), "HIDDEN") > 0 Then linetypetext = "DASH-DOT1"

If InStr(ltype, linetypetext) = 0 Then linetypetext = "CONTINUOUS"
On Error Resume Next
ThisDrawing.layers(layertext).linetype = linetypetext
On Error GoTo 0

Case "acdbblockreference"
Case "acdbpolyline"
Case "acdbarc"
Case "acdbline"
Case "acdbellipse"
Case "acdbspline"
Case "acdbradialdimension"
Case "acdbhatch"
Set hatchobj = entity

'hatchObj.SetPattern acHatchPatternTypePreDefined, "SOLID"
' hatchObj.AssociativeHatch = True

End If
End Select

entity.layer = "0"

Next entity

End If
Next blockdef

End If

' Dim layername As String
' Dim objCurrentLayer As AcadLayer

'layername = "FCR"
'If Not ThisDrawing.ActiveLayer.name = layernam Then
' On Error Resume Next
' Set objCurrentLayer = ThisDrawing.layers.Add(layername)
' objCurrentLayer.color = 240
' objCurrentLayer.LayerOn = True
' objCurrentLayer.Freeze = False
' objCurrentLayer.Lock = False
' objCurrentLayer.Linetype = "CONTINUOUS"
' objCurrentLayer.Lineweight = acLnWt035
' ThisDrawing.ActiveLayer = objCurrentLayer
'End If

End Sub

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

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