前往小程序,Get更优阅读体验!
立即前往
首页
学习
活动
专区
工具
TVP
发布
社区首页 >专栏 >mapx实现热点效果

mapx实现热点效果

作者头像
用户1075292
发布2018-01-23 14:25:09
5750
发布2018-01-23 14:25:09
举报
文章被收录于专栏:听雨堂听雨堂听雨堂

        当鼠标移动到图元上方时,标注改变样式(变色,加下划线等),移开后还原。通过vb+mapx基本实现这个效果,但由于mapx在label进行变化时的刷新很明显,达不到希望的效果。把代码留下。

Private Sub Map1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
     'StatusBar1.Panels(1).Text = X & "," & Y
     Dim Lon As Double
     Dim lat As Double
     Dim fs As Features
     Dim pnt As New Point
     Dim lb As MapXLib.Label  '±ê×¢¶ÔÏó
     Map1.ConvertCoord x, y, Lon, lat, miScreenToMap
     pnt.Set Lon, lat
     Set fs = Map1.Layers(PLayer).SearchAtPoint(pnt)
     If fs.Count > 0 Then     '¶¨Î»¶ÔÏó
       If Not curftr Is Nothing Then If curftr = fs.Item(1) Then Exit Sub  '·ÀÖ¹Öظ´ÉèÖÃ
       Set lb = GetLabel(fs.Item(1).FeatureKey, Map1.Layers(PLayer).Labels)
       If Not lb Is Nothing Then             'Ϊ±ê×¢¼ÓÏ»®ÏßЧ¹û
         lb.Style.TextFont.Underline = True
         Set curftr = fs.Item(1)
         'fs.Item(1).Update
       End If
       Map1.MousePointer = miCustomCursor    'Êó±êÑùʽ
     Else
       If Not curftr Is Nothing Then  '»¹Ô­Ï»®Ïß״̬
         Set lb = GetLabel(curftr.FeatureKey, Map1.Layers(PLayer).Labels)
         lb.Style.TextFont.Underline = False
         'curftr.Update
         Set curftr = Nothing
         Frame1.Visible = False   'Òþ²Øµ¯³ö²Ëµ¥
       End If
       Map1.MousePointer = miArrowCursor
     End If
 End Sub
本文参与 腾讯云自媒体分享计划,分享自作者个人站点/博客。
原始发表:2008-05-13 ,如有侵权请联系 cloudcommunity@tencent.com 删除

本文分享自 作者个人站点/博客 前往查看

如有侵权,请联系 cloudcommunity@tencent.com 删除。

本文参与 腾讯云自媒体分享计划  ,欢迎热爱写作的你一起参与!

评论
登录后参与评论
0 条评论
热度
最新
推荐阅读
领券
问题归档专栏文章快讯文章归档关键词归档开发者手册归档开发者手册 Section 归档