frmmain.frm

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

Private Sub mnuEditCut_Click()
On Error Resume Next

Dim oLayer As MapXLib.Layer
Dim oDS As MapXLib.Dataset
Dim oFtr As MapXLib.Feature

    If Trim(cbLayers.Text) = "" Then Exit Sub
    Set oLayer = Map.Layers(Trim(cbLayers.Text))
    
    If oLayer.Selection.Count = 0 Then Exit Sub
    
    Set m_oExchangeFtrs = oLayer.Selection
    m_sCutLayerName = oLayer.Name
    
    If oLayer.Selection.Count = 1 Then
        StatusBar.Panels(1).Text = "one feature is cut..."
    Else
        StatusBar.Panels(1).Text = oLayer.Selection.Count & " features are cut..."
    End If
    StatusBar.Refresh
    
    Map.Refresh
    
    
End Sub

Private Sub mnuEditMove_Click()
    Map.CurrentTool = miSelectTool
    Map.FeatureEditMode = miEditModeFeature
    
End Sub

Private Sub mnuEditPaste_Click()
On Error Resume Next

Dim oLayer As MapXLib.Layer
Dim oDS As MapXLib.Dataset
Dim oFtr As MapXLib.Feature
Dim oTempLayer  As MapXLib.Layer
Dim iFtrCount As Integer

    If Trim(cbLayers.Text) = "" Then Exit Sub
    Set oLayer = Map.Layers(Trim(cbLayers.Text))
    
'    If m_oExchangeFtrs.Count = 0 Then Exit Sub
    iFtrCount = 0
    For Each oFtr In m_oExchangeFtrs
        iFtrCount = iFtrCount + 1
    Next oFtr
    
    If iFtrCount = 0 Then Exit Sub
    
    For Each oFtr In m_oExchangeFtrs
        oLayer.AddFeature oFtr
    Next oFtr
    oLayer.Selection.Replace m_oExchangeFtrs
    
    '删除剪切要素
    If m_sCutLayerName <> "" Then
        Set oTempLayer = Map.Layers(m_sCutLayerName)
        For Each oFtr In m_oExchangeFtrs
            oTempLayer.DeleteFeature oFtr
        Next oFtr
    
    End If
    
    If iFtrCount = 1 Then
        StatusBar.Panels(1).Text = "one feature is copyed..."
    Else
        StatusBar.Panels(1).Text = iFtrCount & " features are copyed..."
    End If
    StatusBar.Refresh
    
    Set m_oExchangeFtrs = oLayer.Selection
    
    Map.Refresh


End Sub

Private Sub mnuEditRotate180_Click()
On Error Resume Next

Dim oLayer As MapXLib.Layer
Dim oDS As MapXLib.Dataset
Dim oFtr As MapXLib.Feature
Dim oFtrs As MapXLib.Features
Dim oPnt As MapXLib.Point
Dim oPnts As MapXLib.Points
Dim iCenterX As Double
Dim iCenterY As Double
    
    If Trim(cbLayers.Text) = "" Then Exit Sub
    Set oLayer = Map.Layers(Trim(cbLayers.Text))
    
    If oLayer.Selection.Count = 0 Then Exit Sub
    Set oFtrs = oLayer.Selection
    iCenterX = (oLayer.Selection.Bounds.XMin + oLayer.Selection.Bounds.XMax) / 2
    iCenterY = (oLayer.Selection.Bounds.YMin + oLayer.Selection.Bounds.YMax) / 2
    For Each oFtr In oFtrs
        RotateFeaturebyAngle oFtr, iCenterX, iCenterY, 180
        oLayer.UpdateFeature oFtr
    Next oFtr
    
    Map.Refresh

End Sub

Private Sub mnuEditRotate270_Click()
On Error Resume Next

Dim oLayer As MapXLib.Layer
Dim oDS As MapXLib.Dataset
Dim oFtr As MapXLib.Feature
Dim oFtrs As MapXLib.Features
Dim oPnt As MapXLib.Point
Dim oPnts As MapXLib.Points
Dim iCenterX As Double
Dim iCenterY As Double
    
    If Trim(cbLayers.Text) = "" Then Exit Sub
    Set oLayer = Map.Layers(Trim(cbLayers.Text))
    
    If oLayer.Selection.Count = 0 Then Exit Sub
    Set oFtrs = oLayer.Selection
    iCenterX = (oLayer.Selection.Bounds.XMin + oLayer.Selection.Bounds.XMax) / 2
    iCenterY = (oLayer.Selection.Bounds.YMin + oLayer.Selection.Bounds.YMax) / 2
    
    For Each oFtr In oFtrs
        RotateFeaturebyAngle oFtr, iCenterX, iCenterY, 270
        oLayer.UpdateFeature oFtr
    Next oFtr
    
    Map.Refresh

End Sub

Private Sub mnuEditRotate90_Click()
On Error Resume Next

Dim oLayer As MapXLib.Layer
Dim oDS As MapXLib.Dataset
Dim oFtr As MapXLib.Feature
Dim oFtrs As MapXLib.Features
Dim oPnt As MapXLib.Point
Dim oPnts As MapXLib.Points
Dim iCenterX As Double
Dim iCenterY As Double
    
    If Trim(cbLayers.Text) = "" Then Exit Sub
    Set oLayer = Map.Layers(Trim(cbLayers.Text))
    
    If oLayer.Selection.Count = 0 Then Exit Sub
    Set oFtrs = oLayer.Selection
    iCenterX = (oLayer.Selection.Bounds.XMin + oLayer.Selection.Bounds.XMax) / 2
    iCenterY = (oLayer.Selection.Bounds.YMin + oLayer.Selection.Bounds.YMax) / 2
    For Each oFtr In oFtrs
        RotateFeaturebyAngle oFtr, iCenterX, iCenterY, 90
        oLayer.UpdateFeature oFtr
    Next oFtr
    
    Map.Refresh
    
End Sub

Private Sub mnuEditRotateAny_Click()
On Error Resume Next
Dim oLayer As MapXLib.Layer
Dim oDS As MapXLib.Dataset
Dim oFtr As MapXLib.Feature
Dim oFtrs As MapXLib.Features
Dim oPnt As MapXLib.Point
Dim oPnts As MapXLib.Points
Dim iCenterX As Double
Dim iCenterY As Double
Dim oTempLayer As MapXLib.Layer
    
    If Trim(cbLayers.Text) = "" Then Exit Sub
    Set oLayer = Map.Layers(Trim(cbLayers.Text))
    
    If oLayer.Selection.Count = 0 Then Exit Sub
    m_iPrevTool = Map.CurrentTool
    
    If MsgBox("自己指定旋转锚点？否则默认将选中要素的质心作为锚点", vbYesNo, "选择锚点") = vbYes Then
        Map.CurrentTool = 199
    Else
        m_iCurTool = 200
        Set oFtrs = oLayer.Selection
        
        Set oTempLayer = Map.Layers.CreateLayer("RotateFeaturesLayer", , 1)
        
        iCenterX = (oLayer.Selection.Bounds.XMin + oLayer.Selection.Bounds.XMax) / 2
        iCenterY = (oLayer.Selection.Bounds.YMin + oLayer.Selection.Bounds.YMax) / 2
        Set oTempLayer = Map.Layers.CreateLayer("RotateTempLayer", , 1)
        Set oPnt = New MapXLib.Point
        oPnt.Set iCenterX, iCenterY
        Set oFtr = Map.FeatureFactory.CreateSymbol(oPnt, Map.DefaultStyle)
        oTempLayer.AddFeature oFtr
        
        Set oPnts = New MapXLib.Points
        oPnts.Add oPnt
        oPnts.AddXY oPnt.X, Map.Bounds.YMax
        Set oFtr = Map.FeatureFactory.CreateLine(oPnts, Map.DefaultStyle)
        oFtr.Style.LineColor = vbBlue
        oFtr.Style.LineStyle = 2
        oFtr.Style.LineWidth = 2
        oTempLayer.AddFeature oFtr
    End If
        

End Sub

Private Sub mnuFileAddOracleTAB_Click()
On Error Resume Next

Dim oLayerInfo As MapXLib.LayerInfo
Dim sLayerName As String
    
    frmOpenOracleLayer.Show vbModal, Me
    If m_sServerName <> "" Then
        Set oLayerInfo = New MapXLib.LayerInfo
        sLayerName = clsPublic.GetUniqueLayerNamebySQL(Map, m_sSQL)
        oLayerInfo.Type = miLayerInfoTypeServer
        oLayerInfo.AddParameter "Name", sLayerName
        oLayerInfo.AddParameter "ConnectString", "SRVR=" & m_sServerName & ";UID=" & m_sUserName & ";PWD=" & m_sPwd
        oLayerInfo.AddParameter "Query", m_sSQL
'        oLayerInfo.AddParameter "Query", ""
        oLayerInfo.AddParameter "toolkit", "ORAINET"
        oLayerInfo.AddParameter "Cache", "OFF"
        oLayerInfo.AddParameter "MBRSearch", "OFF"
        oLayerInfo.AddParameter "AutoCreateDataset", 1
        oLayerInfo.AddParameter "DatasetName", sLayerName
        
        Map.Layers.Add oLayerInfo
'        m_sEditLayerName = sLayerName
        RefreshcbLayers cbLayers, Map, m_sEditLayerName
        StatusBar.Panels(1).Text = m_sSQL
        StatusBar.Refresh
        
        Set oLayerInfo = Nothing
    End If
    
End Sub

Private Sub mnuFileAddTAB_Click()
On Error Resume Next

Dim sFilePath As String
Dim sLayerName As String
Dim oLayerInfo As MapXLib.LayerInfo
    
    CommonDialog.CancelError = True
    CommonDialog.Filter = "*.tab|*.tab"
    CommonDialog.ShowOpen
    sFilePath = CommonDialog.FileName
    
    If Trim(sFilePath) <> "" Then
        sLayerName = clsPublic.GetUniqueLayerName(Map, sFilePath)
        Set oLayerInfo = New MapXLib.LayerInfo
        oLayerInfo.Type = miLayerInfoTypeTab
        oLayerInfo.AddParameter "name", sLayerName
        oLayerInfo.AddParameter "FileSpec", sFilePath
        Map.Layers.Add oLayerInfo
'        m_sEditLayerName = sLayerName
        StatusBar.Panels(1).Text = sFilePath
        StatusBar.Refresh
        RefreshcbLayers cbLayers, Map, m_sEditLayerName
    End If
    

End Sub

Private Sub mnuFileCloseLayer_Click()
    If Map.Layers.Count > 0 Then
        frmSelectLayer.Show vbModal, frmMain
        If m_sLayerName <> "" Then
            If m_sLayerName = "所有图层" Then
                Map.Layers.RemoveAll
                StatusBar.Panels(1).Text = "没有装载地图"
                m_sEditLayerName = ""
                RefreshcbLayers cbLayers, Map, m_sEditLayerName
            Else
                Map.Layers.Remove m_sLayerName
                StatusBar.Panels(1).Text = "已关闭" & m_sLayerName
                If StrComp(m_sLayerName, m_sEditLayerName, vbTextCompare) = 0 Then
                    m_sEditLayerName = ""
                    RefreshcbLayers cbLayers, Map, m_sEditLayerName
                Else
                    RefreshcbLayers cbLayers, Map, m_sEditLayerName
                End If
            End If
        End If
    End If
End Sub

Private Sub mnuFileExit_Click()
    Unload Me
End Sub

Private Sub mnuFileNewTAB_Click()
On Error Resume Next

Dim sFilePath As String
Dim sLayerName As String
Dim oLayer As MapXLib.Layer
Dim oLayerInfo As MapXLib.LayerInfo

    frmNewLayer.Show vbModal, Me

    If m_sLayerName = "" Then Exit Sub
    
    Set oLayerInfo = New MapXLib.LayerInfo
    
    sLayerName = clsPublic.GetUniqueLayerNamebyStr(Map, m_sLayerName)
    
    If m_sFilePath <> "" And m_iAddTempLayer = 0 Then
        sFilePath = Trim(m_sFilePath & "\" & Trim(m_sLayerName) & ".tab")
'        oLayerInfo.Type = miLayerInfoTypeNewTable
'        oLayerInfo.AddParameter "FileSpec", sFilePath
'        oLayerInfo.AddParameter "Name", sLayerName
'        oLayerInfo.AddParameter "OverwriteFile", "1"
'        Set oLayer = Map.Layers.Add(oLayerInfo, 1)
        Set oLayer = Map.Layers.CreateLayer(sLayerName, sFilePath, 1)
    Else
        Set oLayer = Map.Layers.CreateLayer(sLayerName, , 1)
    End If
    
    m_sEditLayerName = sLayerName
    RefreshcbLayers cbLayers, Map, m_sEditLayerName
    
    Set oLayerInfo = Nothing

End Sub

Private Sub mnuFileOpenGST_Click()
On Error GoTo ErrorReturn

Dim sFilePath As String

    CommonDialog.CancelError = True
    CommonDialog.Filter = "*.gst|*.gst"
    CommonDialog.ShowOpen
    sFilePath = CommonDialog.FileName
    If Trim(sFilePath) <> "" Then
        Map.Layers.RemoveAll
        Map.Layers.AddGeoSetLayers sFilePath
        StatusBar.Panels(1).Text = sFilePath
        RefreshcbLayers cbLayers, Map, ""
        m_sEditLayerName = Map.Layers(1).Name
        StatusBar.Panels(1).Text = sFilePath
        StatusBar.Refresh
    End If
    
ErrorReturn:

End Sub

Private Sub mnuFileSaveas_Click()
On Error Resume Next
    
    If Map.Layers.Count <> 0 Then
        frmSaveLayer.Show vbModal, Me
    Else
        MsgBox "没有加载任何图层！"
    End If

End Sub

Private Sub mnuFileSaveGST_Click()
On Error Resume Next

Dim sFilePath As String
Dim sFileName As String