form1.frm

用于河南省主体功能区区划的一个小地理信息系统

    Map2.Refresh
    
    
End Sub

'实现利用map2来改变map1
Private Sub Map2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim curRectangle As MapObjects2.Rectangle
  Dim pt As New MapObjects2.Point
  '画方框改变Map1窗口
  Set curRectangle = Map2.TrackRectangle
  Set Map1.Extent = curRectangle
  '点击改变Map1位置
  Set pt = Map2.ToMapPoint(X, Y)
  Map1.CenterAt pt.X, pt.Y
  If Map1.Extent.IsPointIn(pt) Then
    Set g_feedback = New DragFeedback
    g_feedback.DragStart Map1.Extent, Map2, X, Y
  End If
End Sub




Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
  Dim bKey As String
  bKey = Button.Key
  Call doTask(bKey)
  BarState = bKey

End Sub

Private Sub TuLi_AfterSetLayerVisible(Index As Integer, isVisible As Boolean)
Map1.Refresh
Map2.Refresh
End Sub

Sub dozoomin(MapI As MapObjects2.Map)
    On Error Resume Next
    Dim ow As Double
    Set rect = MapI.TrackRectangle
    ow = rect.Width
       
    If (ow) > 0 Then
       Set MapI.Extent = rect
    Else
       Set pt = rect.Center
       MapI.CenterAt pt.X, pt.Y
       Set newrect = MapI.Extent
       newrect.ScaleRectangle 0.75
       
       Set MapI.Extent = newrect
      
    End If
End Sub
Sub dozoomout(MapI As MapObjects2.Map)
    On Error Resume Next
    Dim ow As Double
    Set rect = MapI.TrackRectangle
    Set newrect = MapI.Extent
    ow = rect.Width
        
    If (ow > 0) Then
        newrect.ScaleRectangle MapI.Extent.Width / ow
    Else
        newrect.ScaleRectangle 1.5
    End If
     
    Set MapI.Extent = newrect
End Sub



Public Sub AddFile()
 'This procedure sets up the common dialog and returns a shapefile or image file
  'for processing into the Layers collection.

  Dim fullFile As String, path As String, tempChar As String, ext As String
  Dim Test As Boolean
  Dim textPos As Long, periodPos As Long
  Dim curPath As String
  
  'Execute common dialog for selecting a file to open.
  
  Dim strShape, strCov, strGRID, strCAD, strVPF, strImage, strMilImage As String
  strShape = "ESRI Shapefiles (*.shp) |*.shp"
  strCov = "ESRI Coverages (*.adf,*.tat,*.pat,*.rat) |aat.adf;pat.adf;nat.adf;txt.adf;*.tat;*.pat;*.rat"
  strGRID = "GRID (hdr.adf) |hdr.adf"
  strCAD = "CAD drawings (*.dwg,*.dxf) | *.dwg;*.dxf"
  strVPF = "VPF (*.pft,*.lat,*.aft,*.tft) |*.pft;*.lat;*.aft;*.tft"
  strImage = "Standard image formats |*.bmp;*.dib;*.tif;*.jpg;*.jff;*.bil;*.bip;*.bsq;*.gis;*.lan;*.rlc;*.sid;*.sun;*.rs;*.ras;*.svf;*.img;*.gif"
  strMilImage = "Military image formats |*.*"
  ' Set CancelError is True
  CommonDialog1.CancelError = True
  On Error GoTo FileOpenCancel
  
  CommonDialog1.Filter = strShape & "|" & strCov & "|" & strGRID & "|" & strCAD & "|" & strVPF & "|" & strImage & "|" & strMilImage
  CommonDialog1.DialogTitle = "选择新图层"
  CommonDialog1.ShowOpen
  
  'We have the full path name from the common dialog. Parse out base path.
  If CommonDialog1.FileTitle = "" Then Exit Sub
  fullFile = Trim$(CommonDialog1.FileName)  'FileName是带路径的文件名
  
  textPos = Len(fullFile)  '除去字符串左边的空格
  Test = False
  'This loop goes backwards through the string, searching for the
  'last back slash. This marks the base path from the returned string.
  Do While Test = False
    textPos = textPos - 1
    tempChar = Mid$(fullFile, textPos, 1)   '文件名的字符串倒数的的依次取出一个字符
    If tempChar = "." Then
      periodPos = textPos
    ElseIf tempChar = "\" Or textPos = 0 Then
      Test = True
    End If
  Loop
  
  'Path is the part of the full file string up to the last back slash.
  curPath = Left$(fullFile, textPos - 1)
  
  'Send the file name to the procedures that add the layers...
  Dim FileName As String
  Dim pref As String
  FileName = CommonDialog1.FileTitle
  
  'Check for file extension.  Add the selected data to the map as a layer
  'according to the syntax of the file format chosen.
  
  ext = LCase(Mid$(fullFile, periodPos + 1, 3))
  
  Select Case ext
    Case "shp"
      Call addShapeFile(curPath, FileName)
    Case "pat", "rat", "tat"
      Call addCoverage(curPath, FileName)
    Case "adf" 'Could be coverage or grid.  Figure it out.
      If FileName = "hdr.adf" Then
        Call addGRID(curPath, FileName)
       ElseIf pref = "aat" Or pref = "pat" Or pref = "nat" Or pref = "txt" Then
        Call addCoverage(curPath, FileName)
      End If
    Case "dwg", "dxf"
      Call addCAD(curPath, FileName)
    Case "aft", "lft", "pft"
      Call addVPF(curPath, FileName)
    Case Else
      Call addImage(fullFile)
End Select
  
  TuLi.setMapSource Map1
  TuLi.LoadLegend True
  Map1.Refresh
  Map2.Refresh
  Exit Sub
  
FileOpenCancel:
  Exit Sub
End Sub

Private Sub addShapeFile(basepath As String, shpfile As String)
 'This procedure validates and adds a shape file to the Layers collection.
  Dim dCon As New MapObjects2.DataConnection
  Dim gSet As MapObjects2.GeoDataset
  Dim strShapefileType As String
   Dim newLayer As New MapObjects2.MapLayer
   
  dCon.Database = basepath                  'Set Database property of DataConnection
  If dCon.Connect Then
    shpfile = GetFirstToken(shpfile, ".")   'Extract suffix of shpfile string
    Set gSet = dCon.FindGeoDataset(shpfile) 'Find shapefile as GeoDataset in DataConnection
    If gSet Is Nothing Then
      MsgBox "Error opening shapefile " & shpfile, vbCritical
      Exit Sub
    Else
    
    If gSet.HasZ Then
      strShapefileType = "[SHAPEFILZ]"
     Else
      strShapefileType = "[SHAPEFILE]"
    End If
    
     Set newLayer = New MapLayer
      newLayer.GeoDataset = gSet            'Set GeoDataset property of new MapLayer
      newLayer.Name = shpfile               'Set Name property of new MapLayer
'      newLayer.GeoDataset.AllowSharing = True
      'Attach path location to the layer's Tag, also add "[SHAPEFILE]"
      'or "[SHAPEFILZ]" to the Tag so that any subsequent addressmatching
      'or Elevation rendering will be able to tell that this is a
      'shapefile, and if so, if the shapefile supports Z shapes.
      
      newLayer.Tag = strShapefileType & dCon.Database & "|" & newLayer.Name
      Map1.Layers.Add newLayer   'Add MapLayer to Layers collection
    
      Set newLayer = New MapLayer
      newLayer.GeoDataset = gSet            'Set GeoDataset property of new MapLayer
      newLayer.Name = shpfile               'Set Name property of new MapLayer
      Map2.Layers.Add newLayer
      Map2.Extent = Map2.FullExtent
    End If
  Else
    MsgBox ConnectErrorMsg(dCon.ConnectError), vbCritical, "连接出现错误"
  End If
End Sub
Private Sub addImage(imageFile As String)
  'This procedure validates and adds an image file to the Layers collection
  Dim iLayer As New ImageLayer
  iLayer.File = imageFile
  'If the file is a valid image file, add it and move it to the
  'bottom (last index) of the Layers collection.
  If Map1.Layers.Add(iLayer) Then
    Map1.Layers.MoveToBottom 0
  Else
    MsgBox "This file, " & imageFile & ", is not a valid image file."
  End If
End Sub

Public Sub addSDElayer(SDEConn As MapObjects2.DataConnection)
  
'  If frmConnectSDE.lstLayers.text = "" Then
'    Exit Sub
'  End If
'
'  Dim gSet As MapObjects2.GeoDataset
'
'  If SDECon.Connect Then
'    Set gSet = SDECon.FindGeoDataset(frmConnectSDE.lstLayers.text)
'    If gSet Is Nothing Then
'      MsgBox "Error opening SDE layer " & frmConnectSDE.lstLayers.text
'      Exit Sub
'    Else
'      Dim newLayer As New MapObjects2.MapLayer
'      newLayer.GeoDataset = gSet
'      If gSet.HasZ Then
'        newLayer.Tag = "[SDEZ]"
'       Else
'        newLayer.Tag = "[SDE]"
'      End If
'      newLayer.name = frmConnectSDE.lstLayers.text
'
'      Map1.Layers.Add newLayer
'    End If
'   Else
'    MsgBox "Error# " & SDECon.ExtendedError & ": " & SDECon.ExtendedErrorString, _
'           vbCritical, "SDE Connection error"
'    MsgBox "Error# " & SDECon.ConnectError & ": " & ConnectErrorMsg(SDECon.ConnectError), _
'           vbCritical, "SDE Connection error"
'  End If
'
'  legend1.LoadLegend

End Sub

Private Sub addCoverage(basepath As String, FileName As String)
  'This procedure validates and adds a coverage feature attribute table
  'to the Layers collection.
  Dim dCon As New MapObjects2.DataConnection
  Dim gSet As MapObjects2.GeoDataset
  Dim str As String
  
  'For ARC/INFO coverages, the Database property of the DataConnection object
  'needs to be the workspace directory, not the coverage directory, so we need
  'to specify the folder one level above what the common dialog returned...
  Dim textPos As Long, periodPos As Long
  Dim Test As Boolean
  Dim tempChar As String
  Dim fullFile As String, workspace As String, featAttTable As String
  
  fullFile = Trim$(CommonDialog1.FileName)

  textPos = Len(basepath)
  Test = False
  
  'This loop goes backwards through the string, searching for the
  'last back slash. This marks the base path from the returned string.
  Do While Test = False
    textPos = textPos - 1
    tempChar = Mid$(basepath, textPos, 1)
    If tempChar = "." Then
      periodPos = textPos
    ElseIf tempChar = "\" Or textPos = 0 Then
      Test = True
    End If
  Loop
  
  'Path is the part of the full file string up to the last back slash.
  workspace = "[arc]" & Left$(basepath, textPos - 1)
  
  'Send the file name to the procedures that add the layers...
  Dim coverage As String
  Dim lenBasePath As Long
  Dim ext As String
  ext = LCase(Right$(FileName, 3))
  lenBasePath = Len(basepath)
  coverage = Right$(basepath, lenBasePath - textPos)
  
  If ext = "adf" Then
    featAttTable = coverage & "." & Left$(FileName, Len(FileName) - 4)
  Else
    featAttTable = coverage & "." & ext & Left$(FileName, Len(FileName) - 4)
  End If
    
  featAttTable = LCase(featAttTable)
  workspace = LCase(workspace)

  'Also, feature attribute tables are specified by the coverage name followed
  'by the feature attribute table, minus its .adf extension...
  
  dCon.Database = workspace                      'Set Database property of DataConnection
  If dCon.Connect Then
    Set gSet = dCon.FindGeoDataset(featAttTable) 'Find shapefile as GeoDataset in DataConnection
    If gSet Is Nothing Then
      MsgBox "Error opening coverage feature attribute table " & featAttTable
      Exit Sub
    Else
      Dim newLayer As New MapLayer
      newLayer.GeoDataset = gSet            'Set GeoDataset property of new MapLayer
      newLayer.Name = featAttTable          'Set Name property of new MapLayer
      Map1.Layers.Add newLayer   'Add MapLayer to Layers collection
    End If
  Else
    MsgBox ConnectErrorMsg(dCon.ConnectError), vbCritical, "Connection error"
  End If

End Sub

Private Sub addGRID(basepath As String, gridfile As String)

Dim ilyr As New MapObjects2.ImageLayer

ilyr.File = basepath & "\" & gridfile
Map1.Layers.Add ilyr
'lgdcontrol.LoadLegend

End Sub

Private Sub addCAD(basepath As String, cadfile As String)

'Load frmCAD so that the user can choose which
'CAD feature types within the "cadfile" to load
'into the map
frmCAD.cadFileName = cadfile
frmCAD.Show vbModal


Dim dc As New MapObjects2.DataConnection
Dim mlyr As New MapObjects2.MapLayer

If frmCAD.chkCAD(2).Value = 1 Then
  dc.Database = "[CADArea]" & basepath
  If Not dc.Connect Then
    GoTo CADerror
  End If
  Set mlyr.GeoDataset = dc.FindGeoDataset(cadfile)
  Map1.Layers.Add mlyr
End If

Set dc = New MapObjects2.DataConnection
Set mlyr = New MapObjects2.MapLayer

If frmCAD.chkCAD(1).Value = 1 Then
  dc.Database = "[CADLine]" & basepath
  If Not dc.Connect Then
    GoTo CADerror
  End If
  Set mlyr.GeoDataset = dc.FindGeoDataset(cadfile)
  Map1.Layers.Add mlyr
End If

Set dc = New MapObjects2.DataConnection
Set mlyr = New MapObjects2.MapLayer

If frmCAD.chkCAD(0).Value = 1 Then
  dc.Database = "[CADPoint]" & basepath
  If Not dc.Connect Then
    GoTo CADerror
  End If
  Set mlyr.GeoDataset = dc.FindGeoDataset(cadfile)
  Map1.Layers.Add mlyr
End If

Set dc = New MapObjects2.DataConnection
Set mlyr = New MapObjects2.MapLayer

If frmCAD.chkCAD(3).Value = 1 Then
  dc.Database = "[CADText]" & basepath
  If Not dc.Connect Then
    GoTo CADerror
  End If
  Set mlyr.GeoDataset = dc.FindGeoDataset(cadfile)
  Map1.Layers.Add mlyr
End If

'Reset map legend and map contents list
'lgdcontrol.LoadLegend

Unload frmCAD

Exit Sub

CADerror:
MsgBox "无法连接到 " & basepath, vbCritical, "停止"

End Sub

Private Sub addVPF(ByVal basepath As String, ByVal vpffile As String)

Dim dc As New MapObjects2.DataConnection
Dim mlyr As New MapObjects2.MapLayer

dc.Database = "[VPF]" & basepath
If Not dc.Connect Then
  MsgBox "Could not connect to " & basepath
  Exit Sub
End If

Set mlyr.GeoDataset = dc.FindGeoDataset(vpffile)
Map1.Layers.Add mlyr

'Reset map legend and map contents list
'lgdcontrol.LoadLegend

End Sub

Private Sub TuLi_LayerDblClick(Index As Integer)

  Set g_activelayer = Map1.Layers(Index)
  
    If g_activelayer.LayerType = moImageLayer Then
       MsgBox "对不起，你不能为栅格图像设置该属性！", vbExclamation, "提示"
       Exit Sub
    End If

  'Invoke property sheet for new layer.
  'Load frmLayerSymbol
  frmLayerSymbol.Show
End Sub
Public Sub updateScale()
  
  'This procedure updates the scale dislay in the status bar.
  Dim mapScreenWidth As Double
  Dim mapExtentWidth As Double
  Dim mapScale As Double
  Dim convFactor As Double
  Dim zoomFactor As Double
  'If there are no layers, we cannot calculate scale
  If Map1.Layers.Count = 0 Then
    StatusBar1.Panels(1).Text = "Scale Unknown"
    Exit Sub
  End If
  
  'If the map units are unknown, we cannot calculate scale
  If strMapUnits = "Unknown" Then
    StatusBar1.Panels(1) = "Map Units Unknown"
    Exit Sub
  End If
  
  Select Case strMapUnits
    Case "Decimal Degrees":  convFactor = INCH2DEGREES
    Case "Meters":           convFactor = INCH2METERS
    Case "Feet":             convFactor = INCH2FEET
  End Select
  
  'Get width of screen and convert twips to inches.
  mapScreenWidth = Map1.Width / 1440
  
  'Get map width and convert to inches
  mapExtentWidth = Map1.Extent.Width * convFactor
  
  'Calculate scale and update text of status bar
  mapScale = mapExtentWidth / mapScreenWidth
  StatusBar1.Panels(1).Text = "比例尺 1 : " & Format(mapScale, "###,###,###,")
   zoomFactor = Map1.FullExtent.Width / Map1.Extent.Width
   StatusBar1.Panels(3) = "缩放倍数：" & zoomFactor
End Sub