frmmain.frm

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

            FType = 0
        Else
            FType = CLng(rs!FType)
        End If
        Select Case FType
            Case 1 '户室
                hsFS.Add f
            Case 2, 3, 4 '阳台、封闭阳台、阁楼
                ytFS.Add f
            Case 0 '未知
                nWZ = nWZ + 1
            Case Else '其他
                nOther = nOther + 1
        End Select
    Next
    
    '30:判断各Features的状态
    msg = ""
    If GetCountFromFeatures(hsFS) <= 0 Then
        msg = "没有户室被选中！"
    Else
        If GetCountFromFeatures(hsFS) > 1 Then
            msg = "选择了多个户室！"
        End If
    End If
    If GetCountFromFeatures(ytFS) <= 0 Then
        If msg = "" Then
            msg = "没有阳台面或阁楼面被选中！"
        Else
            msg = msg & vbCrLf & "没有阳台面或阁楼面被选中！"
        End If
    End If
    If nWZ >= 1 Then
        If msg = "" Then
            msg = "存在不知类型的面图！"
        Else
            msg = msg & vbCrLf & "存在不知类型的面图！"
        End If
    End If
    If nOther >= 1 Then
        If msg = "" Then
            msg = "存在其他类型的面图！"
        Else
            msg = msg & vbCrLf & "存在其他类型的面图！"
        End If
    End If
    If msg <> "" Then
        Screen.MousePointer = 0
        Set rs = Nothing
        MsgBox "不能进行阳台、阁楼归属操作，可能的原因是：" & vbCrLf & vbCrLf & msg, vbOKOnly + vbInformation, Me.Caption
        Exit Sub
    End If
    '40:检查是否被归属过了
    bIsAttached = False
    For Each f In ytFS
        szSQL = "SELECT Count(*) as ct FROM tbFir " & _
                " WHERE F_tbName='" & REGION_LAYER & "' AND F_FtKey='" & f.FeatureKey & "'"
        Set rs = MAP_CONN.Execute(szSQL)
        If Not IsNull(rs("ct")) Then
            If rs!ct >= 1 Then
                bIsAttached = True '找到一个被归属的面
                Exit For
            End If
        End If
    Next
    If bIsAttached = True Then
        Set rs = Nothing
        Screen.MousePointer = 0
        MsgBox "不能进行阳台、阁楼归属操作，可能的原因是：" & vbCrLf & vbCrLf & _
               "其中有一个阳台面已经被归属过了！", vbOKOnly + vbInformation, Me.Caption
        Exit Sub
    End If
    '50：进行阳台归属
    For Each ft In ytFS '阳台、阁楼面
        For Each f In hsFS '户室
            szSQL = "INSERT INTO tbFir(F_TbName,F_FtKey,H_TbName,H_FtKey,Fttype) " & _
                    "VALUES('" & REGION_LAYER & "','" & ft.FeatureKey & "'," & _
                           "'" & REGION_LAYER & "','" & f.FeatureKey & "',3)" '3表示是阳台归属
            MAP_CONN.Execute szSQL
        Next
    Next
    '--------------------------------------
    MsgBox "阳台、阁楼归属操作成功完成！", vbOKOnly + vbInformation, Me.Caption
    '----------------------------------------
    Set rs = Nothing
    Screen.MousePointer = 0
    Exit Sub
ErrHandler:
    Screen.MousePointer = 0
    ErrMessageBox "mnuAttach()", Me.Caption
End Sub
Private Sub mnuBackup_Click()
    Dim BackupPath As String

    Dim fs As Scripting.FileSystemObject

    On Error GoTo ErrHandler

    frmBackup.Show vbModal
    BackupPath = frmBackup.BackupPath
    If BackupPath = "" Then '没有选择目录
        Exit Sub
    End If
    
    '备份数据库
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    If Not fs.FolderExists(BackupPath) Then '路径不存在，创建路径
        fs.CreateFolder BackupPath
    End If
    fs.CopyFile DATABASE_PATH & DATABASE_FILENAME, BackupPath & DATABASE_FILENAME
    

    MsgBox BK_COMPLETED, vbOKOnly + vbInformation, Me.Caption
    Exit Sub
ErrHandler:
    Dim msg As String
    msg = Me.Name & ":mnuBackup_Click()" & vbCrLf & _
        "数据库备份没有成功，可能的原因是,数据库正在被人使用。" & vbNewLine & vbCrLf & _
        "错误#" & CStr(Err.Number) & ":" & Err.Description

    MsgBox msg, vbOKOnly + vbCritical, Me.Caption
    '将错误写入日志
    WriteToLog (msg)
End Sub

Private Sub mnuCalc_Click()
    On Error Resume Next
    Dim fn As String
    fn = App.path
    If Right(fn, 1) <> "\" Then
        fn = fn & "\"
    End If
    fn = fn & "Calc.exe"
    WinExec fn, SW_SHOW
End Sub

Private Sub mnuCalcArea_Click()
    '面积计算
    Call CalculateArea
    '显示计算结果
    Call mnuAreaDisp_Click
End Sub
Private Sub mnuClose_Click()
    '关闭图形文件
    Call CloseCurrentMap
End Sub
'区域合并只对REGION_LAYER有效
Private Sub mnuCombine_Click()
    Dim Lyr As MapXLib.Layer
    Dim fs As MapXLib.Features
    Dim f As MapXLib.Feature
    
    On Error Resume Next
    Set Lyr = Map1.Layers.Item(REGION_LAYER)
    Set fs = Lyr.Selection
    '如果没有选择集或只有一个选择集，则退出
    If GetCountFromFeatures(fs) <= 1 Then
        Exit Sub
    End If
    'combine
    Set f = Map1.FeatureFactory.CombineFeatures(fs)
    '---------------
    Set f = Lyr.AddFeature(f)
    '--------------------------------
    '显示新的Feature（设置颜色等）
    f.Style.RegionPattern = miPatternSolid
    f.Style.RegionColor = lblWZ.BackColor
    f.Update
    '向数据库添加
    Call AddFeatureToDB(REGION_LAYER, f.FeatureKey)
End Sub
Private Sub mnuConvertToRegion_Click()
    Dim f As MapXLib.Feature
    Dim NewF As MapXLib.Feature
    Dim fs As MapXLib.Features
    Dim pts As New MapXLib.Points
    Dim Lyr As MapXLib.Layer
    Dim pt As MapXLib.Point
    Dim OldPts As MapXLib.Points
    Dim i As Long
    Dim ct As Long
    
    On Error Resume Next
    Set Lyr = Map1.Layers.Item(LINE_LAYER)
    Set fs = Lyr.Selection
    If GetCountFromFeatures(fs) <= 0 Then
        Exit Sub
    End If
    For Each f In fs
        ct = f.Parts.Count
        For i = 1 To ct
            Set OldPts = f.Parts.Item(i)
            For Each pt In OldPts
                pts.Add pt
            Next
        Next i
    Next
    If pts.Count < 3 Then
        Exit Sub
    End If
    Set NewF = Map1.FeatureFactory.CreateRegion(pts)
    NewF.Style.RegionPattern = miPatternSolid
    NewF.Style.RegionColor = lblWZ.BackColor
    Set NewF = Map1.Layers.Item(REGION_LAYER).AddFeature(NewF)
    NewF.Update
    '-------------------------------------------------
    '往tbFeature里添加一条记录，即增加一个Region Feature
    Call AddFeatureToDB(REGION_LAYER, NewF.FeatureKey)
End Sub

Private Sub mnuDelete_Click()
    Dim f As MapXLib.Feature
    Dim fs As MapXLib.Features
    Dim Lyr As MapXLib.Layer
    Dim ret As VbMsgBoxResult
    
    On Error Resume Next
    If Map1.Layers.Count <= 0 Then
        Exit Sub
    End If
    '判断面层是否有选中的Feature
    Set Lyr = Map1.Layers.Item(REGION_LAYER)
    Set fs = Lyr.Selection
    For Each f In fs
        '1:从数据库中删除
        DeleteAllFromDB REGION_LAYER, f.FeatureKey
        '2:删除与之相关的标签
        DeleteText "A" & f.FeatureKey
        '3:再从region_layer中删除
        Lyr.DeleteFeature f.FeatureKey
    Next
    '从线层中删除
    Set Lyr = Map1.Layers.Item(LINE_LAYER)
    Set fs = Lyr.Selection
    For Each f In fs
        Lyr.DeleteFeature f.FeatureKey
    Next
End Sub
Private Sub mnuEditOptions_Click()
'    Dim frm As Form
'    Set frm = New frmEditOption
'    frm.SetMap = fMainForm.Map1
'    Load frm
'    ' The editing dialog allows the user to make layers editable, set the current
'    ' insertion layer, create new editable layers, etc.
'    frm.Show vbModal, Me
'    '-----------------------
'    Call UpdateToolbarButtons
End Sub
Private Sub mnuExit_Click()
    '关闭系统
    Unload fMainForm
End Sub
Private Sub mnuFeatureStyle_Click()
'    Dim frm As Form
'    Set frm = New frmPointStyle
'    Load frm
'    'Allows the user to pick a style for the current insertion layer.
'    frm.Show vbModal, Me
End Sub
Private Sub mnuFlush_Click()
    '刷新
    Dim f As MapXLib.Feature
    Dim fs As MapXLib.Features
    Dim Lyr As MapXLib.Layer
    
    On Error Resume Next
    For Each Lyr In Map1.Layers
        Set fs = Lyr.AllFeatures
        For Each f In fs
            If f.Type = miFeatureTypeSymbol Then
                Lyr.DeleteFeature f.FeatureKey
            End If
        Next
    Next
End Sub

Private Sub mnuFullMap_Click()
    '全视图
    Set Map1.Bounds = Map1.Layers.Bounds
    '-----------------------------------
    SHORTEST_DISTANCE = MAP_WIDTH / SHORTEST_TIME
End Sub

Private Sub mnuLayerControl_Click()
    Map1.Layers.LayersDlg
End Sub

Private Sub mnuLayerSet_Click()
    Dim fs As Features
    Dim f As MapXLib.Feature
    Dim txtLyrF As New MapXLib.Feature
    Dim rs As ADODB.Recordset
    Dim szSQL As String
    Dim frmM As frmMProperties
    Dim ct As Long
    
    On Error GoTo ErrHandler
        
    Set fs = Map1.Layers.Item(REGION_LAYER).Selection
    '---------
    ct = GetCountFromFeatures(fs)
    If ct <= 0 Then
        Exit Sub
    End If
    '对多个Feature
    Set frmM = New frmMProperties
    Load frmM
    frmM.Show vbModal, Me
    Screen.MousePointer = 11
    '----------------------
    If Not frmM.IsCanceled Then
        '1:修改数据库
        For Each f In fs
            szSQL = "UPDATE tbFeature " & _
                  "SET jc=" & CStr(frmM.BaseNumber) & _
                  ",cs=" & CStr(frmM.LayerNumber) & _
                  " WHERE tbName='" & REGION_LAYER & "' AND ftkey='" & f.FeatureKey & "'"
            MAP_CONN.Execute szSQL
        Next
        '2:显示标签
        txtLyrF.Attach Map1
        txtLyrF.Type = miFeatureTypeText
        txtLyrF.Point.Set Map1.CenterX, Map1.CenterY
        txtLyrF.Caption = CStr(frmM.BaseNumber) & "-" & CStr(frmM.BaseNumber + frmM.LayerNumber - 1) & "层"
        Map1.Layers.Item(LINE_LAYER).AddFeature txtLyrF
    End If
    Screen.MousePointer = 0
    Exit Sub
ErrHandler:
    Screen.MousePointer = 0
    Set rs = Nothing
    Set frmM = Nothing
    ErrMessageBox "mnuProperties_Click()", Me.Caption
End Sub

Private Sub mnuMaxRing_Click()
    mnuMaxRing.Checked = True
    
    CURRENT_LAYER = LINE_LAYER
    
    Map1.Layers.Item(LINE_LAYER).Selectable = False
    Map1.Layers.Item(REGION_LAYER).Editable = False
    Map1.Layers.Item(REGION_LAYER).Selectable = False
    Map1.CurrentTool = ctGenWallTool
End Sub

Private Sub mnuNew_Click()
    Dim Lyr As MapXLib.Layer
    Dim LyrName As String '图层名
    Dim FwZL As String '房屋座落
    Dim LyrLineName As String '线层名
    Dim tbFn As String '图层表文件名
    Dim tbFnLine As String '线层表文件名
    Dim szSQL As String
    Dim rs As ADODB.Recordset
    Dim frm As frmSetWidthHeight
    Dim LyrInfo As New MapXLib.LayerInfo
    Dim flds As New MapXLib.Fields
    Dim fs As Scripting.FileSystemObject
    
    On Error GoTo ErrHandler
    '设置边框及座落
    Set frm =