根据现有打开图层画出相应图层的直线

GamIng

根据现有打开图层，画出相应图层的直线。
直线间距、长度不限。只要一一列出来就行。

elepeipei

Sub 测试()
    Dim objLayer As AcadLayer
    Dim i As Integer
    Dim objLine As AcadLine
    Dim strPt(0 To 2) As Double
    Dim endPt(0 To 2) As Double
    Dim basePt As Variant
    basePt = ThisDrawing.Utility.GetPoint(, "拾取点")
    For Each objLayer In ThisDrawing.Layers
        If objLayer.LayerOn = True Then
            ThisDrawing.ActiveLayer = objLayer
            i = i + 1
            strPt(0) = basePt(0) + 50 * i: strPt(1) = basePt(1): strPt(2) = 0
            endPt(0) = strPt(0): endPt(1) = strPt(1) + 300: endPt(2) = 0
            Set objLine = ThisDrawing.ModelSpace.AddLine(strPt, endPt)
        End If

    Next
End Sub

elepeipei

这个解决了吗

GamIng

elepeipei 发表于 2018-6-12 14:34
这个解决了吗

没有。
期待高手出手。

elepeipei

Sub 测试()
    Dim objLayer As AcadLayer
    Dim i As Integer
    Dim objLine As AcadLine
   
    For Each objLayer In ThisDrawing.Layers
        ThisDrawing.ActiveLayer = objLayer
        i = i + 1
        Dim strPt(0 To 2) As Double
        Dim endPt(0 To 2) As Double
        strPt(0) = 50 * i: strPt(1) = 0: strPt(2) = 0
        endPt(0) = strPt(0): endPt(1) = 300: endPt(2) = 0
        Set objLine = ThisDrawing.ModelSpace.AddLine(strPt, endPt)
    Next

End Sub

GamIng

elepeipei 发表于 2018-6-12 15:37
Sub 测试()
    Dim objLayer As AcadLayer
    Dim i As Integer

多谢！问题1：已关闭图层依旧有画出直线；
问题2：放置位置可以自定么？

elepeipei

1，你可以加一个判断，关闭就不画
2，把起始点写成获取点

GamIng

elepeipei 发表于 2018-6-13 10:38
1，你可以加一个判断，关闭就不画
2，把起始点写成获取点

我只会用lisp。

GamIng

elepeipei 发表于 2018-6-13 11:44
Sub 测试()
    Dim objLayer As AcadLayer
    Dim i As Integer

多谢！

elepeipei

GamIng 发表于 2018-6-13 12:34
多谢！