创建实体、图层和选择集
Option ExplicitPublic 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
严兄，跑来这了啊。
页:
[1]