frmmain.frm

MapX5.02紧缩表等地图数据维护源码。

    If Map.Layers.Count = 0 Then
        MsgBox "当前地图中没有加载任何图层！"
        Exit Sub
    End If
    CommonDialog.CancelError = True
    CommonDialog.Filter = "*.gst|*.gst"
    CommonDialog.ShowSave
    sFilePath = CommonDialog.FileName
    If Trim(sFilePath) <> "" Then
        sFileName = clsPublic.GetFileNamefromPath(sFilePath)
        Map.SaveMapAsGeoset "", sFilePath
        StatusBar.Panels(1).Text = sFilePath
    End If
    
End Sub

Private Sub mnuPartsAdd_Click()
    Map.CurrentTool = miSelectTool
    Map.FeatureEditMode = miEditModeAddNode + miEditModeNode
    If Not clsPublic.g_bSnaped Then
        mnuViewNodeSnap_Click
    End If
    
    If Not m_bShowLayerNodes Then
        mnuViewShowNodes_Click
    End If
    Map.SnapToNodeSupport = True
    
End Sub

Private Sub mnuPartsEdit_Click()
    Map.CurrentTool = miSelectTool
    Map.FeatureEditMode = miEditModeNode
    If Not clsPublic.g_bSnaped Then
        mnuViewNodeSnap_Click
    End If
    
    If Not m_bShowLayerNodes Then
        mnuViewShowNodes_Click
    End If
    Map.SnapToNodeSupport = True
    
End Sub

Private Sub mnuSelectbyCircle_Click()
    Map.CurrentTool = miRadiusSelectTool
    Map.FeatureEditMode = miEditModeFeature
    If clsPublic.g_bSnaped Then
        Map.SnapToNodeSupport = True
    Else
        Map.SnapToNodeSupport = False
    End If
    
End Sub

Private Sub mnuSelectbyMaquee_Click()
    Map.CurrentTool = miRectSelectTool
    Map.FeatureEditMode = miEditModeFeature
    If clsPublic.g_bSnaped Then
        Map.SnapToNodeSupport = True
    Else
        Map.SnapToNodeSupport = False
    End If
    
End Sub

Private Sub mnuSelectbyPoint_Click()
    Map.CurrentTool = miSelectTool
'    If clsPublic.g_bSnaped Then
'        Map.SnapToNodeSupport = True
'    Else
'        Map.SnapToNodeSupport = False
'    End If
End Sub

Private Sub mnuSelectbyPolygon_Click()
    Map.CurrentTool = miPolygonSelectTool
    Map.FeatureEditMode = miEditModeFeature
    If clsPublic.g_bSnaped Then
        Map.SnapToNodeSupport = True
    Else
        Map.SnapToNodeSupport = False
    End If
    
End Sub

Private Sub mnuSelectI_Click()
    m_bIQuery = True
    mnuSelectI.Checked = Not mnuSelectI.Checked
    If mnuSelectI.Checked Then
        Toolbar.Buttons(11).value = tbrPressed
    Else
        Toolbar.Buttons(11).value = tbrUnpressed
    End If
    Map.CurrentTool = miSelectTool
    Map.FeatureEditMode = miEditModeFeature
    If clsPublic.g_bSnaped Then
        Map.SnapToNodeSupport = True
    Else
        Map.SnapToNodeSupport = False
    End If
End Sub

Private Sub mnuSelectLocateFeatures_Click()
    Set Map.Bounds = Map.Layers.Bounds
End Sub

Private Sub mnuSelectShowFeatures_Click()
    frmShowFeatures.Show 1, Me
End Sub

Private Sub mnuTablePacking_Click()
    If Map.Layers.Count > 0 Then
        frmPackOption.Show vbModal, Me
    Else
        MsgBox "当前地图中没有加载图层，无法执行该操作！"
    End If
End Sub

Private Sub mnuThemeLabel_Click()
Dim oLayer As MapXLib.Layer
Dim oDS As MapXLib.Dataset


End Sub

Private Sub mnuViewCoord_Click()
    Map.DisplayCoordSys.PickCoordSys
End Sub

Private Sub mnuViewCursorCoord_Click()
    clsPublic.g_bShowCursorCoord = Not clsPublic.g_bShowCursorCoord
    If clsPublic.g_bShowCursorCoord Then
        StatusBar.Panels.Add 2, "CoordPanel", ""
        If StatusBar.Panels.Count = 2 Then
            StatusBar.Panels(1).Width = StatusBar.Width * 0.6
            StatusBar.Panels(2).Width = StatusBar.Width * 0.4
        Else
            StatusBar.Panels(1).Width = StatusBar.Width * 0.4
            StatusBar.Panels(2).Width = StatusBar.Width * 0.4
            StatusBar.Panels(3).Width = StatusBar.Width * 0.2
        End If
    Else
        StatusBar.Panels.Remove 2
        If StatusBar.Panels.Count = 1 Then
            StatusBar.Panels(1).Width = StatusBar.Width
        Else
            StatusBar.Panels(1).Width = StatusBar.Width * 0.7
            StatusBar.Panels(2).Width = StatusBar.Width * 0.3
        End If
        
    End If
    mnuViewCursorCoord.Checked = clsPublic.g_bShowCursorCoord
    
End Sub

Private Sub mnuViewLayerCtrl_Click()
    Map.PropertyPage
End Sub

Private Sub mnuViewNodeSnap_Click()
    clsPublic.g_bSnaped = Not clsPublic.g_bSnaped
    Map.SnapTolerance = m_iSnapTolerance
    If clsPublic.g_bSnaped Then
        
        If StatusBar.Panels.Count = 1 Then
            StatusBar.Panels.Add 2, "InfoPanel", ""
            StatusBar.Panels(2).Text = "捕捉节点"
            StatusBar.Panels(1).Width = StatusBar.Width * 0.8
            StatusBar.Panels(2).Width = StatusBar.Width * 0.2
        Else
            StatusBar.Panels.Add 3, "InfoPanel", ""
            StatusBar.Panels(3).Text = "捕捉节点"
            StatusBar.Panels(1).Width = StatusBar.Width * 0.4
            StatusBar.Panels(2).Width = StatusBar.Width * 0.4
            StatusBar.Panels(3).Width = StatusBar.Width * 0.2
        End If
    Else
        If StatusBar.Panels.Count = 2 Then
            StatusBar.Panels.Remove 2
            StatusBar.Panels(1).Width = StatusBar.Width
        Else
            StatusBar.Panels.Remove 3
            StatusBar.Panels(1).Width = StatusBar.Width * 0.7
            StatusBar.Panels(2).Width = StatusBar.Width * 0.3
        End If
       
    End If
    
    mnuViewNodeSnap.Checked = clsPublic.g_bSnaped
End Sub

Private Sub mnuViewOption_Click()
    frmOptions.Show vbModal, Me
End Sub

Private Sub mnuViewPan_Click()
    Map.CurrentTool = miPanTool
End Sub

Private Sub mnuViewShowNodes_Click()
    m_bShowLayerNodes = Not m_bShowLayerNodes
    If m_bShowLayerNodes Then
        If Trim(m_sEditLayerName) <> "" Then
            Map.Layers(Trim(m_sEditLayerName)).ShowNodes = True
        End If
    Else
        If Trim(m_sEditLayerName) <> "" Then
            Map.Layers(Trim(m_sEditLayerName)).ShowNodes = False
        End If
    End If
    mnuViewShowNodes.Checked = m_bShowLayerNodes
    
End Sub

Private Sub mnuViewZoomIn_Click()
    Map.CurrentTool = miZoomInTool
End Sub

Private Sub mnuViewZoomOut_Click()
    Map.CurrentTool = miZoomOutTool
End Sub

Private Sub RefreshcbLayers(ByRef combobox As combobox, ByVal Map As MapXLib.Map, ByVal sLayerName As String)
On Error Resume Next
Dim i As Integer
Dim iSelected As Integer
    combobox.Clear
    
    iSelected = 0
    For i = 1 To Map.Layers.Count
        combobox.AddItem Map.Layers(i)
        If StrComp(sLayerName, Map.Layers(i).Name, vbTextCompare) = 0 Then
            iSelected = i - 1
            
        End If
        Map.Layers(i).Editable = False
    Next i
    If combobox.ListCount <> 0 Then
        combobox.ListIndex = iSelected
        Set Map.Layers.InsertionLayer = Map.Layers(iSelected + 1)
        Map.Layers(iSelected + 1).Editable = True
    End If
    
End Sub

Private Sub mnuZoomtoLayer_Click()
    If Map.Layers.Count > 0 Then
        frmSelectLayer.Show vbModal, frmMain
        If m_sLayerName <> "" Then
            If m_sLayerName = "所有图层" Then
                Set Map.Bounds = Map.Layers.Bounds
            Else
                Set Map.Bounds = Map.Layers(m_sLayerName).Bounds
            End If
        End If
    End If

End Sub

Private Sub OpenTxtFile(ByVal sFileName As String)
    Dim sWinDir As String
    Dim sHelpFilePath As String
    Const MAX_PATH = 260
    
    On Error Resume Next
    
    '构造帮助文件的全路径名
    If Right(App.Path, 1) = "\" Then
        sHelpFilePath = App.Path & sFileName
    Else
        sHelpFilePath = App.Path & "\" & sFileName
    End If
    
    '如果找到了帮助文件
    If Dir(sHelpFilePath) <> "" Then
        '获得Windows操作系统的安装路径
        sWinDir = Space(MAX_PATH)
        GetWindowsDirectory sWinDir, MAX_PATH
        sWinDir = Trim(sWinDir)
        '调用记事本显示帮助文件
        Shell Left(sWinDir, Len(sWinDir) - 1) & "\notepad.exe '" & _
                sHelpFilePath & "'", vbNormalFocus
    End If

End Sub

Private Sub RotateFeaturebyAngle(ByRef oFtr As MapXLib.Feature, ByVal dblCenterX As Double, ByVal dblCenterY As Double, ByVal dblRotate As Double)
On Error Resume Next

Dim oPnt As MapXLib.Point
Dim oPnts As MapXLib.Points
Dim iCenterX As Double
Dim iCenterY As Double
    
'    iCenterX = oFtr.CenterX
'    iCenterY = oFtr.CenterY
    iCenterX = dblCenterX
    iCenterY = dblCenterY

    
    For Each oPnts In oFtr.Parts
        For Each oPnt In oPnts
            Select Case dblRotate
            
                Case 90
                    oPnt.Set iCenterX + oPnt.Y - iCenterY, iCenterY + iCenterX - oPnt.X
                Case 180
                    oPnt.Set iCenterX - (oPnt.X - iCenterX), iCenterY - (oPnt.Y - iCenterY)
                Case 270
                    oPnt.Set iCenterX - (oPnt.Y - iCenterY), iCenterY + (oPnt.X - iCenterX)
            End Select
        Next oPnt
    Next oPnts

End Sub

Private Sub RotateFeaturebyLine(ByRef oFtr As MapXLib.Feature, ByVal dblCenterX As Double, ByVal dblCenterY As Double, ByVal dblMapX As Double, ByVal dblMapY As Double)
On Error Resume Next

Dim oPnt As MapXLib.Point
Dim oPnts As MapXLib.Points
Dim dblX As Double
Dim dblY As Double
Dim l1 As Double
Dim l2 As Double
Dim l3 As Double
    
    For Each oPnts In oFtr.Parts
        For Each oPnt In oPnts
            l1 = Abs(Sqr((oPnt.X - dblCenterX) * (oPnt.X - dblCenterX) + (oPnt.Y - dblCenterY) * (oPnt.Y - dblCenterY)))
            l2 = Abs(Sqr((dblMapX - dblCenterX) * (dblMapX - dblCenterX) + (dblMapY - dblCenterY) * (dblMapY - dblCenterY)))
            dblX = dblCenterX + (((oPnt.X - dblCenterX) * (dblMapY - dblCenterY) + (oPnt.Y - dblCenterY) * (dblMapX - dblCenterX)) / l2)
            dblY = dblCenterY + (((oPnt.Y - dblCenterY) * (dblMapY - dblCenterY) - (oPnt.X - dblCenterX) * (dblMapX - dblCenterX)) / l2)
            oPnt.Set dblX, dblY
        Next oPnt
    Next oPnts

End Sub


Private Sub Toolbar_ButtonClick(ByVal Button As MSComctlLib.Button)
    
    mnuSelectI.Checked = False
    Select Case Button.Index
        Case 1
            mnuFileAddTAB_Click
        Case 2
            mnuFileOpenGST_Click
        Case 3
            mnuFileSaveas_Click
        Case 5
            mnuViewPan_Click
        Case 6
            mnuViewZoomIn_Click
        Case 7
            mnuViewZoomOut_Click
        Case 8
            mnuZoomtoLayer_Click
        Case 9
            mnuViewLayerCtrl_Click
        Case 11
            mnuSelectI_Click
        Case 12
            mnuSelectbyPoint_Click
        Case 13
            mnuSelectbyMaquee_Click
        Case 14
            mnuSelectbyCircle_Click
        Case 15
            mnuSelectbyPolygon_Click
    End Select
    
End Sub