[VBA程序]：判断点在闭合区域内部，代码有问题，高手帮忙

misters

现在主要是两个问题，一是：下面判断程序是否有错
二是：在附件中带的图，取点有什么好方法，用CAD的命令就能在原来的图的基础上用程序向里将整个多线段缩小或是其它的办法
偶现在用的是按一定的值向通过顶点的直线做切线，切线的半径是X，两条切线的交点是圆心，可偶不会写程序啊，谁能给点简单的
建议，这个还很急呀，
'用矩形做示例，还有其它的图形，用以下表示

dim str as string

str="30,-70|50,-70|50,-84|30,-84"

dim jl as long '输入一个值，在str矩形的内部画一个xy坐标都内移jl值的矩形，这个矩形正好套在上个矩形之内。

新得到的矩形的坐标值是"32,-72|48,-72|48,-82|32,-82"

我用的方法是将每个顶点可能发生的四种情况都调用ptinpoly函数判断如果返回0值表示在内部，但是四个值一个都不返回0值，下面的函数是不是有错误啊，高手能不能帮我检查一下，看看有什么问题，或是谁有VB或VBA的代码发表一下，急呀，检查不出问题呀。

它的四种情况是：

x-,y-

x+,y+

x-,y+

x+,y-

这四种情况中应该有一种是在内部的


'判断给定点 pt 是否在多边形 poly 内
'返回 0 在内部，-1 在外面
'返回 > 0 表示点在第几条有向线段上
Private function PtInPoly(ByVal pt As Variant, ByVal poly As Variant) As Integer
    Dim i As Integer
    Dim status, lastStauts As Integer
    Dim cnt As Integer
    Dim POS, temp As Integer
   
    Dim var_poly As Variant
    Dim var_polyi As Variant
   
    var_poly = Split(poly(1), ",")
    cnt = 0
    lastStauts = IIf(var_poly(1) > pt(1), 1, IIf(var_poly(1) = pt(1), 0, -1))
   
    For i = 1 To UBound(poly)
        var_poly = Split(poly(i), ",")
        status = IIf(var_poly(1) > pt(1), 1, IIf(var_poly(1) < pt(1), -1, 0))
        temp = status - lastStauts
        lastStauts = status
        POS = SideOfLine(poly(i - 1), poly(i), pt)
'       点在有向线段上
        var_poly = Split(poly(i), ",")
        var_polyi = Split(poly(i - 1), ",")
        If (POS = 0 And (var_polyi(0) <= pt(0) And pt(0) <= var_poly(0) Or var_polyi(0) >= pt(0) And pt(0) >= var_poly(0)) And (var_polyi(1) <= pt(1) And pt(1) <= var_poly(1) Or var_polyi(1) >= pt(1) And pt(1) >= var_poly(1))) Then
            PtInPoly = i
            Exit Function
        End If
        
'        跨越
        If (temp > 0 And POS = 1 Or temp < 0 And POS = -1) Then
            cnt = cnt + temp
        End If
        
    Next
   
    PtInPoly = IIf(cnt = 0, -1, 0)
   
End Function

'判断点在线的哪侧
Private function SideOfLine(ByVal p1 As Variant, ByVal p2 As Variant, ByVal pt As Variant) As Integer
    Dim RR, TOP, LL As Integer
    RR = -1
    TOP = 0
    LL = 1
   
    Dim c1 As Double
    Dim c2 As Double
    Dim var_p1 As Variant
    Dim var_p2 As Variant
   
    var_p1 = Split(p1, ",")
    var_p2 = Split(p2, ",")
   
    c1 = (var_p2(0) - pt(0)) * (pt(1) - var_p1(1))
    c2 = (var_p2(1) - pt(1)) * (pt(0) - var_p1(0))
    SideOfLine = IIf(c1 > c2, LL, IIf(c1 < c2, RR, TOP))
End Function

misters

过一个顶点的两条直线，做半径=R的最小的内切圆，有什么好的算法或代码吗？

ahua

没有这么复杂，上美国的网站上搜索一下

misters

有好的网站推荐一下不行吗？

lhx2000

'判断点px是否在多边形内 document.write ( code_jk_my("'判断点px是否在多边形内;
'即可适用于凹多边形的判断，也适用于凸多边形的判断
'所选射线px(x0 y0)--pxy(x0+2*max|x0-xi| y0+min|y0-yi|) [i=1,2 3,.......,n]不与多边形任何一顶点相交
'入口参数多边形：(n, ptx(), pty(), px , py)
'返回值False (在多边形外)、True(在多边形上及在多边形内)
Public Function dzdbxn(n As Long, PTX() As Double, PTY() As Double, PX As Double, PY As Double) As Boolean
Dim j As Long
Dim d1 As Double
Dim d2 As Double
Dim 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
'Print "i=" + Str(i) + " j=" + Str(J) + " d1=" + Str(d1) + " d3=" + Str(d3)
'注意：d1 d3判断值1前的0个数=多边形区域坐标值中小数位数-1
If d1 < 0.0001 And d3 < 0.0001 Then dzdbxn = True: Exit Function
Next i

If dzdbxn = False Then
Dim dx As Double
Dim xmax As Double
Dim dy As Double
Dim 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
'Print "sum=" + Str(sum) + " px=" + Str(px) + " py=" + Str(py)
If sum > 0 And sum <> 2 * Int(sum / 2) Then
dzdbxn = True
Else
dzdbxn = False
End If
End If
End Function

misters

d2 = Pold(PTX(i), PTY(i), PTX(j), PTY(j))中
Pold这个函数的代码能贴上来吧？