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(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
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