|
|
请群里的大神优化优化，祝您身体健康，事业腾达，叩谢大神。
最近在搞一个判断点在多边形内外的程序，由于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(, ".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 = 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
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
测试图片
fzwnzfw05px.png
|
|
置顶卡
