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

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

Нет, этот код просто обновляет экран.

Выборка там меняется при вызове SelectFeatures. Константа
esriSelectionResultNew задаёт поведение, когда старая выборка слоя удаляется, а новая, заданная запросом, устанавливается.

Answer 2

Нет, этот код просто обновляет экран.

Выборка там меняется при вызове SelectFeatures. Константа
esriSelectionResultNew задаёт поведение, когда старая выборка слоя удаляется, а новая, заданная запросом, устанавливается.

Насколько понял константа esriSelectionResultNew создает новую выборку а остальные должны пропадать) Но этого не происходит. Поступил подругому чуток и сделал процедурку которая очищает все выборки.

Sub UnSelectLayer()

  Dim pUID As New UID

  Dim pCmdItem As ICommandItem

  pUID.Value = "{3558D45A-268E-11D4-A383-00C04F6BC619}"

  pUID.SubType = None

  Set pCmdItem = Application.Document.CommandBars.Find(pUID)

  pCmdItem.Execute

End Sub 

    

Answer 3

Насколько понял константа esriSelectionResultNew создает новую выборку а остальные должны пропадать)

Остальные кто? Выборки? Не должны, разумеется. Это же метод слоя, и, соответственно, очистится выборка только данного слоя.
Чтобы очистить выборку во всех слоях, можно пользоваться, например, методом ClearSelection

Dim sxDoc As ISxDocument

Set sxDoc = Application.Document

sxDoc.Scene.ClearSelection

Но этого не происходит.

У меня всё работает. Что я делаю не так?)

Поступил подругому чуток и сделал процедурку которая очищает все выборки.

Рано или поздно готовые кнопки закончатся ;)

Answer 4

   У меня вроде тоже заработало) Но как то не всегда. А вот такой вот еще вопрос. Приложение написаное на VB.net из него запускаем макрос в арксцене и передаем какие то параметры.
     

   

Dim NameStr As Object

NameStr = RichTextBox3.Text

            pApp = m_ROT.Item(i)

            pApp.RunVBAMacro("Project", "Module1", "Neww", NameStr)

А в арксцене вот так принимаю

Sub Neww(FindName As String)

MsgBox (FindName)

End Sub

Но в итоге ничего не получается. Пишет что параметры не правильные. Что я не так делаю?)

Answer 5

Но в итоге ничего не получается. Пишет что параметры не правильные. Что я не так делаю?)

Параметры неправильно задаёте)
Передаёте строку, когда в справке английским по белому написано, что нужен массив:

arguments is a Variant array that represents the arguments that you want to pass into this macro.

Как-то так:

Dim parameters = New Object() {"Hello world"}

pVbaApplication.RunVBAMacro("Project", "Module1", "Neww", parameters)

Answer 6

Но в итоге ничего не получается. Пишет что параметры не правильные. Что я не так делаю?)

Параметры неправильно задаёте)
Передаёте строку, когда в справке английским по белому написано, что нужен массив:

arguments is a Variant array that represents the arguments that you want to pass into this macro.

Как-то так:

Dim parameters = New Object() {"Hello world"}

pVbaApplication.RunVBAMacro("Project", "Module1", "Neww", parameters)

Спасибо большое) Усе получилось. Незнаю бы что делал без вас)