dragfeedback.cls

地理信息系统工程案例精选程序,本书所有案例均需要单独配置

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "DragFeedback"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'WinAPI函数声明和常量声明
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

'地图
Dim m_map As MapObjects2.map

'与跟踪地图显示范围有关变量
Dim m_hDC As Long         'DC
Dim m_hWnd As Long        'window 句柄
Dim m_xMin As Integer, m_yMin As Integer  '拖放相关变量
Dim m_xMax As Integer, m_yMax As Integer  '拖放相关变量
Dim m_xPrev As Integer       '鼠标单击位置
Dim m_yPrev As Integer       '鼠标单击位置

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
  
  '返回矩形
  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)
  '红色矩形框拖放中
  
  '转换到Pixel单位
  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
  '初始化window句柄和DC
  m_hWnd = m_map.hwnd
  m_hDC = GetDC(m_hWnd)
  SetROP2 m_hDC, R2_NOTXORPEN
    
  MapRectToPixels rect, m_xMin, m_yMin, m_xMax, m_yMax
  
  '画矩形框
  GdiRectangle m_hDC, m_xMin, m_yMin, m_xMax, m_yMax
  
  '记下单击位置 remember the click position
  '转换到Pixel单位
  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)
  '将地图上的矩形转换为以Pixel为单位
  Dim p As New MapObjects2.POINT
  Dim xc As Single, yc As Single
  
  p.x = r.Left
  p.Y = r.Top
  m_map.FromMapPoint p, xc, yc
  
  '转换到Pixel单位
  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
  
  '转换到Pixel单位
  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)
  '将以Pixel为单位的矩形转换到地图上
  Dim xc As Single, yc As Single
  
  '转换到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

  '转换到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