在Scene或Globe中绘制橡皮条线的工具，其中wsUtilityBaseTool是我自己封装的基类，
大家只需要把它替换成AE的BaseTool，把其中相应的代码放在相应的函数中,然后再进行一些简单的修改就好了
附上VB.Net源码
Imports ESRI.ArcGIS.Analyst3D
Imports ESRI.ArcGIS.Carto
Imports ESRI.ArcGIS.Controls
Imports ESRI.ArcGIS.Display
Imports ESRI.ArcGIS.Geometry
Imports ESRI.ArcGIS.GlobeCore
Imports ESRI.ArcGIS.SystemUI
Public Class wsSceneDrawLine
Inherits wsUtilityBaseTool
Private Declare Function Polygon Lib "gdi32" (ByVal hDC As Integer, ByVal lpPoint As Integer, ByVal nCount As Integer) As Integer
Private Declare Function SetCapture Lib "USER32" (ByVal hWnd As Integer) As Integer
Private Declare Function GetCapture Lib "USER32" () As Integer
Private Declare Function ReleaseCapture Lib "USER32" () As Integer
Private Declare Function GetCursorPos Lib "USER32" (ByVal lpPoint As PointAPI) As Integer
Private Declare Function SetCursor Lib "USER32" (ByVal hCursor As Integer) As Integer
Private Declare Function GetClientRect Lib "USER32" (ByVal hWnd As Integer, ByVal lpRect As rect) As Integer
Private Declare Function GetWindowRect Lib "USER32" (ByVal hWnd As Integer, ByVal lpRect As rect) As Integer
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Integer, ByVal nWidth As Integer, ByVal crColor As Integer) As Integer
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Integer) As Integer
Private Declare Function GetROP2 Lib "gdi32" (ByVal hDC As Integer) As Integer
Private Declare Function SetROP2 Lib "gdi32" (ByVal hDC As Integer, ByVal nDrawMode As Integer) As Integer
Private Declare Function Rectangle Lib "gdi32" (ByVal hDC As Integer, ByVal X1 As Integer, ByVal Y1 As Integer, ByVal X2 As Integer, ByVal Y2 As Integer) As Integer
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Integer, ByVal hObject As Integer) As Integer
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Integer) As Integer
Private Declare Function Polyline Lib "gdi32" (ByVal hDC As Integer, ByVal lpPoint() As PointAPI, ByVal nCount As Integer) As Integer
Private Declare Function CreatePolygonRgn Lib "gdi32" (ByVal lpPoint As Integer, ByVal nCount As Integer, ByVal nPolyFillMode As Integer) As Integer
Private Structure rect
Dim Left As Integer
Dim Top As Integer
Dim Right As Integer
Dim Bottom As Integer
End Structure
Private Structure PointAPI
Dim x As Integer
Dim y As Integer
End Structure
Private m_pSceneHookhelper As ISceneHookHelper
Private m_pGlobeHookhelper As IGlobeHookHelper
Private m_bInUse As Boolean
Private m_Pen As Long, m_Brush As Long
Private m_lDrawMode As Long
Private m_pUserLine As IPointCollection
Private m_pGeoLine As IPointCollection
Private m_MovePoint_Old As IPoint '当前点
Private m_pScene As IScene
Private m_pSceneViewer As ISceneViewer
Public Sub New()
MyBase.New()
MyBase.Tool = New ControlsScenePanTool
MyBase.m_Caption = "画线"
MyBase.m_ToolTip = "画线"
MyBase.m_Name = "画线"
MyBase.m_Message = "画线"
m_pSceneHookHelper = New SceneHookHelper
End Sub
Public Overrides Sub OnCreate(ByVal hook As Object)
m_pSceneHookhelper = New SceneHookHelper
m_pSceneHookhelper.Hook = hook
m_pSceneViewer = m_pSceneHookhelper.ActiveViewer
m_pScene = m_pSceneHookhelper.Scene
If m_pScene Is Nothing Then
m_pGlobeHookhelper = New GlobeHookHelper
m_pGlobeHookhelper.Hook = hook
m_pSceneViewer = m_pGlobeHookhelper.ActiveViewer
m_pScene = m_pGlobeHookhelper.Globe
End If
End Sub
Public Overrides ReadOnly Property Enabled() As Boolean
Get
If (m_pSceneHookhelper.Scene Is Nothing) Then
Return False
Else
Return True
End If
End Get
End Property
Public Overrides Sub OnMouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Integer, ByVal Y As Integer)
Dim pGeoPoint As IPoint
pGeoPoint = GetGeoPointByScene(m_pScene, X, Y, m_pUserLine)
If pGeoPoint Is Nothing Then Exit Sub
m_bInUse = True
Dim pStartPoint As IPoint
pStartPoint = New Point
pStartPoint.PutCoords(X, Y)
m_pUserLine.AddPoint(pStartPoint)
m_pGeoLine.AddPoint(pGeoPoint)
m_Pen = CreatePen(0, 2, 0) 'A solid, width of 2 black pen
m_Brush = GetStockObject(5) 'A hollow brush
m_lDrawMode = GetROP2(m_pSceneViewer.hDC)
SelectObject(m_pSceneViewer.hDC, m_Pen)
SelectObject(m_pSceneViewer.hDC, m_Brush)
SetROP2(m_pSceneViewer.hDC, 14)
SetCapture(m_pSceneViewer.hWnd)
End Sub
Public Overrides Sub OnMouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Integer, ByVal Y As Integer)
If Not m_bInUse Then Exit Sub
DrawLine(X, Y)
End Sub
Public Overrides Sub OnMouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Integer, ByVal Y As Integer)
End Sub
Public Overrides Sub OnClick()
MyBase.OnClick()
'Not implemented
m_pUserLine = New Polyline
m_pGeoLine = New Polyline
End Sub
Public Overrides Sub OnDblClick()
MyBase.OnDblClick()
If Not m_bInUse Then Exit Sub
If GetCapture = m_pSceneViewer.hWnd Then
ReleaseCapture()
End If
m_MovePoint_Old = Nothing
m_pUserLine = New Polyline
m_pGeoLine = New Polyline
m_pSceneViewer.Redraw(True)
DeleteObject(m_Pen)
DeleteObject(m_Brush)
SetROP2(m_pSceneViewer.hDC, m_lDrawMode)
m_bInUse = False
End Sub
Public Overrides Sub OnKeyDown(ByVal keyCode As Integer, ByVal shift As Integer)
MyBase.OnKeyDown(keyCode, shift)
If m_bInUse = True Then
If keyCode = 0 Then
m_pSceneViewer.Redraw(True)
m_MovePoint_Old = Nothing
m_pUserLine = New Polyline
m_pGeoLine = New Polyline
'GDI calls to delete pen and brush objects
DeleteObject(m_Pen)
DeleteObject(m_Brush)
'GDI call to set device to the original draw mode
SetROP2(m_pSceneViewer.hDC, m_lDrawMode)
ReleaseCapture()
m_bInUse = False
End If
End If
End Sub
Public Sub DrawLine(ByVal x As Long, ByVal y As Long)
Dim pPtNums As Long
pPtNums = m_pUserLine.PointCount
Dim Pts() As PointAPI
ReDim Pts(pPtNums) 'As PointAPI
Dim i As Long
Dim pPoint As IPoint
For i = 0 To pPtNums - 1
pPoint = m_pUserLine.Point(i)
Pts(i).x = pPoint.X : Pts(i).y = pPoint.Y
Next
If Not m_MovePoint_Old Is Nothing Then
Pts(pPtNums).x = m_MovePoint_Old.X : Pts(pPtNums).y = m_MovePoint_Old.Y
Polyline(m_pSceneViewer.hDC, Pts, pPtNums + 1)
End If
Pts(pPtNums).x = x : Pts(pPtNums).y = y
Polyline(m_pSceneViewer.hDC, Pts, pPtNums + 1)
m_MovePoint_Old = New Point
m_MovePoint_Old.PutCoords(x, y)
End Sub
Private Function GetGeoPointByScene(ByVal pScene As IScene, ByVal x As Long, ByVal y As Long, Optional ByVal CheckPointDou As IPointCollection = Nothing) As IPoint
Dim i As Long
Dim pPoint As IPoint
If Not CheckPointDou Is Nothing Then
For i = 0 To CheckPointDou.PointCount - 1
pPoint = CheckPointDou.Point(i)
If pPoint.X = x And pPoint.Y = y Then
Return Nothing
Exit Function
End If
Next
End If
Return LocatePoint(pScene, x, y)
End Function
Private Function LocatePoint(ByVal pScene As IScene, ByVal x As Long, ByVal y As Long) As IPoint
If TypeOf pScene Is IGlobe Then
Dim pGlobe As IGlobe
pGlobe = pScene
Return GlobeToPoint(pGlobe.GlobeDisplay, x, y, True)
ElseIf TypeOf pScene Is IScene Then
Return XYToPoint(pScene.SceneGraph, x, y)
Else
Return Nothing
End If
End Function
Private Function GlobeToPoint(ByVal pGlobeDisplay As IGlobeDisplay, ByVal dx As Long, ByVal dy As Long, ByVal bMaxResolution As Boolean, Optional ByVal pOffset As Double = 0) As IPoint
On Error GoTo errhandler
Dim pPoint As IPoint = Nothing
Dim objectOwner As stdole.IUnknown = Nothing
Dim objectObject As stdole.IUnknown = Nothing
pGlobeDisplay.Locate(pGlobeDisplay.ActiveViewer, dx, dy, False, True, pPoint, objectOwner, objectObject)
If pPoint Is Nothing Then
Return Nothing
Exit Function
Else
If pPoint.IsEmpty Then
Return Nothing
Exit Function
End If
End If
pPoint.Z = pPoint.Z * 1000
Return pPoint
Exit Function
errhandler:
End Function
Private Function XYToPoint(ByVal pSceneGraph As SceneGraph, ByVal x As Long, ByVal y As Long) As IPoint
Dim pSG As ISceneGraph
pSG = pSceneGraph
Dim pViewer As ISceneViewer
pViewer = pSG.ActiveViewer
Dim pOwner As stdole.IUnknown = Nothing
Dim pObject As stdole.IUnknown = Nothing
Dim pPoint As IPoint = Nothing
pSG.Locate(pViewer, x, y, esriScenePickMode.esriScenePickGeography, True, pPoint, pOwner, pObject)
pOwner = Nothing
pObject = Nothing
Return pPoint
End Function
End Class
posted on 2008-05-28 17:50
王者之魂 阅读(465)
评论(0) 编辑 收藏