标签：
‘******************************************************************************
‘是否在多边形内
‘1表示在多边形内，0表示在多边形外
Private Function IsInner(ByVal pts As MapXLib.Points, ByVal P As MapXLib.Point) As Integer
Dim i As Integer
Dim ret As Integer
Dim sum As Integer
Dim direc As Long
Dim num As Long
Dim px() As New MapXLib.Point
ret = 0
sum = 0
direc = 0
num = pts.Count
If pts.Count < 3 Then
IsInner = 2 ‘
Exit Function
End If
ReDim px(0 To num - 1)
For i = 0 To num - 1
px(i).Set pts.Item(i + 1).x, pts.Item(i + 1).y
Next i
For i = 0 To num - 2
ret = IsCross(px(i), px(i + 1), P)
If ret = 2 Then
IsInner = 2
Exit Function
End If
sum = sum + ret
Next i
ret = IsCross(px(num - 1), px(0), P)
If ret = 2 Then
IsInner = 2 ‘无法判断
Exit Function
End If
sum = sum + ret
If direc Then
IsInner = 1 ‘位于多边形区域内
Exit Function
End If
If sum Mod 2 = 0 Then
IsInner = 0 ‘位于多边形区域外
Else
IsInner = 1
End If
End Function
‘***********************************************************************
‘高飞:2000.10.1
‘输入参数：点p1,p2,p0
‘输出：排序之后的点p1,p2(p1,p2相对于p0作逆时针排序)
Private Sub AntiClockWise(P1 As MapXLib.Point, P2 As MapXLib.Point, ByVal P0 As MapXLib.Point)
Dim a1 As Double ‘a1是P1->P0与水平轴之间的夹角(0~2π)
Dim a2 As Double ‘a2是P2->P0与水平轴之间的夹角(0~2π)
Dim a0 As Double
Dim P11 As New MapXLib.Point
Dim P12 As New MapXLib.Point
a1 = GetAngle(P1, P0)
a2 = GetAngle(P2, P0)
a0 = a2 - a1
If a0 > 0 Then
If a0 < PI_IN_MATH Then
P11.Set P1.x, P1.y
P12.Set P2.x, P2.y
Else
P11.Set P2.x, P2.y
P12.Set P1.x, P1.y
End If
Else
If a0 < PI_IN_MATH Then
P11.Set P2.x, P2.y
P12.Set P1.x, P1.y
Else
P11.Set P1.x, P1.y
P12.Set P2.x, P2.y
End If
End If
P1.Set P11.x, P11.y
P2.Set P12.x, P12.y
End Sub
‘******************************************************************************
‘高飞：2000.10.1
‘判断点与直线的关系
‘输入点的坐标 a(x, y), 直线方程a * x + b * y + c = 0
‘如果点在直线上方 return 1;
‘如果点在直线上 return 0;
‘如果点在直线下方 return -1;
‘////////////////////////////////////////////////////////////
Private Function Jponli(ByVal x As Double, ByVal y As Double, _
ByVal a As Double, ByVal b As Double, ByVal c As Double) As Long
Dim j As Long, e As Double
j = 1
If (a * x + b * y + c) < 0# Then
j = -1
End If
e = Sqr(a * a + b * b)
If e >= 0.000001 Then
If Abs(a * x + b * y + c) < (0.001 * e) Then
j = 0
End If
End If
‘-------------------
Jponli = j
End Function
‘******************************************************************************
‘高飞: 2000.10.1
‘沿逆时针方向，P2->P0与P1->P0之间的夹角(0~π)
Private Function Get3DAngle(ByVal P1 As MapXLib.Point, ByVal P0 As MapXLib.Point, ByVal P2 As MapXLib.Point) As Double
Dim a0 As Double
a0 = GetAngle(P1, P0) - GetAngle(P2, P0)
If a0 < 0 Then
a0 = a0 + 2 * PI_IN_MATH
End If
‘--------------
Get3DAngle = a0
End Function
‘******************************************************************************
‘高飞：2000.10.1
‘搜索使a0最小的直线
‘输入参数:f0,点P11,点P12,点P22,角度a0,fkey
‘输出:P22,a0,fkey
Private Function SearchNextLine(ByVal f0 As MapXLib.Feature, ByVal P11 As MapXLib.Point, ByVal P12 As MapXLib.Point, P22 As MapXLib.Point, a0 As Double) As Boolean
Dim i As Long
Dim j As Long
Dim ct As Long
Dim PT_S As MapXLib.Points
Dim P1 As MapXLib.Point
Dim P2 As MapXLib.Point
Dim bSearched As Boolean
If f0.Type <> miFeatureTypeLine Then ‘只检查直线
bSearched = False
Exit Function
End If
bSearched = False
ct = f0.Parts.Count
For i = 1 To ct
Set PT_S = f0.Parts.Item(i)
For j = 1 To PT_S.Count - 1
Set P1 = PT_S.Item(j)
Set P2 = PT_S.Item(j + 1)
If IsEqual(P1.x, P12.x) And IsEqual(P1.y, P12.y) Then ‘P1=P12
If Get3DAngle(P11, P12, P2) < a0 Then
a0 = Get3DAngle(P11, P12, P2)
P22.Set P2.x, P2.y
bSearched = True
End If
End If
If IsEqual(P2.x, P12.x) And IsEqual(P2.y, P12.y) Then ‘P2=P12
If Get3DAngle(P11, P12, P1) < a0 Then
a0 = Get3DAngle(P11, P12, P1)
P22.Set P1.x, P1.y
bSearched = True
End If
End If
Next j
Next i
‘return
SearchNextLine = bSearched
End Function
‘******************************************************************************
‘求两线段的交点
‘输入四点的坐标 l1: A(x1, y1) B(x2, y2)
‘ l2: C(x3, y3) D(x4, y4)
‘输出交点A(*xx, *yy);
‘如果两线段没有交点, return FALSE, and *xx = *yy = 9e5;
‘否则 return TRUE;
Private Function PlsLs(ByVal x1 As Double, ByVal y1 As Double, _
ByVal x2 As Double, ByVal y2 As Double, _
ByVal x3 As Double, ByVal y3 As Double, _
ByVal x4 As Double, ByVal y4 As Double, _
xx As Double, yy As Double) As Boolean
Dim a1 As Double, b1 As Double, c1 As Double ‘第一条直线方程的系数a1*x + b1*y + c1=0
Dim a2 As Double, b2 As Double, c2 As Double ‘第二条直线方程的系数a2*x + b2*y + c2=0
Dim i1 As Long, i2 As Long
Dim j1 As Long, j2 As Long
Dim bb1 As Double, bb2 As Double
Dim cc1 As Double, cc2 As Double
xx = 0.00001
yy = xx
‘判断四点中是否有两点是相同的
‘如果A、C为一点
If (IsEqual(x1, x3) And IsEqual(y1, y3)) = True Then
xx = x1
yy = y1
PlsLs = True
Exit Function
End If
‘如果A、D为一点
If (IsEqual(x1, x4) And IsEqual(y1, y4)) = True Then
xx = x1
yy = y1
PlsLs = True
Exit Function
End If
‘如果B、C为一点
If (IsEqual(x2, x3) And IsEqual(y2, y3)) = True Then
xx = x2
yy = y2
PlsLs = True
Exit Function
End If
‘如果B、D为一点
If (IsEqual(x2, x4) And IsEqual(y2, y4)) = True Then
xx = x2
yy = y2
PlsLs = True
Exit Function
End If
‘---------------------------------------------------------------------
If CoEff1(x1, y1, x2, y2, a1, b1, c1) = False Then
PlsLs = False
Exit Function
End If
If CoEff1(x3, y3, x4, y4, a2, b2, c2) = False Then
PlsLs = False
Exit Function
End If
i1 = Jponli(x1, y1, a2, b2, c2)
i2 = Jponli(x2, y2, a2, b2, c2)
j1 = Jponli(x3, y3, a1, b1, c1)
j2 = Jponli(x4, y4, a1, b1, c1)
‘如果两直线重合
If (i1 = 0 And i2 = 0 And j1 = 0 And j2 = 0) Then
PlsLs = False
Exit Function
End If
‘如果有一点在另一条直线上
If ((i1 * i2 * j1 * j2) = 0) Then
‘如果A在l2上
If (i1 = 0) Then
‘如果C、D在l1两侧
If ((j1 * j2) <= 0) Then
xx = x1
yy = y1
PlsLs = True
Exit Function
End If
PlsLs = False
Exit Function
End If
‘如果B在l2上
If (i2 = 0) Then
‘如果C、D在l1两侧
If ((j1 * j2) <= 0) Then
xx = x2
yy = y2
PlsLs = True
Exit Function
End If
PlsLs = False
Exit Function
End If
‘如果C在l1上
If (j1 = 0) Then
‘如果A、B在l2两侧
If ((i1 * i2) <= 0) Then
xx = x3
yy = y3
PlsLs = True
Exit Function
End If
PlsLs = False
Exit Function
End If
‘如果D在l1上
If (j2 = 0) Then
‘如果A、B在l2两侧
If ((i1 * i2) <= 0) Then
xx = x4
yy = y4
PlsLs = True
Exit Function
End If
PlsLs = False
Exit Function
End If
Else ‘如果没有一点在另一条直线上
‘如果两线段相互交叉
If ((i1 * i2 + j1 * j2) = -2) Then
bb1 = b1 * a2
bb2 = b2 * a1
cc1 = c1 * a2
cc2 = c2 * a1
If IsEqual(bb1, bb2) = True Then
PlsLs = False
Exit Function
End If
yy = -(cc1 - cc2) / (bb1 - bb2)
cc1 = c1 * b2
cc2 = c2 * b1
xx = -(cc1 - cc2) / (bb2 - bb1)
PlsLs = True
Exit Function
End If
PlsLs = False
Exit Function
End If
‘--------------
PlsLs = False
End Function
‘******************************************************************************
‘两点确定一条直线
‘输入两点坐标A(x1, y1) B(x2, y2)
‘输出直线方程l: *a*x + *b*y + *c = 0
‘如果是同一点 return FALSE, *a = *b = *c = 0
‘成功 return TRUE
Private Function CoEff1(ByVal x1 As Double, ByVal y1 As Double, _
ByVal x2 As Double, ByVal y2 As Double, _
a As Double, b As Double, c As Double) As Boolean
If IsEqual(x1, x2) And IsEqual(y1, y2) Then ‘如果是同一点
a = 0#
b = 0#
c = 0#
CoEff1 = False
End If
‘-------------------
a = y2 - y1
b = x1 - x2
c = -x1 * a - y1 * b
CoEff1 = True
End Function
‘******************************************************************************
Private Function IsCross(ByVal P1 As MapXLib.Point, ByVal P2 As MapXLib.Point, ByVal P As MapXLib.Point) As Integer
Dim xt As Integer
Dim direc As Long
If (P.y > P1.y And P.y > P2.y) Or (P.y < P1.y And P.y < P2.y) Then
IsCross = 0 ‘不相交
Exit Function
End If
If P2.y = P1.y Then
If P.y = P1.y Then
If (P.x > P1.x And P.x > P2.x) Then
IsCross = 2 ‘无法判断
Else
If (P.x < P1.x And P.x < P2.x) Then
IsCross = 0
Else
direc = 1 ‘热点坐标正好位于多边形的边界
End If
End If
Else
IsCross = 0
End If
Exit Function
End If
xt = P1.x + 1# * (P2.x - P1.x) * (P.y - P1.y) / (P2.y - P1.y)
If xt > P.x Then
IsCross = 0
Else
If xt = P.x Then
direc = 1
Else
If (P.y = P1.y Or P.y = P2.y) Then
IsCross = 2
Else
IsCross = 1 ‘相交
End If
End If
End If
End Function
‘******************************************************************************
‘是否在多边形内
‘1表示在多边形内，0表示在多边形外
Private Function IsInner(ByVal pts As MapXLib.Points, ByVal P As MapXLib.Point) As Integer
Dim i As Integer
Dim ret As Integer
Dim sum As Integer
Dim direc As Long
Dim num As Long
Dim px() As New MapXLib.Point
ret = 0
sum = 0
direc = 0
num = pts.Count
If pts.Count < 3 Then
IsInner = 2 ‘
Exit Function
End If
ReDim px(0 To num - 1)
For i = 0 To num - 1
px(i).Set pts.Item(i + 1).x, pts.Item(i + 1).y
Next i
For i = 0 To num - 2
ret = IsCross(px(i), px(i + 1), P)
If ret = 2 Then
IsInner = 2
Exit Function
End If
sum = sum + ret
Next i
ret = IsCross(px(num - 1), px(0), P)
If ret = 2 Then
IsInner = 2 ‘无法判断
Exit Function
End If
sum = sum + ret
If direc Then
IsInner = 1 ‘位于多边形区域内
Exit Function
End If
If sum Mod 2 = 0 Then
IsInner = 0 ‘位于多边形区域外
Else
IsInner = 1
End If
End Function
‘******************************************************************************
‘求出(x1,y1)到(x2,y2)之间的距离
Public Function GetDistance(ByVal x1 As Double, ByVal y1 As Double, ByVal x2 As Double, ByVal y2 As Double) As Double
Dim xx As Double
Dim yy As Double
xx = Abs(x1 - x2)
yy = Abs(y1 - y2)
GetDistance = Sqr(xx * xx + yy * yy)
End Function
‘******************************************************************************
Public Function SnapNewPoints(ByVal pts As MapXLib.Points, curX As Double, curY As Double, Range) As Boolean
Dim pt As MapXLib.Point
Dim nstPoint As UPoint ‘最近点：MAP坐标
Dim nstDistance As Double ‘最短的距离
Dim calDistance As Double ‘计算出来的距离
‘Initialize the Data
nstPoint.x = curX
nstPoint.y = curY
nstDistance = Range
‘-------------------------------------
For Each pt In pts
‘计算距离
calDistance = GetDistance(pt.x, pt.y, nstPoint.x, nstPoint.y)
If calDistance < nstDistance Then
nstPoint.x = pt.x
nstPoint.y = pt.y
nstDistance = calDistance
End If
Next
‘return the value
curX = nstPoint.x
curY = nstPoint.y
If nstDistance < Range Then
SnapNewPoints = True
Else
SnapNewPoints = False
End If
End Function
‘******************************************************************************
‘--------------------------------------------------
‘直角坐标与极坐标相互转换
‘flag:1-------极坐标 → 直角坐标
‘ 0-------直角坐标 → 极坐标
‘参数中：angle的单位为弧度
‘--------------------------------------------------
Public Sub REC2POLAR(ByVal x1 As Double, ByVal y1 As Double, x2 As Double, y2 As Double, dist As Double, angle As Double, ByVal flag As Long)
If flag = 1 Then ‘极坐标 → 直角坐标
x2 = x1 + dist * Cos(angle)
y2 = y1 + dist * Sin(angle)
Exit Sub
End If
‘直角坐标 → 极坐标
‘求(x2,y2)到(x1,y1)之间的距离
dist = Sqr((x2 - x1) * (x2 - x1) + (y2 - y1) * (y2 - y1))
If dist = 0 Then
angle = 0
Exit Sub
End If
‘----------------------
angle = Acos((x2 - x1) / dist)
If y2 < y1 Then
If x2 > x1 Then
angle = 2 * PI_IN_MATH - angle
Else
angle = 2 * PI_IN_MATH - angle
End If
End If
End Sub
‘******************************************************************************
‘反余弦函数
‘返回值是弧度
Public Function Acos(ByVal x As Double) As Double
Select Case x
Case 1
Acos = 0
Case -1
Acos = PI_IN_MATH
Case Else
Acos = Atn(-x / Sqr(-x * x + 1)) + 2 * Atn(1)
End Select
End Function
‘******************************************************************************
‘反正弦函数，返回值单位是弧度
Public Function Asin(ByVal x As Double) As Double
Select Case x
Case 1
Asin = PI_IN_MATH / 2
Case -1
Asin = -PI_IN_MATH / 2
Case Else
Atn (x / Sqr(-x * x + 1))
End Select
End Function
‘******************************************************************************
‘求(x1,y1)——(x2,y2)与
‘ (x3,y3)——(x4,y4）两条直线的交点
‘以上有向线段
Public Sub GetIntersetPt(ByVal x1 As Double, ByVal y1 As Double, _
ByVal x2 As Double, ByVal y2 As Double, _
ByVal x3 As Double, ByVal y3 As Double, _
ByVal x4 As Double, ByVal y4 As Double, _
x0 As Double, y0 As Double)
Dim dlt12 As Double
Dim dlt34 As Double
Dim CosA1 As Double
Dim CosA2 As Double
Dim flag As Long ‘1,2,3,4
‘求余弦平方
flag = -1
CosA1 = (x1 - x2) * (x1 - x2) / ((x1 - x2) * (x1 - x2) + (y1 - y2) * (y1 - y2))
CosA2 = (x3 - x4) * (x3 - x4) / ((x3 - x4) * (x3 - x4) + (y3 - y4) * (y3 - y4))
‘1:平行或在同一条直线上
If CosA1 = CosA2 Then
flag = 1
Else
‘2:
If (CosA1 = 1) And (CosA2 <> 1) Then
flag = 2
End If
‘3:
If (CosA1 <> 1) And (CosA2 = 1) Then
flag = 3
End If
‘4:
If (CosA1 <> 1) And (CosA2 <> 1) Then
If (CosA1 = 0) And (CosA2 <> 0) Then
flag = 4
End If
If (CosA1 <> 0) And (CosA2 = 0) Then
flag = 5
End If
If (CosA1 <> 0) And (CosA2 <> 0) Then
flag = 6
End If
End If
End If
‘-------------------
Select Case (flag)
Case 1
x0 = (x2 + x4) / 2
y0 = (y2 + y4) / 2
Case 2
y0 = y2
dlt34 = (x3 - x4) / (y3 - y4)
x0 = x3 - (y3 - y0) * dlt34
Case 3
y0 = y4
dlt12 = (x1 - x2) / (y1 - y2)
x0 = x1 - (y1 - y0) * dlt12
Case 4
x0 = x2
dlt34 = (x3 - x4) / (y3 - y4)
y0 = y3 - (x3 - x0) / dlt34
Case 5
x0 = x4
dlt12 = (x1 - x2) / (y1 - y2)
y0 = y1 - (x1 - x0) / dlt12
Case 6
dlt12 = (x1 - x2) / (y1 - y2)
dlt34 = (x3 - x4) / (y3 - y4)
x0 = ((y3 * dlt12 * dlt34 - x3 * dlt12) - (y1 * dlt12 * dlt34 - x1 * dlt34)) / (dlt34 - dlt12)
y0 = y1 - (x1 - x0) / dlt12
End Select
End Sub
‘******************************************************************************
‘求点到线集的最近距离、线在线集中的位置，
‘并给出点在线集的侧向
‘返回值：1表示逆时针
‘ 0表示顺时针
‘(x,y)多边形外一点
‘pts 点集
Public Function IsClockWise(ByVal x As Double, ByVal y As Double, ByVal pts As MapXLib.Points) As Long
Dim min As Double
Dim irec As Long
Dim ct As Long
Dim i As Long
Dim pt() As UPoint
Dim R As Double
Dim dd As Double
ct = pts.Count
If ct <= 1 Then
IsClockWise = -1
Exit Function
End If
‘-------------------------------------
ReDim pt(1 To ct)
For i = 1 To ct
pt(i).x = pts.Item(i).x
pt(i).y = pts.Item(i).y
Next i
R = 0
‘求(x,y)到第一个点的距离
min = Sqr((x - pt(1).x) * (x - pt(1).x) + (y - pt(1).y) * (y - pt(1).y))
For i = 1 To ct - 1
dd = PtDist2Line(x, y, pt(i).x, pt(i).y, pt(i + 1).x, pt(i + 1).y)
If dd <= min Then
min = dd
R = i
End If
Next i
‘-----------------
min = (x - pt(R + 1).x) * (x - pt(R + 1).x) + (y - pt(R + 1).y) * (y - pt(R + 1).y)
dd = (x - pt(R).x) * (x - pt(R).x) + (y - pt(R).y) * (y - pt(R).y)
‘----------------------
If min > dd Then
irec = R
Else
irec = R + 1
End If
‘-----------------------
dd = (pt(R + 1).y - pt(R).y) * (x - pt(R).x) - (pt(R + 1).x - pt(R).x) * (y - pt(R).y)
If dd < 0 Then
IsClockWise = 1
Else
IsClockWise = 0
End If
End Function
‘******************************************************************************
‘求点到线段的最近距离
Public Function PtDist2Line(ByVal x As Double, ByVal y As Double, _
ByVal x1 As Double, ByVal y1 As Double, _
ByVal x2 As Double, ByVal y2 As Double) As Double
Dim dist01 As Double
Dim dist02 As Double
Dim dist12 As Double
Dim d As Double
Dim dx As Double
Dim dy As Double
‘dist p - p1
dy = y - y1
dx = x - x1
dist01 = dy * dy + dx * dx
‘dist p-p2
dy = y - y2
dx = x - x2
dist02 = dy * dy + dx * dx
‘dist p1-p2
dy = y1 - y2
dx = x1 - x2
dist12 = dy * dy + dx * dx
If (((dist01 + dist12) > dist02) And ((dist02 + dist12) > dist01)) Then ‘余弦定理: p1角<90 并且 p2角<90
d = Abs(-dy * (x - x2) + dx * (y - y2)) / Sqr(dist12) ‘ dist p - line(p1-p2)
Else
If dist01 < dist02 Then
d = Sqr(dist01)
Else
d = Sqr(dist02)
End If
End If
PtDist2Line = d
End Function
‘******************************************************************************
‘------------------------------------------------------
‘返回有向线段Pt1-->pt2与水平线之间的夹角(0～2π)
‘-----------------------------------------------------------
Public Function GetAngle(ByVal pt1 As MapXLib.Point, ByVal pt2 As MapXLib.Point) As Double
Dim a As Double ‘夹角
Dim l As Double ‘弦长
Dim pt0 As UPoint ‘pt2相对于pt1的相对坐标
l = Sqr((pt1.x - pt2.x) * (pt1.x - pt2.x) + (pt1.y - pt2.y) * (pt1.y - pt2.y))
a = Acos((pt2.x - pt1.x) / l)
pt0.x = pt2.x - pt1.x
pt0.y = pt2.y - pt1.y
If pt0.y < 0 Then
a = 2 * PI_IN_MATH - a
End If
‘---------------------
GetAngle = a
End Function
‘******************************************************************************
‘-------------------------------------------------
‘参数
‘Pt1,pt2,pt3
‘根据pt3在有向线段pt1->pt2的侧向，来判断是
‘优弧(1)还是劣弧(0)
‘----------------------------------------------------------------
Public Function IsYouHu(ByVal pt1 As MapXLib.Point, ByVal pt2 As MapXLib.Point, ByVal pt3 As MapXLib.Point) As Long
Dim a12 As Double ‘角度
Dim a13 As Double ‘角度
Dim b As Double ‘角度
Dim L13 As Double
Dim p3y As Double
a12 = GetAngle(pt1, pt2)
b = 2 * PI_IN_MATH - a12
a13 = GetAngle(pt1, pt3)
L13 = Sqr((pt3.x - pt1.x) * (pt3.x - pt1.x) + (pt3.y - pt1.y) * (pt3.y - pt1.y))
‘-----------
p3y = L13 * Sin(a13 + b)
‘---------
If p3y > 0 Then
IsYouHu = 0
Else
IsYouHu = 1
End If
End Function
标签：
原文地址：http://www.cnblogs.com/hartigen/p/4334260.html
