dynamiczoom.frm

This application, built in VB using MapObjects, allows the user to zoom in, zoom out and pan using

VERSION 5.00
Object = "{9BD6A640-CE75-11D1-AF04-204C4F4F5020}#2.0#0"; "mo20.ocx"
Begin VB.Form Form1 
   BackColor       =   &H00C0C0C0&
   Caption         =   "DynamicZoom"
   ClientHeight    =   9495
   ClientLeft      =   165
   ClientTop       =   540
   ClientWidth     =   13290
   LinkTopic       =   "Form1"
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   9495
   ScaleWidth      =   13290
   Begin MapObjects2.Map Map2 
      Height          =   3705
      Left            =   9315
      TabIndex        =   6
      Top             =   135
      Width           =   3855
      _Version        =   131072
      _ExtentX        =   6800
      _ExtentY        =   6535
      _StockProps     =   225
      BackColor       =   0
      BorderStyle     =   1
      Appearance      =   1
      BackColor       =   0
      Contents        =   "dynamicZoom.frx":0000
   End
   Begin MapObjects2.Map Map1 
      Height          =   9360
      Left            =   105
      TabIndex        =   5
      Top             =   30
      Width           =   9090
      _Version        =   131072
      _ExtentX        =   16034
      _ExtentY        =   16510
      _StockProps     =   225
      BackColor       =   16777215
      BorderStyle     =   1
      Appearance      =   1
      ScrollBars      =   0   'False
      MousePointer    =   2
      Contents        =   "dynamicZoom.frx":001A
   End
   Begin VB.CommandButton Command2 
      Caption         =   "E&xit"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   12
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   11970
      TabIndex        =   4
      Top             =   8970
      Width           =   1215
   End
   Begin VB.CommandButton Command1 
      Caption         =   "&Help"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   12
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   10545
      TabIndex        =   3
      Top             =   8985
      Width           =   1245
   End
   Begin VB.CheckBox Check2 
      Caption         =   "I&dentify"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   24
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   510
      Left            =   9315
      TabIndex        =   2
      Top             =   8160
      Width           =   2145
   End
   Begin VB.ListBox List1 
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   3180
      Left            =   9315
      TabIndex        =   1
      Top             =   4035
      Width           =   3795
   End
   Begin VB.CheckBox Check1 
      Caption         =   "P&an"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   24
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   525
      Left            =   9375
      TabIndex        =   0
      Top             =   7485
      Width           =   1350
   End
   Begin VB.Timer Timer1 
      Left            =   9675
      Top             =   8865
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim gZoomingIn As Boolean
Dim gZoomingOut As Boolean

Dim gSym As New Symbol
Dim gLineSym As New Symbol


Dim gFeedback As DragFeedback

Dim gCursor As New MapObjects2.Line

Dim gLastFID As Long

Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long

Private Type POINTAPI
        x As Long
        y As Long
End Type

Private Sub CenterCursorOnMap()
  Dim pt As POINTAPI
  pt.x = ScaleX(Map1.width / 2, vbTwips, vbPixels)
  pt.y = ScaleY(Map1.Height / 2, vbTwips, vbPixels)
  ClientToScreen Map1.hwnd, pt
  SetCursorPos pt.x, pt.y
End Sub

Private Sub DoIdentify()
  Dim lyr As MapLayer
  Set lyr = Map1.Layers("lots")
  If Not lyr.Visible Then
    List1.Clear
    Exit Sub
  End If
  
  Dim rex As MapObjects2.Recordset
  Set rex = lyr.SearchShape(Map1.Extent.Center, moPointInPolygon, "")
  If rex.EOF Then
    List1.Clear
    Exit Sub
  End If
  
  If rex("parcels_id").Value = gLastFID Then Exit Sub
    
  List1.Clear
  
  Dim fld As MapObjects2.Field
  For Each fld In rex.Fields
    List1.AddItem fld.Name & ": " & fld.ValueAsString
  Next fld
End Sub

Private Sub LoadData()
  Dim dc As New MapObjects2.DataConnection
  dc.Database = App.Path & "\Data"
  If Not dc.Connect Then
    MsgBox "Data not found."
    End
  End If
    
  Dim lyr As New MapLayer
  Set lyr.GeoDataset = dc.FindGeoDataset("clines")
  'Set lyr.Renderer = CreateParcelRenderer
  lyr.Symbol.Color = moNavy
  Map1.Layers.Add lyr
  lyr.Visible = True
  
  Set lyr = New MapLayer
  Set lyr.GeoDataset = dc.FindGeoDataset("lots")
  lyr.Symbol.Color = moGreen
  Map1.Layers.Add lyr
  lyr.Visible = False
  
  Set lyr = New MapLayer
  Set lyr.GeoDataset = dc.FindGeoDataset("bldg")
  lyr.Symbol.Color = moLightYellow
  Map1.Layers.Add lyr
  lyr.Visible = False
  
  Set lyr = New MapLayer
  Set lyr.GeoDataset = dc.FindGeoDataset("clines")
  lyr.Symbol.Color = moLightGray
  Map2.Layers.Add lyr

End Sub




Private Sub Check1_Click()
  If Check1.Value = 1 Then
    ShowCursor False
    CenterCursorOnMap
  Else
    ShowCursor True
  End If
End Sub


Private Sub Command1_Click()
  Form2.Show
End Sub

Private Sub Command2_Click()
  End
End Sub

Private Sub Form_Load()
  LoadData
ShowCursor True
  Dim r As Rectangle
  Set r = Map1.FullExtent
  r.ScaleRectangle 1.1
  Map1.FullExtent = r
  Map1.Extent = r
  
  Map2.FullExtent = r
  Map2.Extent = r
  
  gZoomingIn = False
  gZoomingOut = False

  gSym.OutlineColor = moRed
  gSym.Style = moTransparentFill
  
  gLineSym.SymbolType = moLineSymbol
  gLineSym.Color = moBlack
  gLineSym.Size = 3
  
  ' initialize the g_cursor with two points
  Dim p As New MapObjects2.Point
  Dim pts As New MapObjects2.Points
  p.x = 1
  p.y = 1
  pts.Add p
  p.x = 1
  p.y = 1
  pts.Add p
  gCursor.Parts.Add pts


  Map1.RefreshCount = 1000000
  
End Sub

Function CreateParcelRenderer() As Object
  Dim r As New ClassBreaksRenderer
  r.Field = "area"
  r.BreakCount = 4
  r.Break(0) = 22904.5268346446
  r.Break(1) = 96490.0508795875
  r.Break(2) = 170075.57492453
  r.Break(3) = 243661.098969473
  
  ' create a color ramp
  r.RampColors moLightYellow, moBlue
  
  Set CreateParcelRenderer = r
End Function


Private Sub Map1_AfterLayerDraw(ByVal index As Integer, ByVal canceled As Boolean, ByVal hDC As OLE_HANDLE)
  If index = 0 Then
    ' after drawing the first layer, refresh the locator map
    Map2.TrackingLayer.Refresh True
    If Check2.Value = 1 Then DoIdentify
  End If
End Sub

Private Sub Map1_AfterTrackingLayerDraw(ByVal hDC As OLE_HANDLE)
  Dim ctr As MapObjects2.Point, p As New MapObjects2.Point
  Set ctr = Map1.Extent.Center
  Dim pts As MapObjects2.Points
  Dim pt As MapObjects2.Point
  Set pts = gCursor.Parts(0)
  
  Dim delta As Double
  delta = Map1.ToMapDistance(125)
  p.x = ctr.x - delta
  p.y = ctr.y - delta
  pts.Set 0, p
  p.x = ctr.x + delta
  p.y = ctr.y + delta
  pts.Set 1, p
  
  Map1.DrawShape gCursor, gLineSym
  
  p.x = ctr.x - delta
  p.y = ctr.y + delta
  pts.Set 0, p
  p.x = ctr.x + delta
  p.y = ctr.y - delta
  pts.Set 1, p
  
  Map1.DrawShape gCursor, gLineSym
  
End Sub


Private Sub Map1_BeforeLayerDraw(ByVal index As Integer, ByVal hDC As OLE_HANDLE)
  If index = Map1.Layers.Count - 1 Then
    Dim width As Double
    width = Map1.Extent.width
    Map1.Layers("clines").Visible = width >= 3000
    Map1.Layers("lots").Visible = width < 3000
    Map1.Layers("bldg").Visible = width < 1500
    
  End If
End Sub


Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  If Button = 1 Then
    gZoomingIn = True
    Timer1.Interval = 50
  ElseIf Button = 2 Then
    gZoomingOut = True
    Timer1.Interval = 50
  Else
    Timer1.Interval = 0
  End If
End Sub


Private Sub Map1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  
  If gZoomingIn Or gZoomingOut Or Check1.Value = 0 Then
    Exit Sub
  End If
    
  Dim jump As Integer, centerX As Single, centerY As Single
  jump = 25
  centerX = Map1.width / 2
  centerY = Map1.Height / 2
  
  If (Abs(centerX - x) > jump) Or (Abs(centerY - y) > jump) Then
  
    Dim dX As Double, dY As Double
    dX = Map1.ToMapDistance(x - centerX)
    dY = Map1.ToMapDistance(y - centerY)
    Dim r As Rectangle
    Set r = Map1.Extent
    r.Offset dX, -dY
    Map1.Extent = r
    
    CenterCursorOnMap
  End If
    
End Sub

Private Sub Map1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  Timer1.Interval = 0
  gZoomingIn = False
  gZoomingOut = False
End Sub


Private Sub Map2_AfterTrackingLayerDraw(ByVal hDC As OLE_HANDLE)
  ' draw a rectangle indicating the current extent of Map1
  Map2.DrawShape Map1.Extent, gSym

End Sub

Private Sub Map2_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  ' convert to map point
  Dim p As Point
  Set p = Map2.ToMapPoint(x, y)
  
  ' if the click happened inside the indicator, then start dragging
  If Map1.Extent.IsPointIn(p) Then
    Set gFeedback = New DragFeedback
    gFeedback.DragStart Map1.Extent, Map2, x, y
  End If

End Sub


Private Sub Map2_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  If Not gFeedback Is Nothing Then
    Map1.Extent = gFeedback.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 gFeedback Is Nothing Then
    gFeedback.DragFinish x, y
    Set gFeedback = Nothing
  End If
End Sub


Private Sub Timer1_Timer()
  If Not (gZoomingIn Or gZoomingOut) Then Exit Sub
  
  Dim r As Rectangle
  Set r = Map1.Extent
  Dim scaleFactor As Double
  scaleFactor = IIf(gZoomingIn, 0.75, 1.25)
  r.ScaleRectangle scaleFactor
  Map1.Extent = r
End Sub