如何二维地图Map选择范围，加到三维ArcScene控件中显示、渲染（源代码）

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