mainprog.bas

房产测绘用的软件源代码

    End If
    
    'second:采用二进制格式打开文件
    FileNum = FreeFile()
    Open FileName For Binary Access Read Lock Write As #FileNum
    
    ReadFromLog = Input(LOF(FileNum), FileNum)
    
    'close the filename
    Close #FileNum
    Set fs = Nothing
    
    Exit Function
ErrHandler:
    Close #FileNum
    MsgBox "Public ReadFromLog()" & vbCrLf & _
           "错误#" & Err.Number & ":" & Err.Description, vbOKOnly + vbExclamation, SYSTEMTITLE
    
End Function
'清除系统日志
Public Sub ClearUpSystemLog()
    On Error GoTo ErrHandler
    'clear up the system.log
    'first:判断制定路径的文件是否存在
    Dim fs As Scripting.FileSystemObject
    Dim FileName As String
    Dim EXEPath As String
    Dim FileNum As Integer
    
    EXEPath = App.path & "\" & "system.log"
    FileName = SYSTEM_LOG_PATH & "system.log"
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    '如果数据库服务器上没有日志文件，则判断工作站是否存在该文件，如果存在，则
    'copy一份过去
    '采用删除文件的方法来清除其内容
    If fs.FileExists(FileName) Then
        fs.DeleteFile FileName, True
    End If
    'second:采用二进制格式创建一个空文件
    FileNum = FreeFile()
    Open FileName For Binary Access Write Lock Write As #FileNum
    
    'close the filename
    Close #FileNum
    Set fs = Nothing
    
    Exit Sub
ErrHandler:
    Close #FileNum
    MsgBox "Public ClearUpSystemLog()" & vbCrLf & _
           "错误#" & Err.Number & ":" & Err.Description, vbOKOnly + vbExclamation, SYSTEMTITLE
End Sub
'--------------------------------
'功能：1.找出当前层中距离给定点最近的点
'      2.如果最近点与给定点的距离小于给定值，则返回最近点，并返回true;
'        否则返回当前点，并返回false
'返回值：1.最近的点
'        2.是否找到最近的点
'输入参数单位：象素
'计算单位：象素
'-------------------------------------
Public Function SnapIt(MapX45 As Map, ByVal CurLayerName As String, curX As Double, curY As Double, ByVal Range As Double) As Boolean
    Dim nstPoint As UPoint '最近点：MAP坐标
    Dim nstDistance As Double '最短的距离
    Dim calDistance As Double '计算出来的距离
    Dim pt As MapXLib.Point
    Dim pts As MapXLib.Points
    Dim fs As MapXLib.Features
    Dim f As MapXLib.Feature
    Dim i As Long
    Dim ct As Long
    
    'Initialize the Data
    nstPoint.X = curX
    nstPoint.Y = curY
    nstDistance = Range
    '1:求出最近点nstPoint和最近距离nstDistance
    Set fs = MapX45.Layers.Item(CurLayerName).AllFeatures
    For Each f In fs
        '只对线和区域才判断
        If (f.Type = miFeatureTypeRegion) Or (f.Type = miFeatureTypeLine) Then
            ct = f.Parts.Count
            For i = 1 To ct
                Set pts = f.Parts.Item(i)
                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
            Next i
        End If
    Next
    '2:返回点
    curX = nstPoint.X
    curY = nstPoint.Y
    If nstDistance < Range Then
        SnapIt = True
    Else
        SnapIt = False
    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
'计算一个Features集合中有多少个Feature
Public Function GetCountFromFeatures(fs As MapXLib.Features) As Long
    Dim f As MapXLib.Feature
    Dim ct As Long
    For Each f In fs
        ct = ct + 1
    Next
    GetCountFromFeatures = ct
End Function
'墙体产生算法
'求折线集的平行线集
'输入参数：Pts0（源点集)
'        LIN0WID（Offset的距离)
'        MSTART(0表示向外，1表示向内)
'返回值：Pts1（目标点集）
Public Function OffSetPolyLine(ByVal Pts0 As MapXLib.Points, Pts1 As MapXLib.Points, ByVal LIN0WID As Double, ByVal MSTART As Long) As Boolean
    Dim i As Long
    Dim ct As Long
    Dim dist As Double
    Dim ANGLE1 As Double
    Dim ANGLE2 As Double
    Dim ag1 As Double
    Dim ag2 As Double
    Dim TTT As Double
    Dim SLOPE As Double
    Dim OFFSET_RIGHT As Long
    Dim OFFSET_LEFT As Long
    Dim pt As New MapXLib.Point
    Dim pt1() As UPoint '记录输入点集
    Dim pt2() As UPoint '记录输出点集
    Dim x0 As Double
    Dim y0 As Double
    Dim flag_ok As Long
    Dim MINI As Double
    
    MINI = 0.000000001
    ct = Pts0.Count
    If ct < 2 Then '如果输入的点集小于2则退出
        OffSetPolyLine = False
        Exit Function
    End If
    '记录输入和输出点集
    ReDim pt1(1 To ct)
    ReDim pt2(1 To ct)
    For i = 1 To ct
        pt1(i).X = Pts0.Item(i).X
        pt1(i).Y = Pts0.Item(i).Y
    Next
    
    '------------------------------------
    Call REC2POLAR(pt1(1).X, pt1(1).Y, _
                   pt1(2).X, pt1(2).Y, _
                   dist, ANGLE1, 0)
    ag1 = ANGLE1 - PI_IN_MATH / 2
    ag2 = ANGLE1 + PI_IN_MATH / 2
    dist = LIN0WID
    '处理第一点
    If MSTART = OFFSET_OUT Then
        Call REC2POLAR(pt1(1).X, pt1(1).Y, _
                       pt2(1).X, pt2(1).Y, _
                       dist, ag1, 1)
    End If
    If MSTART = OFFSET_IN Then
        Call REC2POLAR(pt1(1).X, pt1(1).Y, _
                       pt2(1).X, pt2(1).Y, _
                       dist, ag2, 1)
    End If
    '----------------------------
    '处理最后一点
    '----------------------------------
    Call REC2POLAR(pt1(ct - 1).X, pt1(ct - 1).Y, _
                   pt1(ct).X, pt1(ct).Y, _
                   dist, ANGLE1, 0)
    ag1 = ANGLE1 - PI_IN_MATH / 2
    ag2 = ANGLE1 + PI_IN_MATH / 2
    dist = LIN0WID
    
    If MSTART = OFFSET_OUT Then
        Call REC2POLAR(pt1(ct).X, pt1(ct).Y, _
                       pt2(ct).X, pt2(ct).Y, _
                       dist, ag1, 1)
    End If
    If MSTART = OFFSET_IN Then
        Call REC2POLAR(pt1(ct).X, pt1(ct).Y, _
                       pt2(ct).X, pt2(ct).Y, _
                       dist, ag2, 1)
    End If

    '如果只有两点，则退出
    If ct <= 2 Then
        '返回
        For i = 1 To ct
            pt.Set pt2(i).X, pt2(i).Y
            Pts1.Add pt
        Next i
        '---------------
        OffSetPolyLine = True
        Exit Function
    End If
    '--------------------------------------------------
    '处理第二点到最后一点
    For i = 2 To ct
        flag_ok = 0
        If i < ct Then
            Call REC2POLAR(pt1(i).X, pt1(i).Y, _
                           pt1(i - 1).X, pt1(i - 1).Y, _
                           dist, ANGLE1, 0)
            Call REC2POLAR(pt1(i).X, pt1(i).Y, _
                           pt1(i + 1).X, pt1(i + 1).Y, _
                           dist, ANGLE2, 0)
            flag_ok = 1
        Else
            If (pt1(1).X = pt1(ct).X) And _
               (pt1(1).Y = pt1(ct).Y) Then '闭合线
                Call REC2POLAR(pt1(i).X, pt1(i).Y, _
                               pt1(i - 1).X, pt1(i - 1).Y, _
                               dist, ANGLE1, 0)
                Call REC2POLAR(pt1(i).X, pt1(i).Y, _
                               pt1(1).X, pt1(1).Y, _
                               dist, ANGLE2, 0)
                flag_ok = 2
            End If
        End If
        
        If flag_ok = 0 Then
        Else
            TTT = ANGLE2 - ANGLE1
            If TTT < 0# Then
                TTT = TTT + 2# * PI_IN_MATH
            End If
            TTT = TTT / 2#
            If TTT >= (PI_IN_MATH / 2#) Then
                SLOPE = PI_IN_MATH - TTT
            Else
                SLOPE = TTT
            End If
            
            SLOPE = Sin(SLOPE)
            If SLOPE > MINI Then
                SLOPE = LIN0WID / SLOPE
            End If
            TTT = ANGLE2 - TTT
            
            If MSTART = OFFSET_OUT Then
                Call REC2POLAR(pt1(i).X, pt1(i).Y, _
                               pt2(i).X, pt2(i).Y, _
                               SLOPE, TTT, 1)
            Else
                If TTT >= PI_IN_MATH Then
                    TTT = TTT - PI_IN_MATH
                Else
                    TTT = TTT + PI_IN_MATH
                End If
                Call REC2POLAR(pt1(i).X, pt1(i).Y, _
                               pt2(i).X, pt2(i).Y, _
                               SLOPE, TTT, 1)
            End If
        End If
    Next i
    '闭合线(flag_ok=2)
    If (pt1(1).X = pt1(ct).X) And (pt1(1).Y = pt1(ct).Y) Then
        '第一点等于最后一点
'        pt2(1).x = pt2(ct).x
'        pt2(1).y = pt2(ct).y
        GetIntersetPt pt2(ct - 1).X, pt2(ct - 1).Y, _
                      pt2(ct).X, pt2(ct).Y, _
                      pt2(2).X, pt2(2).Y, _
                      pt2(1).X, pt2(1).Y, _
                      x0, y0
        pt2(1).X = x0
        pt2(1).Y = y0
        pt2(ct).X = x0
        pt2(ct).Y = y0
    End If
    '最后返回结果点集
    For i = 1 To ct
        pt.Set pt2(i).X, pt2(i).Y