偏移VBA 乐筑天下 - Powered by Discuz! Archiver

AstroNout 发表于 2022-7-6 22:12:35

偏移VBA

嗨，伙计们

我对autoCAD VBA中的偏移方法有点问题。它对LWpoly很有吸引力，但2DPOLYINE或其他具有X、Y和Z坐标的多段线似乎没有通过该方法，创建变量数组varObjArr。感谢您的帮助！

Dim varObjArr As Variant
Dim aEnt As AcadEntity
Dim aLine2 As AcadPolyline
Dim Coords2 As Variant

[... part that works with acadlwpolylines...]

ElseIf TypeOf aEnt Is AcadPolyline Then
      Set aLine2 = aEnt
      varObjArr = aLine2.Offset(-0.001)
      Set aLine2 = varObjArr(0)
      Coords2 = aLine2.Coordinates
      aLine2.Delete
End If

Tyke 发表于 2022-7-6 22:20:01

除了长波多段线，只有二维多段线和三维多段线。

您的ElseIf语句需要更改以拾取二维多段线。我通常用objEnt获得对象名。ObjectName和对于二维多段线，检查“ACDB2DPOLYINE”的值，而对于LWPOLYINES，检查ACDBPOLYINE，对于三维多段线，检查“ACDB3DPOLYINE”。

如果您也要偏移其他对象，则可以考虑使用select case方法，例如：

Select Case objEnt.ObjectName

Case "AcDbPolyline"
      ... (LWPolyline)

Case "AcDb2dPolyline"
      ... (2D-Polyline)

Case "AcDb3dPolyline"
      ... (3D-Polyline)

Case "AcDbLine"
      ... (Line)
.
.
.
Case Else
      ... (Catches non handled objects)

End Select

AstroNout 发表于 2022-7-6 22:24:40

是的，我想你可以选择怎么捡。带有TypeOf或the。name属性。

我现在似乎确实让他们通过了这个程序，有点奇怪，因为我什么都没改变。。。

谢谢
天文学家

Tyke 发表于 2022-7-6 22:29:27

只要你有它的工作，那么一切都是好的。

AstroNout 发表于 2022-7-6 22:30:26

嗨，伙计们

补偿像一个魅力，但我想做的事之后似乎并没有按计划进行。

我正在寻找闭合多段线，这些闭合多段线在特定的几层中与其他多段线重叠。有时程序标记的行与任何内容都不重叠，但我真的看不出我的编程有任何错误。我整个上午都在试图纠正这个错误，但没有任何结果。

我认为应该在某个地方删除一个变量，因为如果没有任何重叠的多边形，一切都正常。可能是选择集吗？

谢谢你看！

Option Compare Text
Option Explicit

Sub Overlap()

Dim aEnt As AcadEntity
Dim varObjArr As Variant
Dim aEnt2 As AcadEntity
Dim sSet As AcadSelectionSet
Dim sSet2 As AcadSelectionSet
Dim aLine As AcadLWPolyline
Dim aCopy As AcadLWPolyline
Dim aCheck As AcadLWPolyline
Dim aLine2 As AcadPolyline
Dim aCopy2 As AcadPolyline
Dim aCheck2 As AcadPolyline
Dim Coords As Variant
Dim Coords2 As Variant
Dim Coords3 As Variant
Dim FT(0) As Integer
Dim FD(0) As Variant
Dim FT2(1) As Integer
Dim FD2(1) As Variant
Dim oLay As AcadLayer
Dim j As Integer
Dim i As Integer
Dim Overlap_Count As Integer

FT(0) = 0
FD(0) = "*polyline"
FT2(0) = 0
FD2(0) = "*polyline"
FT2(1) = 8
FD2(1) = "N_GRA*"

Set oLay = ThisDrawing.Layers.Add("_CHECK_OVERLAP")
oLay.Lineweight = acLnWt030
oLay.Color = acCyan
Overlap_Count = 0

On Error GoTo Delete
Set sSet = ThisDrawing.SelectionSets.Add("sset")
sSet.Select acSelectionSetAll, , , FT, FD

On Error GoTo ErrorControle

For Each aEnt In sSet
If aEnt.Layer Like "N_GRA1A" Or aEnt.Layer Like "N_GRA1GBA" Then
   GoTo FollowingEntity
ElseIf aEnt.Layer Like "*gano*" Or aEnt.Layer Like "N_GRA*" Or aEnt.Layer Like "ANO_GVCO*" Then
   If TypeOf aEnt Is AcadLWPolyline Then
      Set aCheck = aEnt
      varObjArr = aCheck.Offset(0.001)
      Set aLine = varObjArr(0)
      If aLine.Area > aCheck.Area Then
            Erase varObjArr
            aLine.Delete
            varObjArr = aCheck.Offset(-0.001)
            Set aLine = varObjArr(0)
      End If

      ReDim Coords(0 To UBound(aLine.Coordinates))
      Coords = aLine.Coordinates
      aLine.Delete

      ReDim Coords2(0 To ((UBound(Coords) + 1) / 2 * 3) - 1) As Double
      j = 0

      For i = 0 To UBound(Coords) Step 2
            Coords2(j) = Coords(i)
            Coords2(j + 1) = Coords(i + 1)
            Coords2(j + 2) = 0
            j = j + 3
      Next i

   ElseIf TypeOf aEnt Is AcadPolyline Then
      Set aCheck2 = aEnt
      varObjArr = aCheck2.Offset(0.001)
      Set aLine2 = varObjArr(0)
      If aLine2.Area > aCheck2.Area Then
            Erase varObjArr
            aLine2.Delete
            varObjArr = aCheck2.Offset(-0.001)
            Set aLine2 = varObjArr(0)
      End If

      ReDim Coords2(0 To UBound(aLine2.Coordinates)) As Double
      Coords2 = aLine2.Coordinates
      aLine2.Delete
   End If

   Erase varObjArr

   On Error GoTo Delete2
   Set sSet2 = ThisDrawing.SelectionSets.Add("sset2")
   sSet2.SelectByPolygon acSelectionSetCrossingPolygon, Coords2, FT2, FD2

   On Error GoTo ErrorControle
   For Each aEnt2 In sSet2
      If TypeOf aEnt2 Is AcadLWPolyline Then
            Set aCopy = aEnt2.Copy
            aCopy.Layer = "_CHECK_OVERLAP"
            Overlap_Count = Overlap_Count + 1
            'following code is the make the offsetlines visible for control
            'ThisDrawing.ModelSpace.AddPolyline (Coords2)
      ElseIf TypeOf aEnt2 Is AcadPolyline Then
            Set aCopy2 = aEnt2.Copy
            aCopy2.Layer = "_CHECK_OVERLAP"
            Overlap_Count = Overlap_Count + 1
            'following code is the make the offsetlines visible for control
            'ThisDrawing.ModelSpace.AddPolyline (Coords2)
      End If
   Next aEnt2

   ThisDrawing.SelectionSets.Item("sset2").Delete

End If

FollowingEntity:
Next aEnt

ThisDrawing.SelectionSets.Item("sset").Delete

MsgBox Overlap_Count & " nieuwe GRA's hebben een ontoelaatbare overlap.", vbInformation, "Resultaten check"
If Overlap_Count = 0 Then
oLay.Delete
End If

Exit Sub

Delete:
ThisDrawing.SelectionSets.Item("sset").Delete
Resume
Delete2:
ThisDrawing.SelectionSets.Item("sset2").Delete
Resume

ErrorControle:
If Err Then MsgBox Err.Description
End Sub

RICVBA 发表于 2022-7-6 22:37:17

也许这取决于我们前段时间讨论的“适当缩放”问题。http://www.cadtutor.net/forum/showthread.php?82294-选择集交叉问题，即selectionset命令将仅获取显示窗口中的对象。

在那篇文章中，我还展示了如何收集必须完全位于某个围栏内的元素。这很像你的案子。

此外，我只能将其作为警告（因为我不完全确定）：运行“（entget（car（entsel）））命令，然后选择一条轻量级多段线，它将“LWPOLYLINE”作为entitytype返回。所以也许你最好用大写字母
FD(0) = "*POLYLINE"
根据您的选择标准

最后，我试着通读你的代码，看看是否能帮上忙，但我还是坚持了下面的代码片段

      Set aCheck = aEnt
      varObjArr = aCheck.Offset(0.001)
      Set aLine = varObjArr(0)
      If aLine.Area > aCheck.Area Then
            Erase varObjArr
            aLine.Delete
            varObjArr = aCheck.Offset(-0.001)
            Set aLine = varObjArr(0)
      End If

在我看来，“aLine.Area>aCheck.Area”检查的结果总是为FALSE，因为aLine和aCheck都来自aEnt，只有一个偏移量作为差。

至于现在，我没有得到进一步的。。。

AstroNout 发表于 2022-7-6 22:40:37

嗨，RICVBA

我确实注意到了不同论坛上的缩放问题，所以我在程序中加入了最大化。

因为我使用了选项比较文本，所以写多段线的方式应该不会有问题。它拾取所有多段线。

我确实在offset命令方面遇到了一些问题。此命令确保从选择集中排除与所测量的多段线具有相同边界的多段线。0001m的小偏差使得仍然可以按照公认的标准进行检查。在编程和错误处理时，我发现每次偏移都没有正确完成。如果从左到右或从右到左绘制多段线，则偏移的方式不同。这就是我输入代码的原因。

我感觉交叉多边形选项没有按它应该的那样工作。我已经把工作程序（在AC2011地图中）放到了AC2004上，但是当它到达交叉多边形时：混乱。。。多边形围绕0,0点绘制，保留节点数和面积，并删除原始多边形。我现在不仅抓挠我的头。。。GRMBL公司

我正在排除故障。。。

Grtz公司
天文学家

RICVBA 发表于 2022-7-6 22:45:06

嗨AstroNout
如果需要，您可以发布dwg文件。这样我才能更好地理解正在播放的内容，并可能提供一些有用的帮助
再见

AstroNout 发表于 2022-7-6 22:49:39

在左边，这是必须绘制的情况。右边是原始情况。这是2011年绘制的。

2004年的情况将尽快公布在这里。

Grtz公司
天文学家
测试重叠。图纸

RICVBA 发表于 2022-7-6 22:55:01

嗨AstroNout
我只是在一个只包含“右侧”对象的图形中运行您的例程，并获得了您所期望的“左侧”。
你实际上遇到了什么问题？

PS：我之前对“aLine.Area>aCheck.Area”检查的怀疑是因为我不知道“offset”方法，我假设该方法只是移动新创建的对象，而我现在意识到它作用于它们的区域。很抱歉

页: [1] 2

乐筑天下's Archiver

偏移VBA