缓冲区分析.frm

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

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
     
  End If
   
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
    
    Map1.Refresh
  
  End If
End If
End Sub

Private Sub Map1_AfterTrackingLayerDraw(ByVal hdc As stdole.OLE_HANDLE)
 If Not buffer Is Nothing Then
    Dim sym2 As New Symbol
    sym2.Color = moYellow
    sym2.Style = moCrossMarker
    Map1.DrawShape buffer, sym2
 Else
    MsgBox "you have't select a object"
 End If

End Sub

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Set pp = Map1.ToMapPoint(X, Y)
     Set recset = Map1.Layers(0).SearchByDistance(pp, 0.5, "")
     If Not recset.EOF Then
             If Not Text1.Text = "" Then
  
                Select Case i
                
                Case 1
                If Not Map1.Layers(0).shapeType = moShapeTypePoint Then
                MsgBox "地图上没有点状地物"
                Exit Sub
                End If
                Set pot = recset.Fields("Shape").Value
                Set buffer = pot.buffer(Text1.Text, Map1.FullExtent)
                Set bufferpolygon = buffer
                bufferesult.Show
                
                Case 2
                If Not Map1.Layers(0).shapeType = moShapeTypeLine Then
                MsgBox "地图上没有线状地物"
                Exit Sub
                End If
                Set line1 = recset.Fields("shape").Value
                Set buffer = line1.buffer(Text1.Text, Map1.FullExtent)
                Set bufferpolygon = buffer
                bufferesult.Show
                
                Case 3
                If Not Map1.Layers(0).shapeType = moShapeTypePolygon Then
                MsgBox "地图上没有面状地物"
                Exit Sub
                End If
                Set polygon1 = recset.Fields("shape").Value
                Set buffer = polygon1.buffer(Text1.Text, Map1.FullExtent)
                Set bufferpolygon = buffer
                bufferesult.Show
                End Select
             Else
                MsgBox "please input the buffer distance"
                 
             End If
            
     End If
     
  Select Case Map1.MousePointer
        Case moZoomIn
        Set Map1.Extent = Map1.TrackRectangle
        
        
        Case moZoomOut
        Dim r As MapObjects2.Rectangle
        Set r = Map1.Extent
        r.ScaleRectangle 1.5
        Map1.Extent = r
                  
        Case moPan
        Map1.Pan
        
        Case moArrow
        Map1.MousePointer = moArrow
        
       
    End Select
    Map1.Refresh
End Sub
Private Sub Option1_Click()
Combo1.Clear
 For n = 0 To Map1.Layers.Count - 1
          Set lyr = Map1.Layers(n)
          If lyr.shapeType = moShapeTypePoint Then
          Combo1.AddItem lyr.Name
          Map1.Layers.MoveTo n, 0
          End If
 Next n
If Not Map1.Layers(0).shapeType = moShapeTypePoint Then
MsgBox "地图上没有点状地物"
End If
Combo1.Refresh
Map1.MousePointer = moCross
i = 1

Map1.Refresh
End Sub

Private Sub Option2_Click()
Combo1.Clear

 For n = 0 To Map1.Layers.Count - 1
     
          Set lyr = Map1.Layers(n)
          If lyr.shapeType = moShapeTypeLine Then
          Combo1.AddItem lyr.Name
          Map1.Layers.MoveTo n, 0
          End If
 Next n
If Not Map1.Layers(0).shapeType = moShapeTypeLine Then
MsgBox "地图上没有线状地物"
End If
Combo1.Refresh

Map1.MousePointer = moCross
i = 2
Map1.Refresh
End Sub

Private Sub Option3_Click()
Combo1.Clear
 For n = 0 To Map1.Layers.Count - 1
          Set lyr = Map1.Layers(n)
          If lyr.shapeType = moShapeTypePolygon Then
          Combo1.AddItem lyr.Name
          Map1.Layers.MoveTo n, 0
          End If
 Next n
If Not Map1.Layers(0).shapeType = moShapeTypePolygon Then
MsgBox "地图上没有面状地物"
End If
Combo1.Refresh
Map1.MousePointer = moCross
i = 3
Map1.Refresh

End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
i = 0
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
              
            Case "arrow"
                Map1.MousePointer = moArrow
             
 End Select
End Sub