mapbrower.frm

MapX控件与VB的二次开发。主要功能由TAB文件的新建

'    For i = Forms.Count - 1 To 1 Step -1
'        Unload Forms(i)
'    Next
'    If Me.WindowState = vbNormal Then
'        SaveSetting App.Title, "Settings", "MainLeft", Me.Left
'        SaveSetting App.Title, "Settings", "MainTop", Me.Top
'        SaveSetting App.Title, "Settings", "MainWidth", Me.Width
'        SaveSetting App.Title, "Settings", "MainHeight", Me.Height
'    End If
'
'    ' Save the current settings to restore for the
'    ' next time the application is run
'    SaveSetting App.Title, "Settings", "WindowState", Me.WindowState
'    SaveSetting App.Title, "Settings", "ToolbarVisibility", tbToolBar.Visible
'    SaveSetting App.Title, "Settings", "StatusBarVisibility", sbStatusBar.Visible
'    SaveSetting App.Title, "Settings", "MapToolsVisibility", Toolbar1.Visible
'    SaveSetting App.Title, "Settings", "PolyRuler", UsePolyRuler
'    SaveSetting App.Title, "Settings", "ExportFormat", ExportFormat
'    SaveSetting App.Title, "Settings", "ExportFormatString", ExportFormatString
'    SaveSetting App.Title, "Settings", "ExportFormatExt", ExportFormatExt
'    SaveSetting App.Title, "Settings", "RulerUnit", RulerUnit
'    SaveSetting App.Title, "Settings", "RulerUnitString", RulerUnitString
'    SaveSetting App.Title, "Settings", "ExportWidth", ExportWidth
'    SaveSetting App.Title, "Settings", "ExportHeight", ExportHeight
'End Sub

Private Sub calculatedistance_Click(Index As Integer)
    If UsePolyRuler = True Then
        Map1.CurrentTool = PolyRulerTool
    Else
        Map1.CurrentTool = RulerTool
    End If
End Sub

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 And Map1.CurrentTool = RulerTool Then
        ' Place the current screen coordinates in MouseDownX1 and MouseDownY1
        ' Since these points will be used in the Map.Distance call, they
        ' must be in map coordinates, not screen coordinates
        Map1.ConvertCoord X, Y, MouseDownX1, MouseDownY1, miScreenToMap
    End If
End Sub

Private Sub Map1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 And Map1.CurrentTool = RulerTool Then
        Dim X2 As Double
        Dim Y2 As Double

        ' RulerUnit is the unit selected in the options dialog (default Miles)
        ' RulerUnitString is its name. Here, we make sure this is the current map unit.
        Map1.MapUnit = RulerUnit

        ' Convert from Screen Coordinates to Map Coordinates
        Map1.ConvertCoord X, Y, X2, Y2, miScreenToMap
'        sbStatusBar.SimpleText = Map1.Distance(MouseDownX1, MouseDownY1, X2, Y2) & " " & RulerUnitString
    End If
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)
    If ToolNum = PolyRulerTool Then
        Dim i As Integer
        Dim DistanceSoFar As Double

        ' RulerUnit is the unit selected in the options dialog (default Miles)
        ' RulerUnitString is its name. Here, we make sure this is the current map unit.
        Map1.MapUnit = RulerUnit
        DistanceSoFar = 0#

        ' Find the total distance by adding up each of the line segment distances
        If Points.Count > 1 Then
            For i = 2 To Points.Count
                DistanceSoFar = DistanceSoFar + Map1.Distance(Points.Item(i).X, Points.Item(i).Y, Points.Item(i - 1).X, Points.Item(i - 1).Y)
            Next
        End If

        ' Now, we have the total distance along the polyline
        ' If the user is done with the poly-ruler tool, show this distance
        ' in a message box. Otherwise, just show it in the status bar.
        If Flags = miPolyToolEnd Then
'            'First, clear the status bar
'            sbStatusBar.SimpleText = ""
            MsgBox "Distance: " & DistanceSoFar & " " & RulerUnitString
'        Else
'            sbStatusBar.SimpleText = DistanceSoFar & " " & RulerUnitString
        End If
    End If
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)
    If ToolNum = RulerTool Then
        ' The two-point ruler tool has been used.  This tool displays
        ' the distance in the status bar as the mouse is moved, and
        ' displays the distance in a message box as when the mouse is
        ' released.  See Map1_MouseDown and Map1_MouseMove for the rest
        ' of the implementation.

        ' RulerUnit is the unit selected in the options dialog (default Miles)
        ' RulerUnitString is its name. Here, we make sure this is the current map unit.
        Map1.MapUnit = RulerUnit

        ' Clear the status bar and display the distance in a message box
'        sbStatusBar.SimpleText = ""
        MsgBox "Distance: " & Map1.Distance(X1, Y1, X2, Y2) & " " & RulerUnitString
    End If
End Sub




'
'Private Sub copy_Click(Index As Integer)
'    ' Copy a bitmap picture of the map to the clipboard
'    Map1.ExportMap "clipboard", miFormatBMP
'End Sub

Private Sub Form_Load()
On Error GoTo ErrHandling
    ' Create a new temporary layer and set _it_ to the insertion layer.
    Dim newLayer As Layer
    Dim LayerInfoObject As New LayerInfo
    Dim fields As New fields

    fields.AddStringField "GeoName", 10

    LayerInfoObject.Type = miLayerInfoTypeTemp
    LayerInfoObject.AddParameter "Name", "Temporary Layer"
    LayerInfoObject.AddParameter "Fields", fields

    Set newLayer = Map1.Layers.Add(LayerInfoObject, 1)

    newLayer.Editable = True
    Set Map1.Layers.InsertionLayer = newLayer
    
    
    Map1.CreateCustomTool RulerTool, miToolTypeLine, miSizeAllCursor
    Map1.CreateCustomTool PolyRulerTool, miToolTypePoly, miSizeAllCursor
    
      Map1.PaperUnit = miPaperUnitInch
    
'    Updateedit_Click
    Exit Sub
ErrHandling:
    MsgBox Err.Description
End Sub

Private Sub options_Click(Index As Integer)
  frmOptions.Show vbModal, Me
End Sub

'Private Sub maptoolbar_Click(Index As Integer)
'  maptoolbar.Checked = Not maptoolbar.Checked
'    Toolbar1.Visible = maptoolbar.Checked
'    ' resize the map control
'    Form_Resize
'End Sub

Private Sub selection_Click(Index As Integer)
  Map1.CurrentTool = miSelectTool
End Sub
 
       'Add Point,Line,Polyline,Polygon
Private Sub addpoint_Click(Index As Integer)
 Map1.CurrentTool = miAddPointTool
End Sub
Private Sub addline_Click(Index As Integer)
  Map1.CurrentTool = miAddLineTool
End Sub
Private Sub addpolyline_Click(Index As Integer)
  Map1.CurrentTool = miAddPolylineTool
End Sub
Private Sub addpolygon_Click(Index As Integer)
  Map1.CurrentTool = miAddRegionTool
End Sub


Private Sub closeall_Click(Index As Integer)
  Me.Map1.Layers.RemoveAll
End Sub
Private Sub exit_Click(Index As Integer)
  Unload Me
End Sub

Private Sub layercontrol_Click(Index As Integer)
  Map1.Layers.LayersDlg
End Sub

Private Sub openfile_Click(Index As Integer)
  CommonDialog1.ShowOpen
End Sub



Private Sub pan_Click(Index As Integer)
  Map1.CurrentTool = miPanTool
End Sub

Private Sub projection_Click(Index As Integer)
    Map1.DisplayCoordSys.PickCoordSys
    ' Keep the numeric coordinate system the same as the display
    Set Map1.NumericCoordSys = Map1.DisplayCoordSys
End Sub



Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
'  Dim li As New MapXLib.LayerInfo
'  Dim ftrs As MapXLib.Features
'  Dim flds As MapXLib.Fields
'  Dim ds As MapXLib.Dataset
Select Case Button.Key
  Case "a"
    ''Dim str1 As String
    ''str1 = InputBox("请输入图层名字", "请输入图层名字")
    ' Set ds = Me.Map1.DataSets.Add(miDataSetLayer, Me.Map1.Layers(1))
    ' Set flds = ds.Fields
    ' Set ftrs = Me.Map1.Layers.Item(1).selection.Clone
    ' li.Type = miLayerInfoTypeNewTable
    ' li.AddParameter "name", str1
    ' li.AddParameter "FileSpec", App.Path & "112.tab"
    ' li.AddParameter "Fields", flds
    ' li.AddParameter "Features", ftrs
    ' li.AddParameter "OverwriteFile", "1"
    ' Me.Map1.Layers.Add li
        
        
    ' The editing dialog allows the user to make layers editable, set the current
    ' insertion layer, create new editable layers, etc.
         FrmEditing.Show vbModal, Me

'         Updateedit_Click
      
   Case "b"
      'CommonDialog1.CancelError = True
      Me.CommonDialog1.Filter = "GeoSet（*.gst）|*.gst|TAB文件(*.tab)|*.tab"
     'On Error GoTo 0
     'Exit Sub
      CommonDialog1.ShowOpen
        '      On Error GoTo 0
        '        MsgBox "打开错误：文件不可识别！", vbExclamation, "注意！"
        '      Exit Sub
        '      Dim str As String
      If Me.CommonDialog1.FileName <> "" Then
        '      str = Me.CommonDialog1.FileName
        '      Me.Map1.Layers.Add str
       Map1.GeoSet = CommonDialog1.FileName
      End If
   Case "c"
      pan_Click (0)
   Case "d"
      CommonDialog1.Filter = "GeoSet（*.gst）|*.gst|TAB文件（*.tab）|*.tab"
'      On Error GoTo NoSelFile
        CommonDialog1.ShowSave
      On Error GoTo OpenErr
      Map1.SaveMapAsGeoset "MyGeoSet", CommonDialog1.FileName
SubExit:
        Exit Sub
   'NoSelFile:
   '      GoTo SubExit
OpenErr:
        GoTo SubExit
    Case "e"
      zonmin_Click (0)
    Case "f"
      zonmout_Click (0)
    Case "g"
      Set Map1.Bounds = Map1.Layers.Bounds
    Case "h"
       layercontrol_Click (0)
End Select
    
End Sub
' Allows the user to pick a style for the current insertion layer.
Private Sub EditStyle_Click(Index As Integer)
    FrmStyle.Show vbModal, Me
End Sub

Private Sub viewentirelayer_Click(Index As Integer)
  viewentirelayers.Show vbModeless, Me
End Sub

Private Sub zonmin_Click(Index As Integer)
  Map1.CurrentTool = miZoomInTool
End Sub

Private Sub zonmout_Click(Index As Integer)
  Map1.CurrentTool = miZoomOutTool
End Sub
 ' If the user right clicks on the map, pop up the builtin MapX properties dialog
Private Sub Map1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 2 Then
        Map1.PropertyPage
    End If
End Sub
'  About Dialog
Private Sub about_Click()
  Dim style As VbMsgBoxStyle
  Dim Result As VbMsgBoxResult
  Dim strMessage, strTitle As String
  strTitle = "About The Programme"
  strMessage = "Version:1.0,Programmer:张伟."
  style = vbOK + vbInformation
  Result = MsgBox(strMessage, style, strTitle)
  If Result = vbOK Then
    MsgBox ("Thank you very much!")
  End If
End Sub
' Resize the map so that it takes up the entire window
Private Sub Form_Resize()
    If Me.ScaleWidth > 0 And Me.ScaleHeight > 0 Then
        Map1.Width = Me.ScaleWidth
        Map1.Height = Me.ScaleHeight
       If Me.ScaleWidth > 420 And Me.ScaleHeight > Toolbar1.Height Then
            If Toolbar1.Visible = True Then
               Map1.Top = Toolbar1.Height
               Map1.Height = Me.ScaleHeight - Toolbar1.Height
            Else
               Map1.Top = 0
               Map1.Height = Me.ScaleHeight
            End If

       End If
    End If

End Sub

'Private Sub Updateedit_Click()
'    If IsInvalidObject(Map1.Layers.InsertionLayer) Then
'        addpoint_Click.Checked = False
'        addline_Click.Checked = False
'        addpolyline_Click.Checked = False
'        addpolygon_Click.Checked = False
'    Else
'        addpoint_Click.Checked = True
'        addline_Click.Checked = True
'        addpolyline_Click.Checked = True
'        addpolygon_Click.Checked = True
'    End If
'End Sub