frmmain.frm

这是基于MapX4.0的房屋测绘管理信息系统

    End If
    SizeControls picSplitter.Left
    picSplitter.Visible = False
End Sub

Private Sub lstPoints_DblClick()
    If lstPoints.ListIndex >= 0 Then
        lstPoints.RemoveItem lstPoints.ListIndex
    End If
End Sub

Private Sub Map1_DblClick()
    Dim fs As MapXLib.Features
    Dim f As MapXLib.Feature
    Dim frm As frmText
    
    On Error Resume Next
    
    Select Case Map1.CurrentTool
        Case miSelectTool '文字编辑
            Set fs = Map1.Layers.Item(LINE_LAYER).Selection
            If GetCountFromFeatures(fs) <= 0 Then
                Exit Sub
            End If
            Set f = fs(1)
            If f.Type = miFeatureTypeText Then
                Set frm = New frmText
                Load frm
                frm.FeatureCaption = f.Caption
                frm.Show vbModal
                If frm.IsCanceled = False Then
                    If frm.FeatureCaption = "" Then
                        Map1.Layers.Item(LINE_LAYER).DeleteFeature f.FeatureKey
                    Else
                        f.Caption = frm.FeatureCaption
                        f.Update
                    End If
                End If
            End If
            Set frm = Nothing
        Case Else
    End Select
End Sub
Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Select Case Map1.CurrentTool
        Case ctLineTool
            NewPts.Add nPt
        Case ctPolyLineTool, ctPolygonTool, ctArcTool
            If Button = vbRightButton Then
                SendKeys "{ESC}"
            End If
        Case Else
    End Select
End Sub
Private Sub Map1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim MapCoordX As Double, MapCoordY As Double
    
    Map1.ConvertCoord X, Y, MapCoordX, MapCoordY, miScreenToMap
    'On Error Resume Next
    Select Case Map1.CurrentTool
        Case ctLineTool, ctPolyLineTool, ctPolygonTool, ctArcTool
            '1:在已经保存的图中查找
            If SnapIt(Map1, LINE_LAYER, MapCoordX, MapCoordY, SHORTEST_DISTANCE) = True Then
                SetMapMousePointer miCenterCursor, ""
            Else
                SetMapMousePointer miCrossCursor, ""
                '2:在还没有保存的Points中查找
                If SnapNewPoints(NewPts, MapCoordX, MapCoordY, SHORTEST_DISTANCE) Then
                    SetMapMousePointer miCenterCursor, ""
                Else
                    SetMapMousePointer miCrossCursor, ""
                End If
            End If
            'set the a new point
            nPt.Set MapCoordX, MapCoordY
            '------------------------------------
            sbStatusBar.Panels(1).Text = CStr(Round(MapCoordX, 2)) & "," & CStr(Round(MapCoordY, 2))
        Case ctPointSelectTool, ctGenWallTool
            'set the a new point
            nPt.Set MapCoordX, MapCoordY
        Case Else
    End Select
End Sub

Private Sub Map1_PolyToolUsed(ByVal ToolNum As Integer, ByVal Flags As Long, ByVal Points As Object, ByVal bShift As Boolean, ByVal bCtrl As Boolean, EnableDefault As Boolean)
    Dim f As New MapXLib.Feature
    
    On Error GoTo ErrHandler
    '------------------------------------
    Select Case ToolNum
        Case ctArcTool
            Select Case Flags
                Case miPolyToolBegin
                    NewPts.RemoveAll
                    '添加point
                    NewPts.Add nPt
                Case miPolyToolInProgress
                    '添加point
                    NewPts.Add nPt
                Case miPolyToolEnd, miPolyToolEndEscaped
                    '如果是双击，则保存最后一个节点
                    If Flags = miPolyToolEnd Then
                        NewPts.Add nPt
                    End If
                    '加入图形中
                    If NewPts.Count = 2 Then
                        Set f = CreateArc(Map1, NewPts.Item(1), NewPts.Item(2))
                        Map1.Layers.Item(LINE_LAYER).AddFeature f
                        '-----------------------------
                        Map1.Refresh
                    End If
                    'clear the newpts
                    NewPts.RemoveAll
                Case Else
            End Select
        Case ctPolyLineTool
            Select Case Flags
                Case miPolyToolBegin
                    NewPts.RemoveAll
                    '添加point
                    NewPts.Add nPt
                Case miPolyToolInProgress
                    '添加point
                    NewPts.Add nPt
                Case miPolyToolEnd, miPolyToolEndEscaped
                    '如果是双击，则保存最后一个节点
                    If Flags = miPolyToolEnd Then
                        NewPts.Add nPt
                    End If
                    '加入图形中
                    If NewPts.Count >= 2 Then
                        f.Attach Map1
                        f.Type = miFeatureTypeLine
                        f.Parts.Add NewPts
                        AddPointToListBox NewPts
                        Map1.Layers.Item(LINE_LAYER).AddFeature f
                        '-----------------------------
                        Map1.Refresh
                    End If
                    'clear the newpts
                    NewPts.RemoveAll
                Case Else
            End Select
        Case ctPolygonTool
            Select Case Flags
                Case miPolyToolBegin
                    NewPts.RemoveAll
                    '添加point
                    NewPts.Add nPt
                Case miPolyToolInProgress
                    '添加point
                    NewPts.Add nPt
                Case miPolyToolEnd, miPolyToolEndEscaped
                    '如果是双击，则保存最后一个节点
                    If Flags = miPolyToolEnd Then
                        NewPts.Add nPt
                    End If
                    '加入图形中
                    If NewPts.Count >= 3 Then
                        f.Attach Map1
                        '以下一行是和ctPolyLine的区别
                        f.Type = miFeatureTypeRegion
                        '----------------------------
                        f.Parts.Add NewPts
                        AddPointToListBox NewPts
                        f.Style.RegionPattern = miPatternSolid
                        f.Style.RegionColor = lblWZ.BackColor
                        Set f = Map1.Layers.Item(REGION_LAYER).AddFeature(f)
                        '-------------------------------------------------
                        '往tbFeature里添加一条记录，即增加一个Region Feature
                        Call AddFeatureToDB(REGION_LAYER, f.FeatureKey)
                        '--------------------------------------
                        Map1.Refresh
                    End If
                    'clear the newpts
                    NewPts.RemoveAll
                Case Else
            End Select
        Case Else
    End Select
    Exit Sub
ErrHandler:
    NewPts.RemoveAll
    ErrMessageBox "Map1_PolyToolUsed()", Me.Caption
End Sub
Private Sub Map1_ToolUsed(ByVal ToolNum As Integer, ByVal x1 As Double, ByVal y1 As Double, ByVal x2 As Double, ByVal y2 As Double, ByVal distance As Double, ByVal Shift As Boolean, ByVal Ctrl As Boolean, EnableDefault As Boolean)
    Dim f As New MapXLib.Feature
    Dim pts As New MapXLib.Points '源点集
    Dim ScreenX As Single
    Dim ScreenY As Single
    Dim frm As frmText
    Dim fs0 As MapXLib.Features
    '以下是用于墙体生成的变量
    Dim pts2 As New MapXLib.Points '目标点集
    Dim frmW As New frmWallHeight
    Dim wallF As New MapXLib.Feature
    Dim irec As Long

    Select Case ToolNum
        Case ctLineTool
            '显示当前point
            txtBeginX = CStr(nPt.X)
            txtBeginY = CStr(nPt.Y)
            f.Attach Map1
            '创建一个点
            f.Style.SymbolCharacter = 1
            f.Point.Set nPt.X, nPt.Y
            Map1.Layers.Item(CURRENT_LAYER).AddFeature f
        Case miZoomOutTool '缩小
            SHORTEST_DISTANCE = SHORTEST_DISTANCE * 2
        Case miZoomInTool '放大
            SHORTEST_DISTANCE = SHORTEST_DISTANCE / 2
        Case miTextTool '标签
            EnableDefault = False
            Set frm = New frmText
            Load frm
            frm.Show vbModal
            If frm.IsCanceled = False And frm.FeatureCaption <> "" Then
                'Add a new text object to layer 1
                f.Attach Map1
                f.Type = miFeatureTypeText
                f.Point.Set x1, y1
                f.Caption = frm.FeatureCaption
                Map1.Layers.Item(LINE_LAYER).AddFeature f
            End If
            Set frm = Nothing
            Set f = Nothing
        Case ctPointSelectTool '点选构面
            '5:先判断封闭面是否已经存在了
            If SearchRegion(nPt) Then
                MsgBox "封闭面已经存在，请选择其他封闭环！", vbOKOnly + vbInformation, "提示"
            Else
                Set fs0 = Map1.Layers.Item(LINE_LAYER).AllFeatures
                '10:判断是否有封闭环
                If SearchRing0(nPt, fs0, pts, miFeatureTypeLine, 1) Then
                    f.Attach Map1
                    f.Type = miFeatureTypeRegion
                    '----------------------------
                    f.Parts.Add pts
                    f.Style.RegionPattern = miPatternSolid
                    f.Style.RegionColor = lblWZ.BackColor
                    Set f = Map1.Layers.Item(REGION_LAYER).AddFeature(f)
                    '-------------------------------------------------
                    '往tbFeature里添加一条记录，即增加一个Region Feature
                    Call AddFeatureToDB(REGION_LAYER, f.FeatureKey)
                    '--------------------------------------
                    Map1.Refresh
                End If
            End If
        Case ctGenWallTool '生成墙体
            If mnuMaxRing.Checked Then
                mnuMaxRing.Checked = False
            Else
                Exit Sub
            End If
            Set fs0 = Map1.Layers.Item(LINE_LAYER).AllFeatures
            '10:判断是否有最大封闭环
            If SearchRing0(nPt, fs0, pts, miFeatureTypeLine, 0) Then
                '25：输入墙体厚度
                Set frmW = New frmWallHeight
                Load frmW
                frmW.Show vbModal
                If frmW.IsCanceled Or (frmW.WallThickness <= 0) Then
                    Exit Sub
                End If
                '30:调用墙体生成函数生成墙体点集pts2中
                irec = IsClockWise(0, 0, pts)
                If irec = 1 Then
                    Call OffSetPolyLine(pts, pts2, frmW.WallThickness, OFFSET_IN)
                Else
                    Call OffSetPolyLine(pts, pts2, frmW.WallThickness, OFFSET_OUT)
                End If
                '40：生成新的Feature
                f.Attach Map1
                f.Type = miFeatureTypeRegion
                f.Parts.Add pts
                
                wallF.Attach Map1
                wallF.Type = miFeatureTypeRegion
                wallF.Parts.Add pts2
                
                '50:erase the f
                Set wallF = Map1.FeatureFactory.EraseFeature(wallF, f)
                wallF.Attach Map1
                '53:delete the f
                'Map1.Layers.Item(REGION_LAYER).DeleteFeature f.FeatureKey
                Set f = Nothing
                '60：显示新的Feature（设置颜色等）
                Set wallF = Map1.Layers.Item(REGION_LAYER).AddFeature(wallF)
                wallF.Style.RegionPattern = miPatternSolid
                wallF.Style.RegionColor = lblQT.BackColor
                wallF.Update
                '65：向数据库里添加Feature
                Call AddFeatureToDB(REGION_LAYER, wallF.FeatureKey, 6)
                '--------------------------------------
                Map1.Refresh
            End If
        Case Else
    End Select
End Sub

Private Sub mnuAbout_Click()
    Dim frm As frmAbout
    Screen.MousePointer = 11
    Set frm = New frmAbout
    '设置系统标题
    frm.Caption = "关于 " + SYSTEMTITLE
    frm.lblTitle = SYSTEMTITLE
    
    Load frm
    Screen.MousePointer = 0
    
    frm.Show vbModal
End Sub

Private Sub mnuAreaDisp_Click()
'    Dim frm As frmAreaResult
'    Set frm = New frmAreaResult
'    Load frm
'    frm.Show vbModal
    Dim frm As frmReport
    Set frm = New frmReport
    Load frm
    frm.Show vbModal
End Sub

Private Sub mnuAttach_Click()
    '阳台、阁楼归属的规则是：
    '一个阳台阁楼只能属于一个户室，而一个户室可以有多个阳台、阁楼
    Dim SelectedFs As Features
    Dim Lyr As MapXLib.Layer
    Dim ytFS As New Features '阳台、阁楼面
    Dim hsFS As New Features '户室面
    Dim nWZ As Long  '未知类型的面图的个数
    Dim nOther As Long  '其他类型的面图的个数
    Dim rs As ADODB.Recordset
    Dim f As Feature
    Dim ft As Feature
    Dim szSQL As String
    Dim FType As Long '户室类型
    Dim msg As String '
    Dim bIsAttached As Boolean '是否被归属过了
    
    On Error GoTo ErrHandler
    
    Screen.MousePointer = 11
    Set Lyr = Map1.Layers.Item(REGION_LAYER)
    Set SelectedFs = Lyr.Selection
    Set hsFS = Lyr.NoFeatures
    Set ytFS = Lyr.NoFeatures
    
    '10:是否有选中的层
    If GetCountFromFeatures(SelectedFs) <= 0 Then
        Screen.MousePointer = 0
        Exit Sub
    End If
    '20:根据不同的Feature,存入不同的Features
    nWZ = 0
    nOther = 0
    For Each f In SelectedFs
        FType = 0 '0表示未知类型
        szSQL = "SELECT ftype FROM tbFeature " & _
              " WHERE tbName='" & REGION_LAYER & "' AND FtKey='" & f.FeatureKey & "'"
        Set rs = MAP_CONN.Execute(szSQL)
        rs.MoveLast
        'get the feature type
        If IsNull(rs!FType) Then