全屏显示地图的时候调整地图位置

有的时候有点用

Option Explicit
Private rectActualFullExtent As MapObjects2.Rectangle
Private rectModifiedFullExtent As MapObjects2.Rectangle
Private symAFE As MapObjects2.Symbol

Private Sub Command1_Click()

'得到矩形范围
Set rectActualFullExtent = Map1.FullExtent
'做 拷贝
Set rectModifiedFullExtent = rectActualFullExtent
'Increase the full extent 10x
rectModifiedFullExtent.ScaleRectangle 10
'写到地图
Set Map1.FullExtent = rectModifiedFullExtent
'计算实际大小
CalcActualFullExtent

End Sub

Private Sub Form_Load()

Dim dc As New MapObjects2.DataConnection
Dim mlyr As New MapObjects2.MapLayer
dc.Database = App.Path
dc.Connect
Set mlyr.GeoDataset = dc.FindGeoDataset("polys")
mlyr.Symbol.Color = moLightGray
Map1.Layers.Add mlyr

Set symAFE = New MapObjects2.Symbol
With symAFE
  .SymbolType = moFillSymbol
  .Style = moTransparentFill
  .OutlineColor = moRed
End With

CalcActualFullExtent

End Sub

Private Sub Map1_AfterTrackingLayerDraw(ByVal hDC As stdole.OLE_HANDLE)

If Not rectActualFullExtent Is Nothing Then
  Map1.DrawShape rectActualFullExtent, symAFE
End If

End Sub

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

'放大，漫游
If Shift = 0 Then
  If Button = 1 Then
   Set Map1.Extent = Map1.TrackRectangle
    Else
     Map1.Pan
  End If
 Else
  If Button = 1 Then
    Dim rect As MapObjects2.Rectangle
     Set rect = Map1.Extent
     rect.ScaleRectangle (1.2)
     Set Map1.Extent = rect
   Else
     Set Map1.Extent = CalcActualFullExtent
  End If
End If

End Sub

Private Function CalcActualFullExtent() As MapObjects2.Rectangle

Dim lyr As Variant
Dim rect As MapObjects2.Rectangle

'
Set rectActualFullExtent = Map1.Layers(0).Extent
For Each lyr In Map1.Layers
  Set rectActualFullExtent = rectActualFullExtent.Union(lyr.Extent)
Next lyr
Set CalcActualFullExtent = rectActualFullExtent

End Function

<img src="images/post/smile/dvbbs/em01.gif" /><img src="images/post/smile/dvbbs/em01.gif" />