在鹰眼指示窗口中拖动方框
类模块dragfeedback定义
' WinAPI function declarations and constants
Private Declare Function GdiRectangle Lib "gdi32" Alias "Rectangle" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function SetROP2 Lib "gdi32" (ByVal hdc As Long, ByVal nDrawMode As Long) As Long
Private Const R2_NOTXORPEN = 10
' glogal map
Dim m_map As MapObjects2.Map
' variables that keep track of moving the indicator
Dim m_hDC As Long ' a DC to draw into
Dim m_hWnd As Long ' window handle
Dim m_xMin As Integer, m_yMin As Integer ' drag indicator
Dim m_xMax As Integer, m_yMax As Integer ' drag indicator
Dim m_xPrev As Integer ' click location
Dim m_yPrev As Integer ' click location
Function DragFinish(x As Single, y As Single) As MapObjects2.Rectangle
GdiRectangle m_hDC, m_xMin, m_yMin, m_xMax, m_yMax
ReleaseDC m_hWnd, m_hDC
' return the rectangle
Dim r As New MapObjects2.Rectangle
PixelsRectToMap m_xMin, m_yMin, m_xMax, m_yMax, r
Set DragFinish = r
End Function
Sub DragMove(x As Single, y As Single)
' convert to pixels
xNext = m_map.Parent.ScaleX(x, vbTwips, vbPixels)
yNext = m_map.Parent.ScaleY(y, vbTwips, vbPixels)
GdiRectangle m_hDC, m_xMin, m_yMin, m_xMax, m_yMax
m_xMin = m_xMin + (xNext - m_xPrev)
m_xMax = m_xMax + (xNext - m_xPrev)
m_yMin = m_yMin + (yNext - m_yPrev)
m_yMax = m_yMax + (yNext - m_yPrev)
GdiRectangle m_hDC, m_xMin, m_yMin, m_xMax, m_yMax
m_xPrev = xNext
m_yPrev = yNext
End Sub
Sub DragStart(rect As MapObjects2.Rectangle, Map As MapObjects2.Map, x As Single, y As Single)
Set m_map = Map
' initialize the hwnd and hdc variables
m_hWnd = m_map.hwnd
m_hDC = GetDC(m_hWnd)
SetROP2 m_hDC, R2_NOTXORPEN ' raster op for inverting
MapRectToPixels rect, m_xMin, m_yMin, m_xMax, m_yMax
' draw the rectangle
GdiRectangle m_hDC, m_xMin, m_yMin, m_xMax, m_yMax
' remember the click position
' convert to pixels
m_xPrev = m_map.Parent.ScaleX(x, vbTwips, vbPixels)
m_yPrev = m_map.Parent.ScaleY(y, vbTwips, vbPixels)
End Sub
Private Sub MapRectToPixels(r As MapObjects2.Rectangle, xMin As Integer, yMin As Integer, xMax As Integer, yMax As Integer)
Dim p As New Point
Dim xc As Single, yc As Single
p.x = r.Left
p.y = r.Top
m_map.FromMapPoint p, xc, yc
' convert to pixels
xMin = m_map.Parent.ScaleX(xc, vbTwips, vbPixels)
yMin = m_map.Parent.ScaleY(yc, vbTwips, vbPixels)
p.x = r.Right
p.y = r.Bottom
m_map.FromMapPoint p, xc, yc
' convert to pixels
xMax = m_map.Parent.ScaleX(xc, vbTwips, vbPixels)
yMax = m_map.Parent.ScaleY(yc, vbTwips, vbPixels)
End Sub
Sub PixelsRectToMap(xMin As Integer, yMin As Integer, xMax As Integer, yMax As Integer, r As MapObjects2.Rectangle)
Dim xc As Single, yc As Single
' convert to twips
xc = m_map.Parent.ScaleX(xMin, vbPixels, vbTwips)
yc = m_map.Parent.ScaleY(yMin, vbPixels, vbTwips)
Set p = m_map.ToMapPoint(xc, yc)
r.Left = p.x
r.Top = p.y
' convert to twips
xc = m_map.Parent.ScaleX(xMax, vbPixels, vbTwips)
yc = m_map.Parent.ScaleY(yMax, vbPixels, vbTwips)
Set p = m_map.ToMapPoint(xc, yc)
r.Right = p.x
r.Bottom = p.y
End Sub
窗体代码：
Option Explicit
Dim g_feedback As dragfeedback
Private Sub Map2_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
'将点击转换为Map2上的点对象；
Dim p As Point
Set p = Map2.ToMapPoint(x, y)
'如果点击发生在方框内，开始拖动；
If Map1.Extent.IsPointIn(p) Then
Set g_feedback = New dragfeedback
g_feedback.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 g_feedback Is Nothing Then
g_feedback.DragMove x, y
End If
End Sub
'拖动完成，并在Map1中显示新位置；
Private Sub Map2_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Not g_feedback Is Nothing Then
Map1.Extent = g_feedback.DragFinish(x, y)
Set g_feedback = Nothing
End If
End Sub
'左键放大，右键缩小；
Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim r As MapObjects2.Rectangle
If Button = vbLeftButton Then
Set Map1.Extent = Map1.TrackRectangle
ElseIf Button = vbRightButton Then
Set r = Map1.Extent
r.ScaleRectangle 2
Map1.Extent = r
End If
End Sub
'使Map2和Map1联动；
Private Sub Map1_AfterLayerDraw(ByVal Index As Integer, ByVal canceled As Boolean, ByVal hdc As stdole.OLE_HANDLE)
If Index = 0 Then
Map2.TrackingLayer.Refresh True
End If
End Sub
'在Map2上画红色指示框；
Private Sub Map2_AfterTrackingLayerDraw(ByVal hdc As stdole.OLE_HANDLE)
Dim sym As New Symbol
sym.OutlineColor = moRed
sym.Size = 2
sym.Style = moTransparentFill
Map2.DrawShape Map1.Extent, sym
End Sub
Private Sub Form_Load()
Dim dc As New DataConnection
Dim layer As MapLayer
dc.Database = App.Path + "\..\" + "world"
If Not dc.Connect Then
MsgBox "在指定的文件夹下没找到图层数据文件！"
End
End If
Set layer = New MapLayer
Set layer.GeoDataset = dc.FindGeoDataset("country")
layer.Symbol.Color = moYellow
Map1.Layers.Add layer
Set layer = New MapLayer
Set layer.GeoDataset = dc.FindGeoDataset("cities")
layer.Symbol.Color = moRed
Map1.Layers.Add layer
Map1.Refresh
Set layer = New MapLayer
Set layer.GeoDataset = dc.FindGeoDataset("country")
layer.Symbol.Color = moYellow
Map2.Layers.Add layer
Map2.Refresh
End Sub