[例程]线型：添加线型、加载线型、编辑线宽

mccad

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

alphasxb

          谢谢     正在作相关的东西   看得都是vba帮助

                   参考一下

wxpsky113

看不太懂! 请问要运行这段语句还要如何设置和建立些什么?谢谢!