创建实体、图层和选择集

yjr111

Option Explicit
Public ms As AcadModelSpace, utiobj As Object
'提示输入点创建一个点
Private Sub Addpoint()
    Dim p1 As Variant, PointObj As AcadPoint
    Set ms = ThisDrawing.ModelSpace
    Set utiobj = ThisDrawing.Utility
    p1 = utiobj.GetPoint(, "指定点")
    Set PointObj = ms.Addpoint(p1)
End Sub
'提示输入点创建一条直线
Private Sub AddLine()
    Dim p1 As Variant, p2 As Variant, LineObj As AcadLine
    Set ms = ThisDrawing.ModelSpace
    Set utiobj = ThisDrawing.Utility
    p1 = utiobj.GetPoint(, "第一点")
    p2 = utiobj.GetPoint(p1, "第二点")
    Set LineObj = ms.AddLine(p1, p2)
End Sub
'提示输入点创建一个圆
Private Sub AddCircle()
    Dim p1 As Variant, p2 As Variant, dist As Double, CircleObj As AcadCircle
    Set ms = ThisDrawing.ModelSpace
    Set utiobj = ThisDrawing.Utility
    p1 = utiobj.GetPoint(, "第一点")
    dist = utiobj.GetDistance(p1, "输入半径")
    Set CircleObj = ms.AddCircle(p1, dist)
End Sub
'提示输入点创建一条仅2个顶点轻多段线
Private Sub AddLWPline()
    Dim p1 As Variant, p2 As Variant, points(3) As Double, objPline As AcadLWPolyline
    Set utiobj = ThisDrawing.Utility
    Set ms = ThisDrawing.ModelSpace

    On Error Resume Next
    p1 = utiobj.GetPoint(, "输入第一点:")
    If Err.Number = -2145320928 Then
        Err.Clear
        Exit Sub
    End If
    On Error Resume Next
    p2 = utiobj.GetPoint(p1, "输入下一点:")
    If Err.Number = -2145320928 Then
        Err.Clear
        Exit Sub
    End If
    points(0) = p1(0)
    points(1) = p1(1)
    points(2) = p2(0)
    points(3) = p2(1)
    Set objPline = ms.AddLightWeightPolyline(points)
End Sub
'提示输入点创建一条连续顶点轻多段线，by mjtd
Private Sub AddLWPline1()
    Dim index As Integer, p1 As Variant, ptPrevious As Variant, ptCurrent As Variant
    Dim points(0 To 3) As Double, ptVert(0 To 1) As Double
    Dim objPline As AcadLWPolyline
    Set utiobj = ThisDrawing.Utility
    Set ms = ThisDrawing.ModelSpace

    index = 2
    On Error Resume Next
    p1 = utiobj.GetPoint(, "输入第一点:")
    If Err.Number = -2145320928 Then
        Err.Clear
        Exit Sub
    End If
    ptPrevious = p1

nextpt:
    On Error Resume Next
    ptCurrent = utiobj.GetPoint(ptPrevious, "输入下一点:")
    If Err.Number = -2145320928 Then
        Err.Clear
        Exit Sub
    End If

    If index = 2 Then
        points(0) = ptPrevious(0)
        points(1) = ptPrevious(1)
        points(2) = ptCurrent(0)
        points(3) = ptCurrent(1)
        Set objPline = ms.AddLightWeightPolyline(points)
    ElseIf index > 2 Then
        ptVert(0) = ptCurrent(0)
        ptVert(1) = ptCurrent(1)
        objPline.AddVertex index - 1, ptVert
    End If
    index = index + 1
    ptPrevious = ptCurrent
    GoTo nextpt
End Sub
'提示点及各参数创建一个圆弧
Private Sub AddArc()
   Dim Center As Variant, Radius As Double, StartAngle As Double, endangle As Double, objArc As AcadArc
   Set utiobj = ThisDrawing.Utility
   Set ms = ThisDrawing.ModelSpace

   Center = utiobj.GetPoint(, "输入圆心:")
   Radius = utiobj.GetDistance(Center, "输入半径")
   StartAngle = utiobj.GetAngle(Center, "输入起始角")
   endangle = utiobj.GetAngle(Center, "输入终止角")
   Set objArc = ms.AddArc(Center, Radius, StartAngle, endangle)
End Sub
'提示点及各参数创建一个椭圆弧
Private Sub AddEllipse()
   Dim Center As Variant, p1 As Variant, Radius As Double, MajorAxis(2) As Double, RadiusRatio As Double, objEllipse As AcadEllipse
   Dim objLine As AcadLine, StartAngle As Double, endangle As Double
   Set utiobj = ThisDrawing.Utility
   Set ms = ThisDrawing.ModelSpace

   Center = utiobj.GetPoint(, "输入椭圆心:")
   Radius = utiobj.GetDistance(Center, "输入长轴半径")
   MajorAxis(0) = Radius: MajorAxis(1) = 0#: MajorAxis(2) = 0#
   On Error Resume Next
   RadiusRatio = utiobj.GetReal("输入椭圆长轴与短轴比率")
   If (RadiusRatio = 0) Then RadiusRatio = 0.75
   Set objEllipse = ms.AddEllipse(Center, MajorAxis, RadiusRatio)
   p1 = utiobj.GetPoint(Center, "输入椭圆起始角度")
   Set objLine = ms.AddLine(Center, p1)
   StartAngle = objLine.Angle
   objLine.Delete
   p1 = utiobj.GetPoint(Center, "输入椭圆终止角度")
   Set objLine = ms.AddLine(Center, p1)
   endangle = objLine.Angle
   objLine.Delete
   objEllipse.StartAngle = StartAngle
   objEllipse.endangle = endangle
   objEllipse.Update
End Sub
'创建一个新图层
Private Sub AddNewLayer()
   Dim layername As Variant, objLayer As AcadLayer, mylayer As AcadLayers
   Set utiobj = ThisDrawing.Utility
   Set mylayer = ThisDrawing.Layers

   layername = utiobj.GetString(False, "输入新图层名")
   Set objLayer = mylayer.Add(layername)
   ThisDrawing.SetVariable "clayer", layername
   objLayer.color = 1
End Sub
'创建一个新选择集,并选择对象修改颜色
Sub creatss()
    Dim ss As AcadSelectionSet, i%
    Dim FilterType(0) As Integer
    Dim FilterData(0) As Variant
    On Error Resume Next
    Set ss = ThisDrawing.SelectionSets.Add("ss1")
    If Err Then
        Err.Clear
        Set ss = ThisDrawing.SelectionSets("ss1")
        ss.Clear
    End If
    i = ss.Count
    If Err Then
        ss.Delete
        Err.Clear
        Set ss = ThisDrawing.SelectionSets.Add("ss1")
    End If
    Dim ent As AcadEntity
    FilterType(0) = 62
    FilterData(0) = 1
    ss.SelectOnScreen FilterType, FilterData
    For Each ent In ss
    ent.color = 19
    ent.Update
    Next ent
End Sub

weiqi

严兄，跑来这了啊。

陈亚娣