famoushzb
路人甲
路人甲
  • 注册日期2004-12-27
  • 发帖数2
  • QQ
  • 铜币114枚
  • 威望0点
  • 贡献值0点
  • 银元0个
阅读:873回复:0

帮忙看一段代码,谢谢

楼主#
更多 发布于:2005-01-23 16:05
<P>' Results of spatial search
Dim g_selectedFeatures As MapObjects2.Recordset</P>
<P>' Search shapes when using other features to search.
Dim g_searchSet As MapObjects2.Recordset</P>
<P>' Search shape when using rubberbanded shape to search
Dim g_searchShape As Object</P>
<P>Dim g_selectedBounds As MapObjects2.Rectangle
Dim g_searchBounds As MapObjects2.Rectangle
Private Sub Command1_Click()
Dim dc As New DataConnection
Dim gs As GeoDataset
Dim name As String
Dim layer As MapObjects2.MapLayer
CommonDialog1.Filter = "ESRI Shapefiles(*.shp)|*.shp"
CommonDialog1.ShowOpen
If Len(CommonDialog1.FileName) = 0 Then Exit Sub
dc.Database = CurDir
If Not dc.Connect Then Exit Sub
name = Left(CommonDialog1.FileTitle, Len(CommonDialog1.FileTitle) - 4)
Set gs = dc.FindGeoDataset(name)
If gs Is Nothing Then Exit Sub
Set layer = New MapLayer
layer.GeoDataset = gs
Map1.Layers.Add layer
End Sub</P>
<P>Private Sub Map1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim pt As MapObjects2.Point
Set pt = Map1.ToMapPoint(X, Y)
Set g_searchShape = pt
Dim ptBounds As New MapObjects2.Rectangle
ptBounds.Left = pt.X
ptBounds.Top = pt.Y
ptBounds.Right = pt.X
ptBounds.Bottom = pt.Y
Set g_searchBounds = ptBounds
Set g_searchSet = Nothing
ExecuteSearch
End Sub
Sub ExecuteSearch()
  
  '
  ' We're either searching with a single shape or a
  ' record set.  The search routines don't care so,
  ' put the search shape(s) in a single variable
  ' called shapes.
  '
  Dim shapes As Object
  Set shapes = Nothing
  If Not g_searchShape Is Nothing Then Set shapes = g_searchShape
  If Not g_searchSet Is Nothing Then Set shapes = g_searchSet
  If shapes Is Nothing Then Exit Sub
  
  ' reset the selection and execute the search
  Screen.MousePointer = 11
  Set g_selectedFeatures = Nothing
  Set g_selectedFeatures = Map1.Layers(0).SearchByDistance(shapes, 0.05, "")
  Set g_selectedBounds = GetRecordsetBounds(g_selectedFeatures)
  Map1.TrackingLayer.Refresh True
  Screen.MousePointer = 0
End Sub
</P>
<P>Private Function GetRecordsetBounds(recs As MapObjects2.Recordset) As MapObjects2.Rectangle
  ' Get the bounds of the recordset
  Set GetRecordsetBounds = Nothing
  If Not recs Is Nothing Then
    Dim bounds As MapObjects2.Rectangle
    Set bounds = Nothing
    Set fld = recs("Shape")
    
    ' For each feature in recordset...
    recs.MoveFirst
    Do While Not recs.EOF
    
      ' get shape bounds
      Dim shapeBounds As MapObjects2.Rectangle
      If fld.Type = moPoint Then
        Dim pt As MapObjects2.Point
        Set pt = fld.Value
        Dim ptBounds As New MapObjects2.Rectangle
        ptBounds.Left = pt.X
        ptBounds.Top = pt.Y
        ptBounds.Right = pt.X
        ptBounds.Bottom = pt.Y
        Set shapeBounds = ptBounds
      ElseIf fld.Type = moLine Then
        Dim l As MapObjects2.Line
        Set l = fld.Value
        Set shapeBounds = l.Extent
      ElseIf fld.Type = moPolygon Then
        Dim p As MapObjects2.Polygon
        Set p = fld.Value
        Set shapeBounds = p.Extent
      Else
        MsgBox "Invalid shape in GetRecordsetBounds!"
      End If
      
      ' add shape bounds to total
      If bounds Is Nothing Then
        Set bounds = shapeBounds
      Else
        bounds.Union shapeBounds
      End If
      
      recs.MoveNext
    Loop
    
    Set GetRecordsetBounds = bounds
  End If
End Function</P>
<P>
Private Sub Map1_AfterTrackingLayerDraw(ByVal hDC As StdOle.OLE_HANDLE)
  If g_searchBounds Is Nothing And g_selectedBounds Is Nothing Then Exit Sub
  
  ' Either g_searchSet or g_searchShape will be valid.
  DrawRecordset g_selectedFeatures, moMagenta, moSolidFill
  DrawRecordset g_searchSet, moYellow, moTransparentFill
  DrawShape g_searchShape, moYellow, moTransparentFill
End Sub</P>
<P>
Sub DrawShape(shape As Object, color, style)
  ' draw the shape
  If Not shape Is Nothing Then
    Dim sym As New Symbol
    sym.color = color
    If style = moTransparentFill Then sym.OutlineColor = color
    sym.style = style
    Map1.DrawShape shape, sym
  End If
End Sub</P>
<P>Sub DrawRecordset(recs As MapObjects2.Recordset, color, style)
Dim gline As Object
Dim pt As New MapObjects2.Point
  ' draw the features of a RecordSet
  If Not recs Is Nothing Then
    Set gline = recs("Shape").Value
    Set pt = gline.Parts(0).Item(0)
    Dim f As MapObjects2.Field
    Dim sym As New Symbol
    sym.color = color
    If style = moTransparentFill Then sym.OutlineColor = color
    sym.style = style
    Map1.DrawShape recs, sym
    List1.AddItem pt.X
  End If
End Sub
各位高手,以上的code要实现用鼠标捕捉shapefile里的一条线,并把线的端点的坐标在list中显示出来,现在我能捕捉线,但端点不能显示,是最后的drawrecordset函数有问题。代码比较长,哪位高手能耐心看看,不甚感激。</P><img src="images/post/smile/dvbbs/em02.gif" /><img src="images/post/smile/dvbbs/em02.gif" /><img src="images/post/smile/dvbbs/em02.gif" />
喜欢0 评分0
游客

返回顶部