地图显示.frm

本程序利用vb实现了地理信息系统中空间分析的各种方法

        Case moArrow
        Set recset1 = Map1.Layers(0).SearchByDistance(p, 0.2, "")
        
End Select
Map1.Refresh
End Sub



Private Sub Map2_AfterTrackingLayerDraw(ByVal hdc As stdole.OLE_HANDLE)
 ' draw a rectangle indicating the current extent of Map1
  Dim sym As New Symbol
  sym.OutlineColor = moRed
  sym.Style = moTransparentFill
  Map2.DrawShape Map1.Extent, sym
End Sub
Private Sub Map2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  Dim p As Point
  Set p = Map2.ToMapPoint(X, Y)
  If Map1.Extent.IsPointIn(p) Then
    Set g_feedback = New DragFeedback
    g_feedback.DragStart Map1.Extent, Map2, X, Y
  End If
End Sub
Private Sub Map1_AfterLayerDraw(ByVal Index As Integer, ByVal canceled As Boolean, ByVal hdc As stdole.OLE_HANDLE)
If Index = 0 Then
    Map2.TrackingLayer.Refresh True
End If

End Sub


Private Sub Map2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
 If Not g_feedback Is Nothing Then
    g_feedback.DragMove X, Y
  End If
End Sub

Private Sub Map2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
 If Not g_feedback Is Nothing Then
    Map1.Extent = g_feedback.DragFinish(X, Y)
    Set g_feedback = Nothing
  End If
End Sub

Private Sub mnuopencad_Click()
Dim basepath As String
Dim filename As String
Dim dCon As New DataConnection
Dim gSet As GeoDataset
Dim str As String
  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
  CommonDialog1.Filter = "Drawing (*.dwg)|*.dwg*|DXF (*.dxf)|*.dxf"
  CommonDialog1.ShowOpen
  basepath = CurDir
filename = CommonDialog1.FileTitle
  If filename = "" Then
    MsgBox ("You haven't select layer!")
    Exit Sub
 End If
  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
   featAttTable = Left$(filename, Len(filename))
   workspace = basepath
  'Also, feature attribute tables are specified by the coverage name followed
  'by the feature attribute table, minus its .adf extension...
  dCon.Database = "[CAD]" & 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 Auto CAD files " & 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
      
     ' newLayer.Symbol.Color = moGreen
      
      Map1.Layers.Add newLayer
      Map1.Refresh
      'Add MapLayer to Layers collection
      Map2.Layers.Add newLayer
      Map2.Refresh
    End If
  Else
    'MsgBox ConnectErrorMsg(dCon.ConnectError), vbCritical, "Connection error"
  End If
  legend1.setMapSource Map1
  
  legend1.LoadLegend True
  Map1.Refresh
  
End Sub

Private Sub mnuopencov_Click()
Dim basepath As String
Dim filename As String
Dim dCon As New DataConnection
Dim gSet As GeoDataset
Dim str As String
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
CommonDialog1.Filter = "arc/info coverage(*.adf)|*.adf"
CommonDialog1.ShowOpen
basepath = CurDir
filename = CommonDialog1.FileTitle
   If filename = "" Then
      MsgBox ("you haven't select layer!")
      Exit Sub
   End If
fullFile = Trim$(CommonDialog1.filename)
textPos = Len(basepath)
Test = False
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
workspace = "[arc]" & Left$(basepath, textPos - 1)
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
   featattbable = coverage & "." & ext & Left$(filename, Len(filename) - 4)
End If
featAttTable = LCase(featAttTable)
workspace = LCase(workspace)
dCon.Database = workspace
If dCon.Connect Then
  Set gSet = dCon.FindGeoDataset(featAttTable)
  If gSet Is Nothing Then
     MsgBox "error opening coverage featrue attribute table" & featAttTable
     Exit Sub
  Else
     Dim newLayer As New MapLayer
     newLayer.GeoDataset = gSet
     newLayer.Name = featAttTable
     Map1.Layers.Add newLayer
     Map2.Layers.Add newLayer
  End If
   legend1.setMapSource Map1
   legend1.LoadLegend True
  

End If
End Sub

Private Sub mnuopenshp_Click()
Dim basepath As String
Dim filename As String
Dim dCon As New DataConnection
Dim gSet As GeoDataset
Dim str As String
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
CommonDialog1.Filter = "esri shapefile(*.shp)|*.shp"
CommonDialog1.ShowOpen
basepath = CurDir
filename = CommonDialog1.FileTitle
   If filename = "" Then
      MsgBox ("you haven't select layer!")
      Exit Sub
   End If
fullFile = Trim$(CommonDialog1.filename)
textPos = Len(basepath)
Test = False
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
featAttTable = Left$(filename, Len(filename) - 4)
workspace = basepath
dCon.Database = workspace
If dCon.Connect Then
  Set gSet = dCon.FindGeoDataset(featAttTable)
  If gSet Is Nothing Then
     MsgBox "error spening esri shapefile" & featAttTable
     Exit Sub
  Else
    Dim newLayer As New MapLayer
    newLayer.GeoDataset = gSet
    newLayer.Name = featAttTable
    'newLayer.Symbol.Color = moGreen
    Map1.Layers.Add newLayer
    Map2.Layers.Add newLayer
    
    legend1.setMapSource Map1
    legend1.LoadLegend True
    
    Map1.Refresh
    Map2.Refresh
    
    
    Dim i, j As Integer
    i = Map1.Layers.Count
   
  End If

End If
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
            Case "zoomin"
                Map1.MousePointer = moZoomIn
            Case "zoomout"
               Map1.MousePointer = moZoomOut

            Case "pan"
               Map1.MousePointer = moPan
               
            Case "globe"
                Map1.Extent = Map1.FullExtent
                Map2.Extent = Map1.FullExtent
            Case "arrow"
                Map1.MousePointer = moArrow
 End Select
       
End Sub