dragfeedback.cls

本程序利用vb实现了地理信息系统中空间分析的各种方法

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 = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False

' 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