Public Sub SketchToAcad() Call Layer_delete_Fremd_LS Call LayerUpdate_LS End Sub Public Sub Layer_delete_Fremd_LS() a = ThisDrawing.ModelSpace.Count For i = a - 1 To 0 Step -1 If ThisDrawing.ModelSpace.Item(i).Layer = "000_ES_F" Then ThisDrawing.ModelSpace.Item(i).Delete End If If ThisDrawing.ModelSpace.Item(i).Layer = "020_FLT_F" Then ThisDrawing.ModelSpace.Item(i).Delete End If If ThisDrawing.ModelSpace.Item(i).Layer = "020_K_F" Then ThisDrawing.ModelSpace.Item(i).Delete End If If ThisDrawing.ModelSpace.Item(i).Layer = "020_FLT_ISO110_F" Then ThisDrawing.ModelSpace.Item(i).Delete End If If ThisDrawing.ModelSpace.Item(i).Layer = "110_FLT_F" Then ThisDrawing.ModelSpace.Item(i).Delete End If If ThisDrawing.ModelSpace.Item(i).Layer = "110_K_F" Then ThisDrawing.ModelSpace.Item(i).Delete End If If ThisDrawing.ModelSpace.Item(i).Layer = "110_FLT_ISO220_F" Then ThisDrawing.ModelSpace.Item(i).Delete End If If ThisDrawing.ModelSpace.Item(i).Layer = "220_FLT_F" Then ThisDrawing.ModelSpace.Item(i).Delete End If If ThisDrawing.ModelSpace.Item(i).Layer = "220_K_F" Then ThisDrawing.ModelSpace.Item(i).Delete End If If ThisDrawing.ModelSpace.Item(i).Layer = "220_FLT_ISO380_F" Then ThisDrawing.ModelSpace.Item(i).Delete End If If ThisDrawing.ModelSpace.Item(i).Layer = "380_FLT_F" Then ThisDrawing.ModelSpace.Item(i).Delete End If If ThisDrawing.ModelSpace.Item(i).Layer = "380_K_F" Then ThisDrawing.ModelSpace.Item(i).Delete End If If ThisDrawing.ModelSpace.Item(i).Layer = "SY_TX_F" Then ThisDrawing.ModelSpace.Item(i).Delete End If If ThisDrawing.ModelSpace.Item(i).Layer = "RAHMEN" Then ThisDrawing.ModelSpace.Item(i).Delete End If Next i 'zeichnung regenerieren ThisDrawing.Regen acAllViewports 'zoomen ThisDrawing.Application.ZoomExtents End Sub Public Sub LayerUpdate_LS() 'layer 0 aktiv setzen ThisDrawing.ActiveLayer = ThisDrawing.Layers("0") '--------------------------------------------------------- 'Layerliste = AutoCADlayer Dim LayerListe As AcadLayers Dim LayerObj As AcadLayer 'Layerfarbe Dim LF As Long 'Strichstärke Dim LW As Long 'Linientyp Dim LT As String '--------------------------------------------------------- 'layer 0 aktiv setzen ThisDrawing.ActiveLayer = ThisDrawing.Layers("0") Set LayerListe = ThisDrawing.Layers If LayerListe.Count = 0 Then Exit Sub For Each LayerObj In LayerListe Select Case LayerObj.Name Case "0" LF = 7 'Layerfarbe festlegen LW = 0 'strichstärke festlegen LT = "continuous" 'Linientyp festlegen LayerObj.color = LF LayerObj.Lineweight = LW LayerObj.Linetype = LT Case "000_ES" LF = 38 'Layerfarbe festlegen LW = 35 'strichstärke festlegen LT = "continuous" 'Linientyp festlegen LayerObj.Freeze = False 'Layer tauen LayerObj.color = LF LayerObj.Lineweight = LW LayerObj.Linetype = LT Case "000_ES_F" LayerObj.Delete Case "020_FLT" LF = 214 'Layerfarbe einstellen LW = 40 'strichstärke einstellen LT = "continuous" 'Linientyp einstellen LayerObj.Freeze = False 'Layer tauen LayerObj.color = LF LayerObj.Lineweight = LW LayerObj.Linetype = LT Case "020_FLT_F" LayerObj.Delete Case "020_FLT_ISO110" LF = 214 'Layerfarbe einstellen LW = 70 'strichstärke einstellen LT = "continuous" 'Linientyp einstellen LayerObj.Freeze = False 'Layer tauen LayerObj.color = LF LayerObj.Lineweight = LW LayerObj.Linetype = LT Case "020_FLT_ISO110_F" LayerObj.Delete Case "020_K" LF = 214 'Layerfarbe einstellen LW = 40 'strichstärke einstellen LT = "ACAD_ISO07W100" 'Linientyp einstellen LayerObj.Freeze = False 'Layer tauen LayerObj.color = LF LayerObj.Lineweight = LW LayerObj.Linetype = LT Case "020_K_F" LayerObj.Delete Case "110_FLT" LF = 162 'Layerfarbe einstellen LW = 70 'strichstärke einstellen LT = "continuous" 'Linientyp einstellen LayerObj.Freeze = False 'Layer tauen LayerObj.color = LF LayerObj.Lineweight = LW LayerObj.Linetype = LT 'Case "110_FLT_F" 'LayerObj.Delete Case "110_FLT_ISO220" LF = 162 'Layerfarbe einstellen LW = 106 'strichstärke einstellen LT = "continuous" 'Linientyp einstellen LayerObj.Freeze = False 'Layer tauen LayerObj.color = LF LayerObj.Lineweight = LW LayerObj.Linetype = LT Case "110_FLT_ISO220_F" LayerObj.Delete Case "110_K" LF = 162 'Layerfarbe einstellen LW = 70 'strichstärke einstellen LT = "ACAD_ISO07W100" 'Linientyp einstellen LayerObj.Freeze = False 'Layer tauen LayerObj.color = LF LayerObj.Lineweight = LW LayerObj.Linetype = LT Case "110_K_F" LayerObj.Delete Case "220_FLT" LF = 96 'Layerfarbe einstellen LW = 106 'strichstärke einstellen LT = "continuous" 'Linientyp einstellen LayerObj.Freeze = False 'Layer tauen LayerObj.color = LF LayerObj.Lineweight = LW LayerObj.Linetype = LT Case "220_FLT_F" LayerObj.Delete Case "220_FLT_ISO380" LF = 96 'Layerfarbe einstellen LW = 140 'strichstärke einstellen LT = "continuous" 'Linientyp einstellen LayerObj.Freeze = False 'Layer tauen LayerObj.color = LF LayerObj.Lineweight = LW LayerObj.Linetype = LT Case "220_FLT_ISO380_F" LayerObj.Delete Case "220_K" LF = 96 'Layerfarbe einstellen LW = 140 'strichstärke einstellen LT = "ACAD_ISO07W100" 'Linientyp einstellen LayerObj.Freeze = False 'Layer tauen LayerObj.color = LF LayerObj.Lineweight = LW LayerObj.Linetype = LT Case "220_K_F" LayerObj.Delete Case "380_FLT" LF = 12 'Layerfarbe einstellen LW = 140 'strichstärke einstellen LT = "continuous" 'Linientyp einstellen LayerObj.Freeze = False 'Layer tauen LayerObj.color = LF LayerObj.Lineweight = LW LayerObj.Linetype = LT Case "380_FLT_F" LayerObj.Delete Case "380_K" LF = 12 'Layerfarbe einstellen LW = 140 'strichstärke einstellen LT = "ACAD_ISO07W100" 'Linientyp einstellen LayerObj.Freeze = False 'Layer tauen LayerObj.color = LF LayerObj.Lineweight = LW LayerObj.Linetype = LT Case "380_K_F" LayerObj.Delete Case "ANSICHTSFENSTER" LF = 1 'Layerfarbe einstellen LW = 18 'strichstärke einstellen LT = "CONTINUOUS" 'Linientyp einstellen LayerObj.Freeze = False 'Layer tauen LayerObj.color = LF LayerObj.Lineweight = LW LayerObj.Linetype = LT Case "RAHMEN" LF = 4 'Layerfarbe einstellen LW = 50 'strichstärke einstellen LT = "CONTINUOUS" 'Linientyp einstellen LayerObj.Freeze = False 'Layer tauen LayerObj.color = LF LayerObj.Lineweight = LW LayerObj.Linetype = LT Case "HILFSLAYER" LF = 202 'Layerfarbe einstellen LW = 18 'strichstärke einstellen LT = "CONTINUOUS" 'Linientyp einstellen LayerObj.Freeze = False 'Layer tauen LayerObj.color = LF LayerObj.Lineweight = LW LayerObj.Linetype = LT Case Else 'Sonstige Acadfarben LF = 253 'Strichstärke 0.05mm LW = 0 LT = "continuous" End Select NEXTLAYER: Next LayerObj 'bereinigen ThisDrawing.PurgeAll 'zeichnung regenerieren ThisDrawing.Regen acAllViewports End Sub