?? 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
'WindowsAPI函數(shù)申明及常量
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 '繪圖句柄
Dim m_hWnd As Long '窗口句柄
Dim m_xMin As Integer, m_yMin As Integer
Dim m_xMax As Integer, m_yMax As Integer
Dim m_xPrev As Integer '鼠標(biāo)單擊的位置
Dim m_yPrev As Integer '鼠標(biāo)單擊的位置
Function DragFinish(x As Single, y As Single) As MapObjects2.Rectangle
'拖拽操作結(jié)束
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)
'拖拽進(jìn)行中
'轉(zhuǎn)換為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
'初始化窗口句柄和繪圖句柄
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
'記下鼠標(biāo)位置
'轉(zhuǎn)為為以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)
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
'將坐標(biāo)轉(zhuǎn)換為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
'將坐標(biāo)轉(zhuǎn)換為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)
Dim xc As Single, yc As Single
'將坐標(biāo)轉(zhuǎn)換為Pixel為單位
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
'將坐標(biāo)轉(zhuǎn)換為Pixel為單位
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
?? 快捷鍵說明
復(fù)制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -