Zoom ArcScene

Question

    Добрый день. Пытался сделать макрос который бы зумировал как нибудь к объекту. Порылся в инете нашел кое что, но он ругается на esricore.
Ниже код. Может кто подскажет как сделать зум?)

Sub ZoomToSelectedLayers()
On Error GoTo ZoomToSelectedLayers_ERR

Dim pLayerArray As IArray

' get the selected layers; exit if there are none:
Set pLayerArray = GetDocLayers(True)
If pLayerArray Is Nothing Then Exit Sub
If pLayerArray.Count < 1 Then Exit Sub

Dim pSxDoc As ISxDocument
Dim pMxDoc As IMxDocument
Dim i As Integer
Dim pExtent As IEnvelope
Dim pLayer As ILayer
Dim pLayersExtent As IEnvelope

' instantiate extent variables:
Set pExtent = New Envelope
Set pLayersExtent = New Envelope

Dim xMax As Double, xMin As Double, yMin As Double, yMax As Double
Dim zmax As Double, zmin As Double
Dim bInScene As Boolean
Dim bInMap As Boolean
Dim pScene As IScene

' check once to see if we are in ArcMap or ArcScene:
bInScene = InScene
bInMap = InMap


' set the new extent boundary to the first one:
Set pLayer = pLayerArray.Element(0)
With pLayer.AreaOfInterest
      xMin = .xMin
      xMax = .xMax
      yMin = .yMin
      yMax = .yMax
      
' need to ask the scenegraph for the z information:
      If bInScene Then
          Set pScene = GetScene()
          Set pExtent = pScene.SceneGraph.OwnerExtent(pLayer, False)
          zmax = pExtent.zmax
          zmin = pExtent.zmin
      End If
      
End With
      
' iterate through each other selected layer and set new boundary coordinates
' if necessary:
For i = 1 To pLayerArray.Count - 1
      Set pLayer = pLayerArray.Element(i)
      With pLayer.AreaOfInterest
          If .xMax > xMax Then xMax = .xMax
          If .xMin < xMin Then xMin = .xMin
          If .yMax > yMax Then yMax = .yMax
          If .yMin > yMin Then yMin = .yMin
      
          If bInScene Then
              Set pExtent = pScene.SceneGraph.OwnerExtent(pLayer, False)
              If pExtent.zmax > zmax Then zmax = pExtent.zmax
              If pExtent.zmin < zmin Then zmin = pExtent.zmin
          End If
          
      End With
Next
     
Dim pZAware As IZAware
Set pZAware = pLayersExtent
pZAware.ZAware = True
       
' set boundary of new extent from our variables:
With pLayersExtent
      .xMin = xMin
      .xMax = xMax
      .yMin = yMin
      .yMax = yMax
      .zmin = zmin
      .zmax = zmax
End With

' call the appropriate method for ArcScene or ArcMap:
If bInScene Then
      Set pSxDoc = Application.Document
      
' set default minimum bounding box:
      pSxDoc.Scene.SceneGraph.ActiveViewer.Camera.SetDefaultsMBB pLayersExtent
      
ElseIf bInMap Then
      Set pMxDoc = Application.Document

      Dim pDisplayTransform As IDisplayTransformation

' set the bisible bounds:
      Set pDisplayTransform = pMxDoc.ActiveView.ScreenDisplay.DisplayTransformation
      pDisplayTransform.VisibleBounds = pLayersExtent
      
Else
      Exit Sub
End If

' call a refresh:
RefreshDocument

Exit Sub

ZoomToSelectedLayers_ERR:
Debug.Print "ZoomToSelectedLayers_ERR: " & Err.Description
Debug.Assert 0

End Sub
'
' return an IEnumLayer of layers in current document
'
Private Function GetDocLayers(Optional bOnlySelected As Boolean) As IArray
Dim pSxDoc As ISxDocument
Dim pMxDoc As IMxDocument
Dim pTOC As IContentsView
Dim i As Integer
Dim pScene As IScene
Dim ppSet As ISet
Dim p
Dim pLayers As IArray
Dim pLayer As ILayer


On Error GoTo GetDocLayers_ERR
Set GetDocLayers = New esricore.Array

If TypeOf Application.Document Is ISxDocument Then
      Set pSxDoc = Application.Document
      Set pScene = pSxDoc.Scene
      
      If Not bOnlySelected Then
          Set pLayers = New esricore.Array
          For i = 0 To pScene.LayerCount - 1
              pLayers.Add pScene.Layer(i)
          Next
          Set GetDocLayers = pLayers
          Exit Function
      Else
          Dim pSxTOC As ISxContentsView
          Set pSxTOC = pSxDoc.ContentsView(0)
      End If
      
ElseIf TypeOf Application.Document Is IMxDocument Then
      Set pMxDoc = Application.Document
      
      If Not bOnlySelected Then
          Set pLayers = New esricore.Array
          For i = 0 To pMxDoc.FocusMap.LayerCount - 1
              pLayers.Add pMxDoc.FocusMap.Layer(i)
          Next
  &

Answer 1

В коде разбираться не пытался, но судя по тому, что компилятор ругается на esricore, у вас что-то не так с версиями ArcGis. Этот пример, скорее всего, для версий младше 9.0. Вы в какой версии пробуете запустить скрипт?

Answer 2

    В версии 9.3. Да я его не мог найти этот esricore нужен iArray насколько я понял по коду.

Answer 3

Помогите кто может) Нужно сделать функционал макроса такой же как и когда нажимаешь правой кнопкой по слою и нажимаешь zoom to layer. Не получается чтото сделать.

Answer 4

Что то подобное, только для арксцены

Public Sub ZoomToLayer()
Dim pMxDoc As IMxDocument
Dim pMap As IMap
Dim pActiveView As IActiveView

Set pMxDoc = Application.Document
Set pMap = pMxDoc.FocusMap
Set pActiveView = pMap

If pMap.Layer(0) Is Nothing Then Exit Sub
pActiveView.Extent = pMap.Layer(0).AreaOfInterest
pActiveView.Refresh
End Sub

Answer 5

Вроде разобрался. А еще вопрос такой вот. Как написать макрос подобный кверибилдеру по всем слоям. Типа такого queryStr = "StreetName = 'НазваниеУлицы'" он ищет совпадение по всем слоям и выделяет его при нахождении.

Answer 6

Вроде разобрался.

Ну так выложите, вдруг пригодится кому.

Как написать макрос подобный кверибилдеру по всем слоям. Типа такого queryStr = "StreetName = 'НазваниеУлицы'" он ищет совпадение по всем слоям и выделяет его при нахождении.

Можно посмотреть здесь:
http://www.dataplus.ru/Support/ESRI/ArcGIS/ArcObjects/ArcObjects.htm
и сделать аналогично. Придётся кое-что выкинуть, кое-что поменять, например, IMxDocument поменять на ISxDocument, FocusMap и IMap на Scene и IScene соответственно, ну и т.д.
В цикле пройтись по всем слоям, для каждого вызвать метод SelectFeatures, передав соответствующий IQueryFilter. И, конечно, предварительно убедившись, что указанное в запросе поле присутствует в слое.

Answer 7

Ну так выложите, вдруг пригодится кому.

Может сделал слишком примитивно, но по другому не смог)
Sub SelectLayer()
Dim pUID As New UID
Dim pCmdItem As ICommandItem
pUID.Value = "{3558D456-268E-11D4-A383-00C04F6BC619}"
pUID.SubType = None
Set pCmdItem = Application.Document.CommandBars.Find(pUID)
pCmdItem.Execute
End Sub

Сейчас попробую разобраться с тем что Вы мне подкинули. Спасибо.

Answer 8

Можно посмотреть здесь:
http://www.dataplus.ru/Support/ESRI/ArcGIS/ArcObjects/ArcObjects.htm
и сделать аналогично. Придётся кое-что выкинуть, кое-что поменять, например, IMxDocument поменять на ISxDocument, FocusMap и IMap на Scene и IScene соответственно, ну и т.д.
В цикле пройтись по всем слоям, для каждого вызвать метод SelectFeatures, передав соответствующий IQueryFilter. И, конечно, предварительно убедившись, что указанное в запросе поле присутствует в слое.

    'очистка существующей выборки на экране
mxDoc.ActiveView.PartialRefresh_
esriViewGeoSelection , Nothing, Nothing
Вот тут вот зависаю) Незнаю что поменять и можете подсказать какой цикл должен быть чтоб по всем слоям прошелся а не только по одному. А так выборка получилась.

Answer 9

'очистка существующей выборки на экране
mxDoc.ActiveView.PartialRefresh_
esriViewGeoSelection , Nothing, Nothing
Вот тут вот зависаю)

Я не знаю, зачем вызывать обновление экрана дважды, как там делают. Надо проверять.

Но вообще после каких-либо изменений (в т.ч. и после изменения выборки) необходимо обновить экран. Метод PartialRefresh как раз и предоставляет эффективный способ это сделать. Выглядеть это будет как-то так:

Dim pActiveView As IActiveView

Set pActiveView = sxDoc.Scene

pActiveView.PartialRefresh esriViewGeoSelection, Nothing, Nothing

В цикле вызывать обновление экрана не надо! Вызывать надо уже в самом конце, за пределами этого самого цикла.

Незнаю что поменять и можете подсказать какой цикл должен быть чтоб по всем слоям прошелся а не только по одному. А так выборка получилась.

Посмотрите там скрипт №4.
    

Answer 10

Я не знаю, зачем вызывать обновление экрана дважды, как там делают. Надо проверять.
   

    
А вот допустим выборка уже какая то была. И нужно чтоб все они убрались. Я думал для этого этот код. Но проверял выборка все равно остается. Можно как либо все выборки убирать?