社区 › 源码共享 › 通过颜色、线型等改物体图层

subtlation 发表于 2003-11-26 17:53:00

通过颜色、线型等改物体图层

没有对话框，里面的设置是根据自己的绘图习惯定的。


源码如下：里面一些函数都是明经里面下载的。
Sub changelayer()
On Error Resume Next
   '新建选择集
    Dim ssetObj As AcadSelectionSet
    Set ssetObj = CreateSelectionSet()
    ssetObj.SelectOnScreen
    If ssetObj.Count = 0 Then Exit Sub

   '新建图层
    Dim newlayer As AcadLayer
    Set newlayer = CreateLayer("A1", acRed)
      newlayer.Lineweight = acLnWt050
    Set newlayer = CreateLayer("A2", acYellow)
      newlayer.Lineweight = acLnWt025
    Set newlayer = CreateLayer("A3", acGreen)
      newlayer.Lineweight = acLnWt025
    Set newlayer = CreateLayer("A4", acCyan)
      newlayer.Lineweight = acLnWt035
    Set newlayer = CreateLayer("A5", acBlue)
      newlayer.Lineweight = acLnWt070
    Set newlayer = CreateLayer("A6", acMagenta)
      newlayer.Lineweight = acLnWt013
    Set newlayer = CreateLayer("C6", acMagenta, "CENTER")
      newlayer.Lineweight = acLnWt013
    Set newlayer = CreateLayer("HATCH")
      newlayer.Lineweight = acLnWt018
    Set newlayer = CreateLayer("NOTE")
      newlayer.Lineweight = acLnWt018
    Set newlayer = CreateLayer("DIM")
      newlayer.Lineweight = acLnWt018
    Set newlayer = CreateLayer("钢筋编号")
      newlayer.Lineweight = acLnWt018
    Set newlayer = CreateLayer("标高")
      newlayer.Lineweight = acLnWt018
   
   
    Dim ent As AcadEntity
    For Each ent In ssetObj
      '根据颜色改变改图层
      colorTolayer ent, acRed, "A1"
      colorTolayer ent, acYellow, "A2"
      colorTolayer ent, acGreen, "A3"
      colorTolayer ent, acCyan, "A4"
      colorTolayer ent, acBlue, "A5"
      '所有标注变成DIM层
      '所有文字变成NOTE层
      '所有填充变成HATCH层
      '所有钢筋编号改为钢筋编号层
      If TypeOf ent Is AcadDimension Then
      ent.Layer = "DIM"
      ElseIf TypeOf ent Is AcadHatch Then
      ent.Layer = "HATCH"
      ElseIf TypeOf ent Is AcadMText Or TypeOf ent Is AcadText Then
      ent.Layer = "NOTE"
      ElseIf TypeOf ent Is AcadBlockReference Then
      If ent.Name Like "钢筋编号*" Then
          ent.Layer = "钢筋编号"
      ElseIf ent.Name Like "BG??" Or ent.Name Like "*标高" Then
          ent.Layer = "标高"
      End If
      End If
    Next
   
    ssetObj.Clear
    ssetObj.Delete
    ThisDrawing.PurgeAll
End Sub
Sub colorTolayer(ent As AcadEntity, Color As Integer, layerName As String)
If ent.Color = Color Then
    ent.Layer = layerName
    ent.Color = acByLayer
End If
End Sub
Public Function CreateLayer(ssLayerName As String, Optional LayerColor As Integer, _
                            Optional LayerLineType As String) As AcadLayer
On Error Resume Next
    Set CreateLayer = ThisDrawing.Layers(ssLayerName)
    If Err Then
      Err.Clear
      Set CreateLayer = ThisDrawing.Layers.Add(ssLayerName)
      If LayerColor <> 0 Then CreateLayer.Color = LayerColor
      If LayerLineType <> "" Then CreateLayer.Linetype = LayerLineType
    End If
End Function

Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet
'返回一个空白选择集

    Dim ss As AcadSelectionSet
   
    On Error Resume Next
    Set ss = ThisDrawing.SelectionSets(ssName)
    If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
    ss.Clear
    Set CreateSelectionSet = ss
End Function

chengzhang 发表于 2008-6-25 16:15:00

好好学习，天天向上！

清风明月名字 发表于 2013-6-27 20:26:24

谢谢楼主代码分享！

查看完整版本: 通过颜色、线型等改物体图层