maptip.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 = "clsMapTip"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'===========================================　跟踪类模块说明　===========================================
'
'说　　明：此功能模块是专门用来实现属性跟踪功能的，各属性、方法要配合使用才能正常工作。
'                   其中，DoSearch()和ShowTipText()为内部私有函数，
'                        使用者不要进行任何的调用操作。
'操作方法：首 先，要初始化类模块，调用
'                Initialize(frm As Form, map As SuperMap, tmr As Timer, pic As PictureBox, lbl As Label)
'                初始化窗体和控件对象，调用
'                SetLayer(layer As soLayer, ByVal fld As String)初始化数据集和字段；
'         再 次，把Timer()函数放在相应的Timer控件的Timer()事件下，
'                把MouseMove(ByVal x As Single, ByVal y As Single)放在SuperMap控件的MouseMove事件中。
'         其它的控制可以通过对Timer控件的Enable属性和Check控件的Value属性进行是否开始或结束跟踪的操作。
'
'========================================================================================================
Option Explicit
Public bTracking As Boolean        '是否进行跟踪Tip
Private fX As Single             '当前鼠标x坐标
Private fY As Single             '当前鼠标y坐标
Private fLastX As Single         'Timer开始时的x坐标
Private fLastY As Single         'Timer开始时的y坐标

Private frmTip As Form            '跟踪哪个Form，这一设置关系到Tip框的定位
Private objSuperMap As SuperMap         '跟踪哪个SuperMap控件
Private objTimer As Timer          '用来跟踪的计时器
Private objPicture As PictureBox   '用来放置跟踪文本显示的Label控件的Picture控件
Private m_label As Label          '用来放置跟踪文本显示的Label控件

Private m_layer As soLayer        '跟踪哪个图层
Private m_strFieldName As String  '显示哪个字段的值

Private Function DoSearch() As soRecordset '本函数用来根据当前鼠标的位置用QueryEx方法查找所在的几何对象
      Dim objRecordset As soRecordset  '存放查找结果的记录集
      Dim objGeoPoint As New soGeoPoint '用于查找的点，临时构造而成，所以用New
      Dim objDt As soDatasetVector '被查找的矢量数据集
      Dim dTolerance As Double '查找点是否和在点或线上的容限值
      Dim objRect As soRect    '记录当前地图的Bounds
      
      '构造查找点，必须进行坐标转换
      objGeoPoint.x = objSuperMap.PixelToMapX(frmTip.ScaleX(fX, vbTwips, vbPixels))
      objGeoPoint.y = objSuperMap.PixelToMapY(frmTip.ScaleY(fY, vbTwips, vbPixels))
      
      '获取被查找的数据集，并进行查找
      Set objDt = m_layer.Dataset
      If objDt.Type = scdRegion Then '如果是面数据集，直接点所在的面
          Set objRecordset = objDt.QueryEx(objGeoPoint, scsPointInPolygon, "")
      ElseIf (objDt.Type = scdPoint) Or (objDt.Type = scdLine) Then  '如果是点和线，则根据容限来查找
          Set objRect = objSuperMap.ViewBounds
          If objRect.Height / objRect.Width > 1 Then
              dTolerance = objRect.Height / 500
          Else
              dTolerance = objRect.Width / 500
          End If
          Set objRecordset = objDt.QueryByDistance(objGeoPoint, dTolerance, "")
      End If
      
      Set DoSearch = objRecordset  '返回查询结果
      Set objRecordset = Nothing
      Set objGeoPoint = Nothing
      Set objDt = Nothing
      Set objRect = Nothing
 End Function

Public Sub Initialize(frm As Form, map As SuperMap, tmr As Timer, pic As PictureBox, lbl As Label)  '初始化
      Set frmTip = frm
      Set objSuperMap = map
      Set objTimer = tmr
      Set objPicture = pic
      Set m_label = lbl
      
      objPicture.Visible = False
      objPicture.BackColor = vbInfoBackground
      
      m_label.ForeColor = vbBlue
      m_label.AutoSize = True
      m_label.BackStyle = 0 'Label背景透明
      fLastX = 0
      fLastY = 0
End Sub

Public Sub MouseMove(ByVal x As Single, ByVal y As Single) '处理鼠标移动时的过程
      If bTracking = False Then Exit Sub
      If objSuperMap.Layers.Count = 0 Then
            Exit Sub
      End If
      objTimer.Enabled = True
      fX = x
      fY = y
      If objTimer.Interval < 10 Then  'Timer处于停止状态，鼠标移动时应启动Timer
            fLastX = x
            fLastY = y
            objTimer.Interval = 50
      Else
            objPicture.Visible = False
      End If
End Sub

Public Sub SetLayer(layer As soLayer, ByVal fld As String)  '设置被跟踪的图层
      Set m_layer = layer
      m_strFieldName = fld
End Sub

Private Sub ShowTipText(ByVal text As String) '显示TipText
  '设置显示的内容
  m_label.Caption = text
  m_label.Left = 50
  m_label.Top = 0
  
  '设置显示的位置
  objPicture.Left = objSuperMap.Left + fX
  objPicture.Top = objSuperMap.Top + fY + 290
  objPicture.Width = m_label.Width + 100
  objPicture.Height = 250
  
  If objPicture.Left + objPicture.Width > objSuperMap.Left + objSuperMap.Width Then
     objPicture.Left = objSuperMap.Left + objSuperMap.Width - objPicture.Width
  End If
End Sub

Public Sub Timer()
   If bTracking = False Then Exit Sub
      Dim objRecordset  As soRecordset
      If fX = fLastX And fY = fLastY Then
      '条件满足，表明鼠标没在移动，停止Timer,并执行一次查找
            objTimer.Interval = 0
            Set objRecordset = DoSearch()
            If objRecordset Is Nothing Then
                  objPicture.Visible = False
            ElseIf objRecordset.RecordCount < 1 Then
                  objPicture.Visible = False
            Else
                  objPicture.Visible = True
                  ShowTipText IIf(IsNull(objRecordset.GetFieldValue(m_strFieldName)), "NULL", objRecordset.GetFieldValue(m_strFieldName))
            End If
      Else '条件不满足，隐藏picture
            fLastX = fX
            fLastY = fY
            objPicture.Visible = False
      End If

      Set objRecordset = Nothing
End Sub