如何放大到选择的多个对象[原创]

'功能：放大到已经显示选择的地物
'调用参数：map1，recs
Public Function ZoomToSelected(map As MapObjects2.map, recs As MapObjects2.Recordset)

On Error GoTo ZoomError
'定义字段和值的变量，放大到的显示对象的范围的变量
Dim fld As MapObjects2.Field
Dim shp As Object
Dim ext As MapObjects2.Rectangle
Dim x1 As Double, x2 As Double
Dim y1 As Double, y2 As Double

recs.MoveFirst
Set fld = recs.Fields("Shape")
Set shp = fld.Value

'获得所选择的图形的范围，以进行下一步的放大到对象的操作

If TypeOf shp Is MapObjects2.Point Then
  Dim pts As New MapObjects2.Points
  pts.Add shp
  Do Until recs.EOF
    Set shp = fld.Value
    pts.Add shp
    recs.MoveNext
  
  Loop
  Set ext = pts.Extent
 Else
  Set ext = shp.Extent
  x1 = ext.Left
  x2 = ext.Right
  y1 = ext.Bottom
  y2 = ext.Top
  
    Do Until recs.EOF
    Set ext = fld.Value.Extent
    x1 = IIf(ext.Left < x1, ext.Left, x1)
    x2 = IIf(ext.Right > x2, ext.Right, x2)
    y1 = IIf(ext.Bottom < y1, ext.Bottom, y1)
    y2 = IIf(ext.Top > y2, ext.Top, y2)
    recs.MoveNext
  Loop
  ext.Left = x1
  ext.Right = x2
  ext.Bottom = y1
  ext.Top = y2
End If
'设置地图显示范围
Set map.Extent = ext
Exit Function
ZoomError:
End Function

谢谢！真是雪中送炭，正需要呢！

d

这个代码挺有意思的，有用！

谢谢，能不能多共享些源代码？

以下是引用rabbitli在2003-10-30 16:36:54的发言：
谢谢，能不能多共享些源代码？

mo自带的例子就很多了，很多时候需要大家一起讨论才行，一个人猛贴代码有什么意思？

十分感谢！太有用了！