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
全部评论