mainprog.bas

房产测绘用的软件源代码

        Pts1.Add pt
    Next i
    '----------------
    OffSetPolyLine = True
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
'-------------------------------------
'给出如下参数，绘制圆弧
'MapX45:map
'Pt1:第一个点的坐标
'Pt2：第二个点的坐标
'Raius：半径
'IsYouHu；是优弧还是劣弧(1:优弧0:劣弧)
'ptCt：弧的等分数
'返回值：MapXLib.Feature(type:PolyLine)
'--------------------------------------------------------------
Public Function CreateArc(MapX45 As Map, ByVal pt1 As MapXLib.Point, ByVal pt2 As MapXLib.Point, Optional ByVal Radius As Double = 0, Optional ByVal IsYouHu As Long = 1, Optional ByVal ptCt As Long = 30) As MapXLib.Feature
    Dim L12 As Double '弦长
    Dim R As Double '半径
    Dim aa As Double 'Pt1-->pt2与水平线的夹角
    Dim a As Double '等分角
    Dim b As Double 'b角
    Dim ai As Double 'ai角
    Dim yy As Double 'yy角
    Dim li As Double 'li:长度
    Dim ppi As UPoint
    Dim i As Long
    Dim n As Long
    Dim pts As New MapXLib.Points
    Dim pt As New MapXLib.Point
    
    '求弦长和半径
    L12 = Sqr((pt1.X - pt2.X) * (pt1.X - pt2.X) + (pt1.Y - pt2.Y) * (pt1.Y - pt2.Y))
    R = Radius
    If (2 * R) < L12 Then
        R = L12 / 2
    End If
    '求夹角
    aa = GetAngle(pt1, pt2)
    If IsYouHu = 1 Then
        b = 2 * PI_IN_MATH - 2 * Asin(L12 / (2 * R))
    Else
    End If
    '
    n = ptCt
    a = b / n
    yy = (2 * PI_IN_MATH - b) / 2
    pt.Set pt1.X, pt1.Y
    pts.Add pt
    For i = 2 To n
        ai = PI_IN_MATH - yy - a * (i - 1) / 2
        li = L12 * Sin(a * (i - 1) / 2) / Sin(yy)
        ppi.X = pt1.X + li * Cos(aa - ai)
        ppi.Y = pt1.Y + li * Sin(aa - ai)
        pt.Set ppi.X, ppi.Y
        pts.Add pt
    Next i
    pt.Set pt2.X, pt2.Y
    pts.Add pt
    Set CreateArc = MapX45.FeatureFactory.CreateLine(pts)
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