ESRI ArcGIS应用与开发用AO如何实现鹰眼？||做专业的GIS技术交流论坛

wavvylia 路人甲注册日期2003-07-28 发帖数384 QQ 铜币555枚威望0点贡献值0点银元0个加关注写私信	阅读：2950回复：4 用AO如何实现鹰眼？楼主^# 更多只看楼主倒序阅读发布于：2004-11-07 01:32 郁闷中，如何实现鹰眼？那个兄弟指点一下！
	喜欢0 评分0 最新喜欢：举报回复

wrbwf 路人甲注册日期2003-12-01 发帖数944 QQ 铜币2516枚威望0点贡献值0点银元0个加关注写私信	1楼^# 发布于：2004-11-07 15:50 期待ing!
	举报回复(0) 喜欢(0) 评分

wlh_jimmy

路人甲

注册日期2004-02-02
发帖数66
QQ309588724
铜币363枚
威望0点
贡献值0点
银元0个

加关注写私信

2楼^#

发布于：2004-11-08 16:56

## Íâ²¿
Private m_OverViewRenderer As IFeatureRenderer '## Ó¥ÑÛµÄäÖÈ¾ÊôÐÔ½Ó¿Ú£¬Í¨¹ýÀàÊôÐÔµÃµ½ ##
'##'## ÄÚ²¿
Private m_MapActiveView As IActiveView '## Íâ²¿MapControlµÄActiveViewÊôÐÔ½Ó¿Ú£¬Í¨È«¾ÖÀàÊôÐÔµÃµ½ ##
Private m_OverViewActive As IActiveView '## Ó¥ÑÛµÄActiveView ÊôÐÔ½Ó¿Ú##
Private m_SimpleFillSymbol As ISimpleFillSymbol '## Ó¥ÑÛÉÏ¾ØÐÎ¿òµÄSymbolÊôÐÔÉèÖÃ ##
Private m_Envelope As IEnvelope '## Ó¥ÑÛÉÏµÄ¾ØÐÎ¿òµÄ·¶Î§ ##
Private m_MoveEnvelopeFeedback As IMoveEnvelopeFeedback '## ÓÃÓÚÒÆ¶¯¾ØÐÎ¿ò ##
'##'## ÀàµÄ³õÊ¼»¯ ##
Private Sub Class_Initialize()
 Dim pSimpleLineSymbol As ISimpleLineSymbol
 Dim pRgbColor As IRgbColor

 '¶ÔÓ¥ÑÛÖÐµÄ¾ØÐÎ¿òµÄSymbolÊôÐÔ½øÐÐµÄ³õÊ¼»¯
 Set pRgbColor = New RgbColor
 With pRgbColor
 .Red = 255
 .Blue = 0
 .Blue = 0
 End With
 Set pSimpleLineSymbol = New SimpleLineSymbol
 pSimpleLineSymbol.Color = pRgbColor
 pSimpleLineSymbol.Width = 1
 Set m_SimpleFillSymbol = New SimpleFillSymbol
 m_SimpleFillSymbol.Outline = pSimpleLineSymbol
 m_SimpleFillSymbol.Style = esriSFSNull

 Set m_MapActiveView = g_clsGloble.Get_ActiveView

 Set pRgbColor = Nothing
 Set pSimpleLineSymbol = Nothing
End Sub'## ÀàµÄÊÍ·Å ##
Private Sub Class_Terminate()
 Set m_SimpleFillSymbol = Nothing
End Sub'## Ó¥ÑÛÖÐµÄÍ¼²ãµÄäÖÈ¾Ð§¹û£¬ÈôÉèÖÃ´ËÊôÐÔ£¬Ó¥ÑÛÓÐäÖÈ¾Ð§¹û£¬·ñÔòÎÞ£¬½«ÒÔËæ¼´äÖÈ¾ÏÔÊ¾ ##
Public Property Let Set_Renderer(ByVal pFeatureRenderer As IFeatureRenderer)
 Set m_OverViewRenderer = pFeatureRenderer
End Property
'## ÉèÖÃÓ¥ÑÛ½«ÏÔÊ¾ÔÚÄÄ¸ö¶ÔÏóÖÐ£¬¸ù¾ÝHWND¾ä±úÈ·¶¨£¬ÒÔ¼°Ó¥ÑÛÖÐÏÔÊ¾ÄÄ¸öÍ¼²ã£¬ÓÉpFeaturClass²ÎÊýÈ·¶¨ ##
Public Function ConfirmOverViewDisplayObject(ByVal pFeatureCalss As IFeatureClass, ByVal hwnd As Double) As Boolean
 Dim pMap As IMap
 Dim pGeoFeatureLayer As IGeoFeatureLayer

 Set pGeoFeatureLayer = New FeatureLayer
 Set pGeoFeatureLayer.FeatureClass = pFeatureCalss
 If Not m_OverViewRenderer Is Nothing Then
 Set pGeoFeatureLayer.Renderer = m_OverViewRenderer
 End If
 pGeoFeatureLayer.Cached = True
 Set pMap = New Map
 pMap.AddLayer pGeoFeatureLayer
 Set m_OverViewActive = pMap
 m_OverViewActive.Activate hwnd
 SetOverView = True

 Set pGeoFeatureLayer = Nothing
 Set pMap = Nothing
 Set m_OverViewRenderer = Nothing
End Function'## µ±ÉèÖÃÍêÓ¥ÑÛÏÔÊ¾ÔÚÄÄ¸ö¶ÔÏóÖÐºó£¬½«ÔÚÄÇ¸ö¶ÔÏóµÄPaintÊÂ¼þÏÂµ÷ÓÃ´Ë¹ý³Ì£¬ÒÔÏÔÊ¾³öÓ¥ÑÛ ##
Public Sub DrawOverView()
 Dim pTrackCancel As ITrackCancel

 Set pTrackCancel = New CancelTracker
 m_OverViewActive.Draw m_OverViewActive.ScreenDisplay.hDC, pTrackCancel
 Set pTrackCancel = Nothing
End Sub'## ÔÚÓ¥ÑÛÖÐ½«»³öÒ»¸ö¾ØÐÎ¿ò£¬ÒÔÏòÓÃ»§Õ¹ÏÖÓ¥ÑÛÓëMapControlµÄ¶ÔÓ¦¹ØÏµ ##
Public Sub DrawRectangle(ByVal pEnvelope As IEnvelope)
 Dim pOverViewScreen As IScreenDisplay

 Set m_Envelope = pEnvelope
 Set pOverViewScreen = m_OverViewActive.ScreenDisplay
 If (pEnvelope.Height < m_MapActiveView.FullExtent.Height) Then
 m_OverViewActive.PartialRefresh esriViewForeground, Nothing, Nothing
 With pOverViewScreen
 .StartDrawing .hDC, 0
 .UpdateWindow
 .SetSymbol m_SimpleFillSymbol
 .DrawRectangle pEnvelope
 .FinishDrawing
 End With
 ElseIf (pEnvelope.Height >= m_MapActiveView.FullExtent.Height) Then
 m_OverViewActive.PartialRefresh esriViewForeground, Nothing, Nothing
 Set m_Envelope = Nothing
 'With pOverViewScreen
 ' .StartDrawing .hDC, 0
 ' .UpdateWindow
 ' .SetSymbol m_SimpleFillSymbol
 ' .DrawRectangle m_OverViewActive.FullExtent
 ' .FinishDrawing
 'End With
 End If
End Sub'## µ±Êó±êÔÚÓ¥ÑÛÉÏµ¥»÷Ê±£¬ÅÐ¶ÏÊÇ»³öÀ¿ò·¶Î§£¬»¹ÊÇÒÆ¶¯¾ØÐÎ¿ò ##
Public Sub OverView_MouseDown(ByVal button As Integer, ByVal x As Single, ByVal y As Single)
 Dim pPoint As IPoint
 Dim pRubberBand As IRubberBand
 Dim pGeo As IGeometry

 Set pPoint = m_OverViewActive.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y)
 If button = 1 Then 'Êó±êÎª×ó¼ü£¬½«»³ö¾ØÐÎ,ÇÒ½«MapControlÖÐµÄ·¶Î§ÉèÎª´Ë¾ØÐÎ·¶Î§
 Set pRubberBand = New RubberEnvelope
 Set pGeo = pRubberBand.TrackNew(m_OverViewActive.ScreenDisplay, Nothing)
 If Not pGeo.IsEmpty Then ''Èç¹û¾ØÐÎ²»Îª¿Õ£¬»³ö¾ØÐÎ¿ò£¬ÇÒÉèÖÃMapControl·¶Î§
 m_MapActiveView.Extent = pGeo
 m_MapActiveView.Refresh
 DrawRectangle m_MapActiveView.Extent
 Else ''ÈôÎª¿Õ£¬ÔòMapControl·¶Î§´¦ÓÚÈ«¾°×´Ì¬£¬Çå³ý¾ØÐÎ¿ò
 m_MapActiveView.Extent = m_MapActiveView.FullExtent
 m_MapActiveView.Refresh
 m_OverViewActive.PartialRefresh esriViewForeground, Nothing, Nothing
 Set m_Envelope = Nothing
 End If
 Else 'Êó±êÎªÓÒ¼üÊ±£¬½«ÒÆ¶¯¾ØÐÎ
 If Not m_Envelope Is Nothing Then
 Set m_MoveEnvelopeFeedback = New MoveEnvelopeFeedback
 Set m_MoveEnvelopeFeedback.Display = m_OverViewActive.ScreenDisplay
 m_MoveEnvelopeFeedback.Start m_Envelope, pPoint
 End If
 End If

 Set pRubberBand = Nothing
End Sub'## µ±Êó±êÔÚÓ¥ÑÛÉÏÒÆ¶¯Ê±£¬ÅÐ¶ÏÊÇ·ñÔÚ¾ØÐÎ¿òÖ®ÉÏ£¬ÔÚÖ®ÉÏµ¥»÷ÓÒ¼üÊ±£¬¿ªÊ¼ÒÆ¶¯¾ØÐÎ ##
Public Sub OverView_MouseMove(ByVal x As Single, ByVal y As Single)
 Dim pPoint As IPoint

 Set pPoint = m_OverViewActive.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y)
 If Not m_MoveEnvelopeFeedback Is Nothing Then
 m_MoveEnvelopeFeedback.MoveTo pPoint
 End If
End Sub'## µ±Êó±êµ¯ÆðÊ±£¬½«¾ØÐÎÒÆ¶¯Êó±êÎ»ÖÃ
Public Sub OverView_MouseUp(ByVal x As Single, ByVal y As Single)
 Dim pEnv As IEnvelope
 If Not m_MoveEnvelopeFeedback Is Nothing Then
 Set pEnv = m_MoveEnvelopeFeedback.Stop
 DrawRectangle pEnv
 m_MapActiveView.Extent = pEnv
 m_MapActiveView.Refresh
 Set m_MoveEnvelopeFeedback = Nothing
 End If
End Sub

举报回复喜欢评分

wavvylia 路人甲注册日期2003-07-28 发帖数384 QQ 铜币555枚威望0点贡献值0点银元0个加关注写私信	3楼^# 发布于：2004-11-08 19:20 多谢兄弟,真是个大好人,先看看!
	举报回复(0) 喜欢(0) 评分

wlh_jimmy 路人甲注册日期2004-02-02 发帖数66 QQ309588724 铜币363枚威望0点贡献值0点银元0个加关注写私信	4楼^# 发布于：2004-11-09 16:19 <P>不用谢，多多交流，QQ：309588724</P>
	举报回复(0) 喜欢(0) 评分

您需要登录后才可以回帖，登录或者注册

用AO如何实现鹰眼？

最新喜欢：