|
|
Public Sub UseLinetype()
Dim entry As AcadLineType
Dim found As Boolean
Dim ltName(0 To 2) As String
Dim I As Integer
found = False
'准备添加的3种线型
ltName(0) = "BORDER"
ltName(1) = "CENTER"
ltName(2) = "DASHDOT"
For I = 0 To 2
'搜寻要添加的线型在线型集合中是否已存在
For Each entry In ThisDrawing.Linetypes
If StrComp(entry.Name, ltName(I), 1) = 0 Then
found = True
Exit For
End If
Next
'如果不存在则将其从线型文件acad.lin中加载
If Not (found) Then
ThisDrawing.Linetypes.Load ltName(I), "acad.lin"
End If
Next
'-------------------------------------------------
'将DASHDOT线型设为当前活动线型
Dim ltObj As AcadLineType
Set ltObj = ThisDrawing.Linetypes.Add("DASHDOT")
ThisDrawing.ActiveLinetype = ltObj
ltObj.Description = "当前线型为点划线。"
'创建一条直线，让其使用活动线型
Dim lineObj1 As AcadLine
Dim startPoint(0 To 2) As Double
Dim endPoint(0 To 2) As Double
startPoint(0) = 25#: startPoint(1) = 25#: startPoint(2) = 0#
endPoint(0) = 100#: endPoint(1) = 100#: endPoint(2) = 0#
Set lineObj1 = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
'--------------------------------------------------
'将0层设为CENTER线型，并保证0层为当前层
Dim layObj As AcadLayer
Set layObj = ThisDrawing.Layers("0")
layObj.Linetype = "CENTER"
ThisDrawing.ActiveLayer = layObj
Dim lineObj2 As AcadLine
startPoint(0) = 50#: startPoint(1) = 25#: startPoint(2) = 0#
endPoint(0) = 125#: endPoint(1) = 100#: endPoint(2) = 0#
Set lineObj2 = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
'将第2条直线的线型设为随层
lineObj2.Linetype = "ByLayer"
'--------------------------------------------------
Dim lineObj3 As AcadLine
startPoint(0) = 75#: startPoint(1) = 25#: startPoint(2) = 0#
endPoint(0) = 150#: endPoint(1) = 100#: endPoint(2) = 0#
Set lineObj3 = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
'将第3条直线的线型直接设为BORDER
lineObj3.Linetype = "BORDER"
'--------------------------------------------------
'将3条直线的线型比例放大，以便于观察
MsgBox "第一条线段的默认比例因子：" & lineObj1.LinetypeScale
ThisDrawing.SetVariable "LTSCALE", 6
'lineObj1.LinetypeScale = 1
'lineObj2.LinetypeScale = 1
'lineObj3.LinetypeScale = 10
ZoomAll
'MsgBox "线型描述：" & ltObj.Description
ThisDrawing.Regen True
End Sub
Public Sub UseLnWt()
Dim circleObj As AcadCircle
Dim centerPoint(0 To 2) As Double
Dim radius As Double
'设定圆心坐标
centerPoint(0) = 200#: centerPoint(1) = 180#: centerPoint(2) = 0#
'创建第1个圆
radius = 30#
Set circleObj = ThisDrawing.ModelSpace.AddCircle _
(centerPoint, radius)
'设置线宽为0.3毫米
circleObj.Lineweight = acLnWt030
circleObj.Update
'创建第2个圆
radius = 60#
Set circleObj = ThisDrawing.ModelSpace.AddCircle _
(centerPoint, radius)
'设置线宽为0.65毫米，该值不是内定的
circleObj.Lineweight = acLnWt065
circleObj.Update
'创建第3个圆
radius = 90#
Set circleObj = ThisDrawing.ModelSpace.AddCircle _
(centerPoint, radius)
'设置线宽为0.7毫米
circleObj.Lineweight = acLnWt070
circleObj.Update
ZoomAll
'通过对系统变量的设置，在屏幕上显示线宽
ThisDrawing.SetVariable "LWDISPLAY", 1
' Change the lineweight for the circle
'circleObj.Lineweight = acLnWt211
'circleObj.Update
'MsgBox "The current lineweight for the circle is " & circleObj.Lineweight
'ThisDrawing.SetVariable "LWDISPLAY", 0
'ThisDrawing.Regen True
End Sub
Public Sub lx2()
Dim ltObj As AcadLineType
ThisDrawing.Linetypes.Load "CENTER", "acad.lin"
Set ltObj = ThisDrawing.Linetypes.Add("CENTER")
ThisDrawing.ActiveLinetype = ltObj
ThisDrawing.Regen True
MsgBox "CENTER线型已加载，并设为当前线型！"
End Sub
Public Sub lx3()
Dim ltObj As AcadLineType
'判断CENTER线型是否为当前线型
If StrComp(ThisDrawing.ActiveLinetype.Name, "CENTER", 1) = 0 Then
'将ByLayer线型设为当前线型
Set ltObj = ThisDrawing.Linetypes.Add("ByLayer")
ThisDrawing.ActiveLinetype = ltObj
End If
On Error Resume Next
MsgBox "现在准备删除CENTER线型！"
Set ltObj = ThisDrawing.Linetypes.Add("CENTER")
ltObj.Delete
'如果没有CENTER线型，删除时程序将出错。
If Err 0 Then '捕获错误
MsgBox "CENTER线型已不存在！"
End If
End Sub |
|
置顶卡
