判断点在多边形的内外，适合复杂图形

yswoyh

请群里的大神优化优化，祝您身体健康，事业腾达，叩谢大神。
最近在搞一个判断点在多边形内外的程序，由于VB与CAD内存地址的问题，始终没能找到一个比较块的方法

在学习的过程中，用到了api
'创建一个由一系列点围成的区域。windows在需要时自动将最后点与第一点相连以封闭多边形
Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long

'确定点是否在指定区域内
Private Declare Function PtInRegion Lib "gdi32" (ByVal hRgn As Long, ByVal X As Long, ByVal Y As Long) As Long

由于 CreatePolygonRgn PtInRegion 的精度问题始终困惑，精度问题特别体现在靠近多段线的边上，会出现内外判断错误。
下面是利用aip的程序

'创建一个由一系列点围成的区域。windows在需要时自动将最后点与第一点相连以封闭多边形
Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
'确定点是否在指定区域内
Private Declare Function PtInRegion Lib "gdi32" (ByVal hRgn As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Type POINTAPI
    X As Long
    Y As Long
End Type
Const ALTERNATE = 1
Const WINDING = 2
Dim Graph As Long
Dim Ecolor As Long

Private Sub Form_Load()
    Dim Acadapp As Object
    Dim acaddoc As Object
    Dim entry As Object
    Dim vexn As Integer
    Dim pt As Variant
    Dim pt1 As Variant
    Dim E() As POINTAPI
    Set Acadapp = GetObject(, "AutoCAD.application")
    Set acaddoc = Acadapp.ActiveDocument
    Acadapp.ActiveDocument.Utility.GetEntity entry, "选择一个多边形:"
   
    If TypeName(entry) = "IAcadLWPolyline" Then     '获得顶点数
         vexn = (UBound(entry.Coordinates) + 1) / 2
    End If
    If TypeName(entry) = "IAcadPolyline" Then
         vexn = (UBound(entry.Coordinates) + 1) / 3
    End If
    ReDim E(vexn - 1)
    For i = 0 To vexn - 1
        pt = entry.Coordinate(i)
        E(i).X = pt(1)                 '纵坐标
        E(i).Y = pt(0)                 '横坐标
        Debug.Print 横坐标 & E(i).X
        Debug.Print 纵坐标 & E(i).Y
    Next i
    Dim aa As Object
    For i = 0 To 50
        pt1 = acaddoc.Utility.GetPoint(, vbCrLf & "请指插入点")
        Graph = CreatePolygonRgn(E(0), vexn, ALTERNATE)
        Set aa = acaddoc.ModelSpace.AddCircle(pt1, 2)     'AddCircle
        If PtInRegion(Graph, pt1(1), pt1(0)) > 0 Then
            acaddoc.Utility.Prompt (vbCrLf & "多边形内")
            aa.Color = 1
        Else
            acaddoc.Utility.Prompt (vbCrLf & "多边形外")
            aa.Color = 2
        End If
    Next i
End Sub

下面是射线法，解决了aip的判断精度问题，关于 continue 的用法，在VB中只想到 goto 语句


Function fun(ByVal n As Long, ByVal px As Double, ByVal py As Double, x() As Double, y() As Double) As Long
'***********************************************************
'判断点在多边形的内外  返回 0 或 1  ，0 多边形外，1 多边形内
'
'参数说明： n 多边形个数，px 判断点的x坐标，py 判断点的y坐标
'
'         X() 多边形 x坐标数组集合，Y() 多边形 y坐标数组集合
'
'哎哎绿灯亮 2022-4-20
'***********************************************************
Dim count, i As Integer
Dim p1x, p1y As Double
Dim p2x, p2y As Double
Dim xx As Double
count = 0
For i = 0 To n
    p1x = x(i): p1y = y(i)
    If i < n Then
        p2x = x(i + 1): p2y = y(i + 1)
    Else
        p2x = x(0): p2y = y(0)
    End If
    If (p1y = p2y) Then GoTo nexti            'continue p1y,p2y与平行；
    If (py < min(p1y, p2y)) Then GoTo nexti   'continue; //交点在p1,p2的延长线上
    If (py >= max(p1y, p2y)) Then GoTo nexti  'continue; //交点在p1,p2的延长线上
    xx = (py - p1y) * (p2x - p1x) / (p2y - p1y) + p1x
    If (xx > px) Then count = count + 1
nexti:
Next
fun = count Mod 2
End Function

Function min(ByVal x As Double, ByVal y As Double) As Double
'*************************
'判断数值大小，返回最小值
'*************************
    If x < y Then
        min = x
    Else
        min = y
    End If
End Function

Function max(ByVal x As Double, ByVal y As Double) As Double
'*************************
'判断数值大小，返回最大值
'*************************
    If x > y Then
        max = x
    Else
        max = y
    End If
End Function

Sub abc()
    Dim Acadapp As Object
    Dim acaddoc As Object
    Dim entry As Object
    Dim i, n As Integer
    Dim pl_x() As Double
    Dim pl_y() As Double
    Dim vexn As Long
    Dim pt As Variant
    Dim pt1 As Variant
    Set Acadapp = GetObject(, "autocad.application")
    Set acaddoc = Acadapp.ActiveDocument
    Acadapp.ActiveDocument.Utility.GetEntity entry, "选择一个多边形:"     '提示用户选择一个图形
    If TypeName(entry) = "IAcadLWPolyline" Then     '获得顶点数
    vexn = (UBound(entry.Coordinates) + 1) / 2
    End If
    If TypeName(entry) = "IAcadPolyline" Then
        vexn = (UBound(entry.Coordinates) + 1) / 3
    End If
    n = vexn - 1
    ReDim pl_x(n)
    ReDim pl_y(n)
    For i = 0 To n
        pt = entry.Coordinate(i)
        pl_x(i) = pt(1)                 '纵坐标
        pl_y(i) = pt(0)                 '横坐标
        'Debug.Print "第 " & I & " 点 "& "横坐标" & pl_x(i) & "纵坐标" & pl_y(i)
    Next i
    Dim AA As Object
    For i = 0 To 50
      
       pt1 = acaddoc.Utility.GetPoint(, vbCrLf & "请指插入点")
       Set AA = acaddoc.ModelSpace.AddCircle(pt1, 1)     'AddCircle
       If fun(n, pt1(1), pt1(0), pl_x, pl_y) = 1 Then
            acaddoc.Utility.Prompt (vbCrLf & "多边形内")
            AA.Color = 1
       Else
            acaddoc.Utility.Prompt (vbCrLf & "多边形外")
            AA.Color = 2
       End If
    Next
End Sub

Private Sub Form_Load()
    Call abc
End Sub

787116960

老哥  怎么判断在线上的  你这个在线上面也默认为线外

chixun99

你用的什么算法，可以用射线法判断，多边形最好用多段线，判断多边形与过指定点向某个方向发出射线的交点数量，偶数为外，奇数为内。无数个点则边与射线重合也可以判断为在内，在边上、顶点上都是特例需要特殊判断一下。特例时可用原指定点偏移一个微小的距离后判断来代替。

yealor

这个很有用啊，路过记录一下

wuyunpeng888

在DBX里用射线法