frmmain.frm

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

      Begin VB.Menu mnuSelectShowFeatures 
         Caption         =   "显示选择集"
      End
      Begin VB.Menu mnuSelectLocateFeatures 
         Caption         =   "缩放到选择集"
      End
   End
   Begin VB.Menu mnuEdit 
      Caption         =   "对象编辑(&E)"
      Begin VB.Menu mnuEditCopy 
         Caption         =   "复制(&C)"
         Shortcut        =   ^C
      End
      Begin VB.Menu mnuEditCut 
         Caption         =   "剪切(&X)"
         Shortcut        =   ^T
      End
      Begin VB.Menu mnuEditPaste 
         Caption         =   "拷贝(&P)"
         Shortcut        =   ^V
      End
      Begin VB.Menu mnuEditSep1 
         Caption         =   "—————————"
      End
      Begin VB.Menu mnuEditConsociate 
         Caption         =   "合并图元"
      End
      Begin VB.Menu mnuEditSplit 
         Caption         =   "拆分"
         Visible         =   0   'False
      End
      Begin VB.Menu mnuEditSep2 
         Caption         =   "—————————"
      End
      Begin VB.Menu mnuEditMove 
         Caption         =   "平移"
      End
      Begin VB.Menu mnuEditRotate 
         Caption         =   "旋转"
         Begin VB.Menu mnuEditRotate90 
            Caption         =   "旋转90度"
         End
         Begin VB.Menu mnuEditRotate180 
            Caption         =   "旋转180度"
         End
         Begin VB.Menu mnuEditRotate270 
            Caption         =   "旋转270度"
         End
         Begin VB.Menu mnuEditRotateAny 
            Caption         =   "任意旋转"
         End
      End
   End
   Begin VB.Menu mnuParts 
      Caption         =   "节点编辑(&P)"
      Begin VB.Menu mnuPartsAdd 
         Caption         =   "添加"
      End
      Begin VB.Menu mnuPartsEdit 
         Caption         =   "编辑"
      End
   End
   Begin VB.Menu mnuTable 
      Caption         =   "表维护(&M)"
      Begin VB.Menu mnuTablePacking 
         Caption         =   "表紧缩"
      End
   End
   Begin VB.Menu mnuTheme 
      Caption         =   "专题图(&T)"
      Visible         =   0   'False
      Begin VB.Menu mnuThemeLabel 
         Caption         =   "标注专题"
      End
   End
   Begin VB.Menu mnuAbout 
      Caption         =   "关于(&A)"
      Begin VB.Menu mnuAboutMapXNew 
         Caption         =   "MapX5新功能"
      End
      Begin VB.Menu mnuAboutReadme 
         Caption         =   "关于Demo"
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'********************************************************************************
'File Name   ：frmMain.frm
'Description ：MapX5 Demo main form
'Author      ：James Liu
'Copyright   ：MapInfo China
'Create Date ：2002年9月11日
'********************************************************************************

Private clsPublic As New clsPublic
Private m_sEditLayerName As String
Private m_bShowLayerNodes As Boolean
Private m_bIQuery As Boolean
Private m_oExchangeFtrs As MapXLib.Features
Private m_sCutLayerName As String
Private m_iPrevX As Single
Private m_iPrevY As Single
Private m_iCurTool As Integer
Private m_iPrevToolnum As Integer

Public m_sLayerName As String
Public m_sServerName As String
Public m_sUserName As String
Public m_sPwd As String
Public m_sSQL As String
Public m_sFilePath As String
Public m_iAddTempLayer As Integer
Public m_iSnapTolerance As Integer

Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long


Private Sub cbLayers_Click()
On Error Resume Next
    m_sEditLayerName = cbLayers.List(cbLayers.ListIndex)
    
    If m_bShowLayerNodes Then
        Map.Layers(m_sEditLayerName).ShowNodes = True
    End If
    
'    RefreshcbLayers cbLayers, Map, m_sEditLayerName
    Set Map.Layers.InsertionLayer = Map.Layers(m_sEditLayerName)
End Sub

Private Sub Form_Load()

    m_iSnapTolerance = 5
    m_bIQuery = False
    
    StatusBar.Panels(1).Width = StatusBar.Width
    StatusBar.Panels(1).Text = "没有装载地图"
    Map.Left = 0
    Map.Width = frmMain.Width
    Map.Height = frmMain.Height - StatusBar.Height - Toolbar.Height
    Map.Top = Toolbar.Top + Toolbar.Height
    cbLayers.Left = Toolbar.Buttons(Toolbar.Buttons.Count - 1).Left + Toolbar.Buttons(Toolbar.Buttons.Count - 1).Width + Toolbar.ButtonWidth
    cbLayers.Top = Toolbar.Top + (Toolbar.Height - cbLayers.Height) / 2 + 15
    
    Map.CreateCustomTool 199, miToolTypePoint, 2
    
End Sub

Private Sub Form_Resize()
On Error Resume Next
    Map.Left = 0
    Map.Width = frmMain.Width
    Map.Height = frmMain.Height - StatusBar.Height - Toolbar.Height
    Map.Top = Toolbar.Top + Toolbar.Height
    cbLayers.Left = Toolbar.Buttons(Toolbar.Buttons.Count - 1).Left + Toolbar.Buttons(Toolbar.Buttons.Count - 1).Width + Toolbar.ButtonWidth
    cbLayers.Top = Toolbar.Top + (Toolbar.Height - cbLayers.Height) / 2 + 15
End Sub

Private Sub Map_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
Dim oLayer As MapXLib.Layer
Dim oFtr As MapXLib.Feature
Dim oFtrs As MapXLib.Features
Dim oPnt As MapXLib.Point
Dim oPnts As MapXLib.Points
Dim i As Integer
Dim dblMapX As Double, dblMapY As Double
Dim dblCenterX As Double, dblCenterY As Double


    If m_iCurTool = 200 Then
        m_iCurTool = 0
        
        '左键保存旋转对象，右键放弃编辑
        If Button = vbLeftButton Then
        
            Set oLayer = Map.Layers("RotateTempLayer")
            Set oFtr = oLayer.AllFeatures(1)
            Set oPnt = oFtr.Point
            dblCenterX = oPnt.X
            dblCenterY = oPnt.Y
            Map.ConvertCoord X, Y, dblMapX, dblMapY, miScreenToMap
            
            Set oLayer = Map.Layers(Trim(cbLayers.Text))
            Set oFtrs = oLayer.Selection
            
            For Each oFtr In oFtrs
                RotateFeaturebyLine oFtr, dblCenterX, dblCenterY, dblMapX, dblMapY
                oLayer.UpdateFeature oFtr
            Next oFtr
        
        End If
        
        Map.Layers.Remove "RotateTempLayer"
        Map.Layers.Remove "RotateFeaturesLayer"
    End If

End Sub

Private Sub Map_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'On Error Resume Next
Dim sTemp As String
Dim oLayer As MapXLib.Layer
Dim oTempLayer As MapXLib.Layer
Dim oFtr As MapXLib.Feature
Dim oFtrs As MapXLib.Features
Dim oPnt As MapXLib.Point
Dim oPnts As MapXLib.Points
Dim i As Integer, j As Integer
Dim dblMapX As Double, dblMapY As Double
Dim dblCenterX As Double, dblCenterY As Double

    If clsPublic.g_bShowCursorCoord Then
        Map.ConvertCoord X, Y, dblMapX, dblMapY, miScreenToMap
        sTemp = "X坐标：" & dblMapX & "    Y坐标：" & dblMapY
        StatusBar.Panels(2).Text = sTemp
    End If
    
    If m_iCurTool = 200 Then
        Set oLayer = Map.Layers("RotateTempLayer")
        Set oFtr = oLayer.AllFeatures(1)
        Set oPnt = oFtr.Point
        dblCenterX = oPnt.X
        dblCenterY = oPnt.Y
        Set oPnts = New MapXLib.Points
        oPnts.Add oPnt
        Map.ConvertCoord X, Y, dblMapX, dblMapY, miScreenToMap
        oPnts.AddXY dblMapX, dblMapY
        Set oFtr = Map.FeatureFactory.CreateLine(oPnts, Map.DefaultStyle)
        oFtr.Style.LineColor = vbRed
        oFtr.Style.LineStyle = 9
        oFtr.Style.LineWidth = 2
        If oLayer.AllFeatures.Count > 2 Then
            For i = 3 To oLayer.AllFeatures.Count
                oLayer.DeleteFeature oLayer.AllFeatures(i)
            Next i
        End If
        oLayer.AddFeature oFtr
        
        Set oTempLayer = Map.Layers("RotateFeaturesLayer")
        For j = 1 To oTempLayer.AllFeatures.Count
            oTempLayer.DeleteFeature oTempLayer.AllFeatures(j)
        Next j
        
        Set oLayer = Map.Layers(Trim(cbLayers.Text))
        Set oFtrs = oLayer.Selection
        
        For Each oFtr In oFtrs
            RotateFeaturebyLine oFtr, dblCenterX, dblCenterY, dblMapX, dblMapY
'            oLayer.UpdateFeature oFtr
            oTempLayer.AddFeature oFtr
        Next oFtr
        
        Map.Refresh
        
    End If
    
    
End Sub

Private Sub Map_SelectionChanged()
    If m_bIQuery And Toolbar.Buttons(11).value = tbrPressed Then
'        MsgBox Map.Layers(cbLayers.Text).Selection(1).Name
        Load frmProperty
        frmProperty.InitData m_sEditLayerName
    End If

End Sub

Private Sub Map_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)
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 ToolNum = 199 Then
        m_iCurTool = 200
        Set oFtrs = oLayer.Selection
        
        Set oTempLayer = Map.Layers.CreateLayer("RotateFeaturesLayer", , 1)
        
        iCenterX = X1
        iCenterY = Y1
        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
        
        Map.CurrentTool = miSelectTool
    
    End If
End Sub

Private Sub mnuAboutMapXNew_Click()
'    frmTest.Show 1
    OpenTxtFile "MapX5NewFeature.txt"

End Sub

Private Sub mnuAboutReadme_Click()
    OpenTxtFile "Readme.txt"

End Sub

Private Sub mnuabouttest_Click()
'    MsgBox m_sEditLayerName
'    map.FeatureEditMode =
    frmNewLayer.Show vbModal, Me
End Sub

Private Sub mnuEditConsociate_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
    
    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
    
    Set oFtr = Map.FeatureFactory.CombineFeatures(oFtrs)
    oLayer.AddFeature oFtr
    For Each oFtr In oFtrs
        oLayer.DeleteFeature oFtr
    Next oFtr
    
End Sub

Private Sub mnuEditCopy_Click()
On Error Resume Next

Dim oLayer As MapXLib.Layer
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
'    For Each oFtr In oLayer.Selection
'        m_oExchangeFtrs.Add oFtr
'    Next oFtr
    
    m_sCutLayerName = ""
    If oLayer.Selection.Count = 1 Then
        StatusBar.Panels(1).Text = "one feature is copying..."
    Else
        StatusBar.Panels(1).Text = oLayer.Selection.Count & " features are copying..."
    End If
    StatusBar.Refresh
    
End Sub