GamIng 发表于 2018-6-6 10:59:43

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

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

elepeipei 发表于 2018-6-6 10:59:44

本帖最后由 elepeipei 于 2018-6-13 12:05 编辑


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 发表于 2018-6-12 14:34:06

这个解决了吗

GamIng 发表于 2018-6-12 14:38:07

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

没有。
期待高手出手。:loveliness:

elepeipei 发表于 2018-6-12 15:37:51

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 发表于 2018-6-13 08:50:31

本帖最后由 GamIng 于 2018-6-13 08:53 编辑

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

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

elepeipei 发表于 2018-6-13 10:38:45

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

GamIng 发表于 2018-6-13 11:03:10

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

我只会用lisp。:(

GamIng 发表于 2018-6-13 12:34:53

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


多谢！ :victory:

elepeipei 发表于 2018-6-13 12:43:37

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

页: [1] 2
查看完整版本: 根据现有打开图层画出相应图层的直线