mod_maptip.bas

ArcEngine 这是基于AE组件的源代码

Attribute VB_Name = "Mod_MapTip"
Option Explicit

Public m_pX As Single      ' current x position
Public m_pY As Single      ' current y position
Public m_pLastX As Single  ' x position when timer starts
Public m_pLastY As Single  ' y position when timer starts

Public m_pFLayer As IFeatureLayer  ' layer to search

Private Type POINTAPI
        x As Long
        y As Long
End Type
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Public Sub ShowTipText(text As String)
  'set the caption
  frmMapTips.lblToolTip.Caption = text
  frmMapTips.lblToolTip.Left = 50
  frmMapTips.lblToolTip.Top = 0
  
  Dim pT As POINTAPI, lResult As Long
  lResult = GetCursorPos(pT)
  
  ' position the picture
  frmMapTips.picToolTip.Width = frmMapTips.lblToolTip.Width + 50
  frmMapTips.Left = pT.x * Screen.TwipsPerPixelX + 50
  frmMapTips.Top = pT.y * Screen.TwipsPerPixelY - frmMapTips.Height - 50
  frmMapTips.Width = frmMapTips.picToolTip.Width + 50
  frmMapTips.Visible = True
  frmMapTips.picToolTip.Visible = True
End Sub

Public Sub OnStartMapTip()
  Dim pMap As IMap, lLoop As Long
  Set pMap = frmMDIMap.MapControl.ActiveView.FocusMap
  Set m_pFLayer = Nothing
  Set m_pFLayer = m_pCurrentLayer
  'If the target layer is not found, then unset the tool
  If m_pFLayer Is Nothing Then
    MsgBox "目标图层不存在或不存在图层，请选择."
    Exit Sub
  End If
  'Initialize everything
  frmMapTips.Show
 
 
  frmMapTips.Visible = False
  frmMapTips.picToolTip.Visible = False
  frmMapTips.picToolTip.BackColor = vbInfoBackground
  
  frmMapTips.lblToolTip.ForeColor = vbInfoText
  frmMapTips.lblToolTip.AutoSize = True
  frmMapTips.lblToolTip.BackStyle = 0 ' transparent
End Sub

Public Sub OnStopMapTip()
   Unload frmMapTips
End Sub


Private Sub ITool_OnMouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal y As Long)
  m_pX = x
  m_pY = y
  If rmMapTips.tmrToolTip.Interval = 0 Then  ' start the timer
    m_pLastX = x
    m_pLastY = y
    rmMapTips.tmrToolTip.Interval = 100
  Else  ' hide the tooltip
    frmMapTips.Visible = False
    frmMapTips.picToolTip.Visible = False
  End If
End Sub


Private Sub m_pTimer_Timer()
  If m_pX = m_pLastX And m_pY = m_pLastY Then
    ' mouse didn't move
    rmMapTips.tmrToolTip.Interval = 0
    Dim pFilter As ISpatialFilter, pFeatCursor As IFeatureCursor, pPt As IPoint
    Dim pTopo As ITopologicalOperator, pBufGeom As IGeometry, pApp As IMxApplication
    Set pApp = m_pApp
    Set pPt = pApp.Display.DisplayTransformation.ToMapPoint(m_pX, m_pY)
    Set pTopo = pPt
    Set pBufGeom = pTopo.Buffer(10)
    
    Set pFilter = New SpatialFilter
    Set pFilter.Geometry = pBufGeom
    pFilter.SpatialRel = esriSpatialRelIntersects
    Set pFeatCursor = m_pFLayer.Search(pFilter, False)
    Dim pFeat As IFeature
    Set pFeat = pFeatCursor.NextFeature
    If pFeat Is Nothing Then
      ' nothing at this location
      frmMapTips.picToolTip.Visible = False
    Else
      ' show the toolTip
      Dim lIndex1 As Long, lIndex2 As Long, sString As String
      lIndex1 = pFeat.Fields.FindField("TAG")  '<----- CHANGE THIS VALUE
      lIndex2 = pFeat.Fields.FindField("PIP_MATERIAL_CD")  '<----- CHANGE THIS VALUE
      sString = pFeat.Value(lIndex1) & Chr(13) & lIndex2
      ShowTipText sString
    End If
  Else ' start over at the current location
    m_pLastX = m_pX
    m_pLastY = m_pY
  End If
End Sub