当前版块:问答社区 > CASS

VBA+AutoCAD判断点是否在多边形内

Windows10
其他
CASS9
Public Function dzdbxn(n As Long, ptx() As Double, pty() As Double, px As Double, py As Double) As Boolean
  Dim j As Long, d1 As Double, d2 As Double, d3 As Double
  dzdbxn = False
  For i = 1 To n
      j = i + 1: If i = n Then j = 1
      d1 = Abs(ptx(i) * pty(j) + ptx(j) * py + px * pty(i) - ptx(i) * py - ptx(j) * pty(i) - px * pty(j))
      d2 = Pold(ptx(i), pty(i), ptx(j), pty(j))
      d3 = Abs(d2 - Pold(ptx(i), pty(i), px, py) - Pold(ptx(j), pty(j), px, py))
      d1 = d1 / d2
      If d1 < 0.0001 And d3 < 0.0001 Then dzdbxn = True: Exit Function
  Next i
  If dzdbxn = False Then
     Dim dx As Double, xmax As Double, dy As Double, ymin As Double
     For i = 1 To n
         dx = Abs(ptx(i) - px): dy = Abs(pty(i) - py)
         If i = 1 Then
            xmax = dx: ymin = dy
         Else
            If dx > xmax Then xmax = dx
            If dy < ymin Then ymin = dy
         End If
     Next i
     Dim sum As Long
     sum = 0: xmax = 2# * xmax
     For i = 1 To n
         j = i + 1: If i = n Then j = 1
         d1 = ymin * (ptx(j) - ptx(i)) - xmax * (pty(j) - pty(i))
         d2 = xmax * (pty(i) - py) - ymin * (ptx(i) - px)
         d3 = (ptx(j) - ptx(i)) * (pty(i) - py) - (pty(j) - pty(i)) * (ptx(i) - px)
         If (d2 * (d1 - d2)) >= 0# And d3 * d1 >= 0# Then sum = sum + 1
     Next i
     If sum > 0 And sum <> 2 * Int(sum / 2) Then
        dzdbxn = True
     Else
        dzdbxn = False
     End If
  End If
End Function

Public Function Pold(x1 As Double, y1 As Double, x2 As Double, y2 As Double) As Double
  Pold = Sqr((x2 - x1) * (x2 - x1) + (y2 - y1) * (y2 - y1))
End Function

Public Function PntInPolygon(pnt As Variant, objLwpl As AcadLWPolyline) As Boolean
  Dim n As Long, x As Double, y As Double, pntX() As Double, pntY() As Double
  Dim i As Integer, j As Integer
  x = pnt(0): y = pnt(1)
  n = (UBound(objLwpl.Coordinates) + 1) / 2
  ReDim pntX(n), pntY(n)
  j = 0
  For i = 1 To n
      pntX(i) = objLwpl.Coordinates(j)
      pntY(i) = objLwpl.Coordinates(j + 1)
      j = j + 2
  Next i
  PntInPolygon = dzdbxn(n, pntX, pntY, x, y)

End Function


Sub test()
  Dim objEnt As AcadObject, objLwpl As AcadLWPolyline, pnt As Variant, pnt2 As Variant
  On Error Resume Next
ReSelect:
  ThisDrawing.Application.ActiveDocument.Utility.GetEntity objEnt, pnt2, vbCr & vbCr & "选择多段线:"
  If objEnt Is Nothing Then
     GoTo ReSelect
  Else
     If objEnt.ObjectName = "AcDbPolyline" Then
        Set objLwpl = objEnt
RePnt:
       pnt = ThisDrawing.Application.ActiveDocument.Utility.GetPoint(, vbCr & vbCr & "指定点:")
       MsgBox PntInPolygon(pnt, objLwpl)
       GoTo RePnt
    End If
  End If
End Sub 

全部评论

等级:LV28
积分:49045
扯淡的青春 2019-12-03 06:20
好东西
回复 0
1
提交
悬赏回复规则
1、悬赏期为24小时,从发布时间起算;
2、悬赏期内提问者如设置评论为“精选评论”,视为悬赏结束,该精选评论人将获得本题全部悬赏积分;
3、悬赏期内如提问者未设置“精选评论”,则前5位评论者平分悬赏积分(如仅有一位评论,该评论者获得50%悬赏积分);
4、悬赏积分会自动发放到生态圈账户中,请留意站内信通知。
知道了

距离打开宝箱还剩7

是否花费200积分补签?
确认
取消