如何二维地图Map选择范围，加到三维ArcScene控件中显示、渲染（源代码）
一、 在arcMapControl_OnMouseDown事件中增加：
Dim objEnvelope As IEnvelope
Dim pScreenDisplay As IDisplay
Dim pRubberband As IRubberBand
Set m_pActiveView = arcMapControl.ActiveView.FocusMap
Set pScreenDisplay = arcMapControl.ActiveView.ScreenDisplay
Set pRubberband = New RubberEnvelope
Set objEnvelope = pRubberband.TrackNew(pScreenDisplay, Nothing)
If objEnvelope Is Nothing Then
Call MsgBox("Envelope is Empty", vbExclamation)
Exit Sub
End If
Call FrmMap3D.Init(objEnvelope)
二、初始化选择中的要素：
Public Sub LoadSceneLayers()
On Error GoTo ErrorHandler
'
Dim pMap As iMap
Dim pLayer As ILayer
Dim pCompositeLayer As ICompositeLayer
Dim pPriority As Long
Dim pIndex1 As Long
Dim pIndex2 As Long
'
Set mSceneGraph = FrmMap3D.ArcSceneControl.SceneGraph 'SceneViewerCtrl1.SceneGraph
Set mSceneGraphEvents = mSceneGraph
Set pMap = frmMapControl.arcMapControl.ActiveView.FocusMap
pPriority = 0
'
For pIndex1 = 0 To pMap.LayerCount - 1 Step 1
Set pLayer = pMap.Layer(pIndex1)
If pLayer.Visible = True Then
If TypeOf pLayer Is IGroupLayer Then
Set pCompositeLayer = pLayer
For pIndex2 = 0 To pCompositeLayer.Count - 1 Step 1
pPriority = pPriority + 1
Call LoadSceneLayers2(pCompositeLayer.Layer(pIndex2), pPriority)
Next pIndex2
Else
pPriority = pPriority + 1
Call LoadSceneLayers2(pLayer, pPriority)
End If
End If
Next pIndex1
Exit Sub
ErrorHandler:
MsgBox "LoadSceneLayers"
' Call HandleError(False, "LoadSceneLayers " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub LoadSceneLayers2(ByVal pLayerMx As ILayer, _
ByRef pPriority As Long)
On Error GoTo ErrorHandler
'
Dim pfeatureselection As IFeatureSelection
Dim pSpatialFilter As ISpatialFilter
Dim pFeatureLayerDefinition As IFeatureLayerDefinition
Dim pFeatureLayerMx As IFeatureLayer
Dim pFeatureLayerSx As IFeatureLayer
Dim p3DProperties As I3DProperties
Dim pGeoFeatureLayerMx As IGeoFeatureLayer
Dim pGeoFeatureLayerSx As IGeoFeatureLayer
Dim pLayerSx As ILayer
Dim pColor As IColor
Dim pSymbol As ISymbol
Dim pObjectCopy As IObjectCopy 'esriControlsSupport.IObjectCopy
'
Dim pListItems As MSComctlLib.ListItems
Dim pListItem As MSComctlLib.ListItem
'------------------------------------------------------
' Select Features That pass through the current extent
'------------------------------------------------------
Set pLayerSx = Nothing
If TypeOf pLayerMx Is IFeatureLayer Then
Set pFeatureLayerMx = pLayerMx
If pFeatureLayerMx.FeatureClass.FeatureType = esriFTSimple Then
Set pSpatialFilter = New SpatialFilter
Set pSpatialFilter.Geometry = mEnvelope
'
' pSpatialFilter.GeometryField = pFeatureLayerMx.FeatureClass.ShapeFieldName
pSpatialFilter.SpatialRel = esriSpatialRelIntersects
'
Set pfeatureselection = pFeatureLayerMx
Call pfeatureselection.SelectFeatures(pSpatialFilter, esriSelectionResultNew, False)
'
Set pFeatureLayerDefinition = pFeatureLayerMx
Set pFeatureLayerSx = pFeatureLayerDefinition.CreateSelectionLayer(pFeatureLayerMx.Name, True, "", "")
pFeatureLayerSx.Visible = pFeatureLayerMx.Visible
'
Call pfeatureselection.Clear
'
Set pGeoFeatureLayerMx = pFeatureLayerMx
Set pGeoFeatureLayerSx = pFeatureLayerSx
Set pObjectCopy = New ObjectCopy
Set pGeoFeatureLayerSx.Renderer = pObjectCopy.Copy(pGeoFeatureLayerMx.Renderer)
'
Set pLayerSx = pFeatureLayerSx
End If
Else
If TypeOf pLayerMx Is IRasterLayer Then
Dim pRasterLayerMx As IRasterLayer
Set pRasterLayerMx = pLayerMx
pRasterLayerMx.VisibleExtent = mEnvelope
Set pLayerSx = pRasterLayerMx
End If
End If
'-----------------------
' Add Layer to ArcScene
'-----------------------
Call mSceneGraph.Scene.AddLayer(pLayerSx, False)
'---------------------------------
' Update 3D Properties of SxLayer
'---------------------------------
Set p3DProperties = Get3DPropertiesFromLayer(pLayerSx)
If Not (p3DProperties Is Nothing) Then
' p3DProperties.BaseExpressi
' p3DProperties.BaseOption = esriBaseShape
p3DProperties.DepthPriorityValue = pPriority
' p3DProperties.Extrusi
' p3DProperties.ExtrusionType = esriExtrusionNone
' p3DProperties.FaceCulling = esriFaceCullingNone
' p3DProperties.Illuminate = True
' p3DProperties.OffsetExpressi
' p3DProperties.RenderMode = esriRenderCache
' p3DProperties.RenderRefreshRate = 0.75
' p3DProperties.RenderVisibility = esriRenderAlways
' p3DProperties.SmoothShading = True
' p3DProperties.ZFactor = 1
'
Call p3DProperties.Apply3DProperties(pLayerSx)
End If
' End If
'
Exit Sub
ErrorHandler:
MsgBox "LoadSceneLayers2"
'Call HandleError(False, "LoadSceneLayers2 " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
三、进行符号渲染
Public Sub SymbolInit()
On Error GoTo errH
'ReadIni
Dim pRen As ISimpleRenderer
Dim pGeoFeatLyr As IGeoFeatureLayer
Dim i As Integer
For i = 0 To FrmMap3D.ArcSceneControl.Scene.LayerCount - 1
If FrmMap3D.ArcSceneControl.Scene.Layer(i).Name Like "*" & "l" Then
Set pGeoFeatLyr = FrmMap3D.ArcSceneControl.Scene.Layer(i)
Set pRen = pGeoFeatLyr.Renderer
' Dim pSimpleRenderer As ISimpleRenderer
Dim pLine3DSymbol As ILineSymbol
Dim pSimpleLineSymbol As ISimpleLine3DSymbol
Set pSimpleLineSymbol = New SimpleLine3DSymbol
pSimpleLineSymbol.Style = esriS3DLSTube
Set pLine3DSymbol = pSimpleLineSymbol
pLine3DSymbol.Width = 2
Dim pRgbColor As IRgbColor
Set pRgbColor = New RgbColor
pRgbColor.Red = 255
pLine3DSymbol.color = pRgbColor
ExitLOOP:
Set pRen.Symbol = pLine3DSymbol
FrmMap3D.ArcSceneControl.Scene.SceneGraph.Invalidate pGeoFeatLyr, True, True
FrmMap3D.ArcSceneControl.Scene.SceneGraph.RefreshViewers
End If
Next
frmTreeToc3Dcontrol.ArcTOCControl.Update
errH:
If Err.Number <> 0 Then
MsgBox Err.Number & Err.Description, vbOKOnly + vbInformation & "2"
End If
End Sub
Private Function Get3DPropertiesFromLayer(pLayer As ILayer) As I3DProperties
On Error GoTo ErrorHandler
'
Dim pIndex As Integer
Dim pLayerExtensions As ILayerExtensions
Dim p3DProperties As I3DProperties
'
Set pLayerExtensions = pLayer
Set p3DProperties = Nothing
'
If Not (pLayerExtensions Is Nothing) Then
For pIndex = 0 To pLayerExtensions.ExtensionCount - 1 Step 1
If TypeOf pLayerExtensions.Extension(pIndex) Is I3DProperties Then
Set p3DProperties = pLayerExtensions.Extension(pIndex)
Exit For
End If
Next pIndex
End If
'
Set Get3DPropertiesFromLayer = p3DProperties
'
Exit Function
ErrorHandler:
MsgBox "Get3DPropsFromLayer"
'Call HandleError(False, "Get3DPropsFromLayer " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
Public Sub UniValueSymbol()
Dim pUniqueValueRenderer As IUniqueValueRenderer
Dim pSym As ISimpleLineSymbol ' IFillSymbol
Dim pColor As IColor
Dim pNextUniqueColor As IColor
Dim pEnumRamp As IEnumColors
Dim pTable As ITable
Dim FieldNumberDS As Long
Dim FieldNumberWidth As Long
Dim FieldNumberHeight As Long
Dim pNextRow As IRow
Dim pNextRowBuffer As IRowBuffer
Dim pCursor As ICursor
Dim pQueryFilter As iQueryFilter
Dim dbl_DSValue As Variant
'''''''''''''''''''''''''''''''''''''''''''
Dim pLine3DSymbol As ILineSymbol
Dim pSimpleLineSymbol As ISimpleLine3DSymbol
'''''''''''''''''''''''''''''''''''''''''''
Set pUniqueValueRenderer = New UniqueValueRenderer
Dim pGeoFeatLyr As IGeoFeatureLayer
Dim i As Integer
For i = 0 To FrmMap3D.ArcSceneControl.Scene.LayerCount - 1
Set pGeoFeatLyr = FrmMap3D.ArcSceneControl.Scene.Layer(i)
If pGeoFeatLyr.FeatureClass.ShapeType = esriGeometryLine Or pGeoFeatLyr.FeatureClass.ShapeType = esriGeometryPolyline Then
FieldNumberDS = pGeoFeatLyr.FeatureClass.FindField("D_S")
FieldNumberWidth = pGeoFeatLyr.FeatureClass.FindField("WIDTH")
FieldNumberHeight = pGeoFeatLyr.FeatureClass.FindField("HEIGHT")
If FieldNumberDS = -1 And FieldNumberWidth = -1 Then
GoTo NextIIII
End If
pUniqueValueRenderer.FieldCount = 1
Set pQueryFilter = New QueryFilter
If FieldNumberDS <> -1 Then
pUniqueValueRenderer.Field(0) = Con_D_S
pQueryFilter.AddField Con_D_S
Else
pUniqueValueRenderer.Field(0) = "WIDTH"
pQueryFilter.AddField "WIDTH"
End If
'Set up the Color ramp, this came from looking at ArcMaps Color Ramp
' properties for Pastels.
'
Dim pColorRamp As IRandomColorRamp
Set pColorRamp = New RandomColorRamp
pColorRamp.StartHue = 0
pColorRamp.MinValue = 99
pColorRamp.MinSaturation = 15
pColorRamp.EndHue = 360
pColorRamp.maxValue = 100
pColorRamp.MaxSaturation = 30
pColorRamp.SIZE = 100
pColorRamp.CreateRamp True
Set pEnumRamp = pColorRamp.Colors
Set pNextUniqueColor = Nothing
' Get a enumerator on the first row of the Layer '
Set pCursor = pGeoFeatLyr.Search(pQueryFilter, True)
Set pNextRow = pCursor.NextRow
Do While Not pNextRow Is Nothing
Set pNextRowBuffer = pNextRow
Set pSimpleLineSymbol = New SimpleLine3DSymbol
pSimpleLineSymbol.Style = esriS3DLSTube
If FieldNumberDS <> -1 Then
dbl_DSValue = pNextRowBuffer.Value(FieldNumberDS)
pSimpleLineSymbol.ResolutionQuality = 1#
Else
dbl_DSValue = pNextRowBuffer.Value(FieldNumberWidth)
pSimpleLineSymbol.ResolutionQuality = 0#
End If
Set pNextUniqueColor = pEnumRamp.Next
If pNextUniqueColor Is Nothing Then
pEnumRamp.Reset
Set pNextUniqueColor = pEnumRamp.Next
End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Symbolwith As Double
Symbolwith = CDbl(dbl_DSValue)
Symbolwith = Symbolwith / 1000
Set pLine3DSymbol = pSimpleLineSymbol
pLine3DSymbol.Width = Symbolwith
pLine3DSymbol.color = pNextUniqueColor
pUniqueValueRenderer.AddValue dbl_DSValue, dbl_DSValue, pLine3DSymbol
Set pNextRow = pCursor.NextRow
Loop
Set pGeoFeatLyr.Renderer = pUniqueValueRenderer
FrmMap3D.ArcSceneControl.Scene.SceneGraph.Invalidate pGeoFeatLyr, True, True
FrmMap3D.ArcSceneControl.Scene.SceneGraph.RefreshViewers
End If
NextIIII:
Next
frmTreeToc3Dcontrol.ArcTOCControl.Update
End Sub
