[编程交流] 偏移VBA

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

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

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

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