frmpttrackingimport.frm

esir公司的产品MapObject的vb例子

      TabIndex        =   4
      Top             =   165
      Visible         =   0   'False
      Width           =   348
   End
   Begin VB.ComboBox cmbTrackingLayer 
      Height          =   315
      Left            =   1830
      Style           =   2  'Dropdown List
      TabIndex        =   3
      Top             =   180
      Width           =   2016
   End
   Begin VB.CommandButton cmdOK 
      Caption         =   "&OK"
      Default         =   -1  'True
      Height          =   372
      Left            =   4515
      TabIndex        =   1
      Top             =   7050
      Width           =   828
   End
   Begin VB.CommandButton cmdCancel 
      Cancel          =   -1  'True
      Caption         =   "&Cancel"
      Height          =   372
      Left            =   5610
      TabIndex        =   0
      Top             =   7050
      Width           =   924
   End
   Begin VB.Label Label8 
      Caption         =   "Value Scale:"
      Height          =   195
      Left            =   3930
      TabIndex        =   44
      Top             =   5910
      Width           =   1080
   End
   Begin VB.Label Label10 
      Caption         =   $"frmPTTrackingImport.frx":68E2
      Height          =   1308
      Left            =   7212
      TabIndex        =   18
      Top             =   132
      Visible         =   0   'False
      Width           =   3468
   End
   Begin VB.Label Label7 
      Caption         =   "Layer to animate:"
      Height          =   285
      Left            =   150
      TabIndex        =   15
      Top             =   5895
      Width           =   1350
   End
   Begin VB.Label Label2 
      Caption         =   "Timestamp Field (mm/dd/yy hh:mm:ss):"
      Height          =   495
      Left            =   120
      TabIndex        =   5
      Top             =   1050
      Width           =   1695
   End
   Begin VB.Label Label1 
      Caption         =   "Point Layer:"
      Height          =   255
      Left            =   510
      TabIndex        =   2
      Top             =   195
      Width           =   1200
   End
End
Attribute VB_Name = "frmEventQuantityAnimator"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'
' ESRI
' 3D Analyst Developer Sample - sxTrackingAnimationImport
' frmPTTrackingImport.frm
'
' Dialog for running the ImportTrackingPointsToLayerKeyframes command
'
' May require references to
' ESRI ArcScene Object Library
' ESRI ArcMap Object Library
' ESRI TIN Object Library
' ESRI Object Library


Option Explicit

Dim m_pTrackingLayers As Collection ' all layers in the scene in which to choose as the input
Dim m_pLayersToAnimate As Collection ' all layers in the scene in which to choose as the target layer to clone & animate
Dim m_bNoEvents As Boolean  ' modular level flag
Public Sub RunMe()
  On Error Resume Next
  
  FormatMe
  SetFieldDefaults
  Me.Show vbModal
  
End Sub
'
' format the dialog w/defaults
'
Private Sub FormatMe()

  On Error GoTo EH
  
  Set m_pTrackingLayers = New Collection
  Set m_pLayersToAnimate = New Collection
  
  m_bNoEvents = True  ' don't process any dialog events
  
  ' The way this command works is that a layer or table will be used as the
  ' input to derive geographic location events.
  ' Once groups of these events are established by processing the input table
  ' (such as an airline flight), the 'animated layer', such as a CAD file or a graphic symbol
  ' is cloned for each group and added as a layer in a group layer.
  ' Therefore, feature layers or standalone tables can be considered as a input source,
  ' and CAD files, graphics layers, or feature layers can be considered as potential
  ' animated layers.
  With Me
    Dim pLayer As ILayer
    Dim i As Integer
    For i = 0 To g_pSxDoc.Scene.LayerCount - 1
    
      ' add feature layers as input or animated layer:
      Set pLayer = g_pSxDoc.Scene.Layer(i)
      If TypeOf pLayer Is IFeatureLayer Then
        m_pTrackingLayers.Add pLayer
        m_pLayersToAnimate.Add pLayer
        
      ' CAD layers can be animated:
      ElseIf TypeOf pLayer Is ICadLayer Then
        m_pLayersToAnimate.Add pLayer
        
      ' graphic layers can be animated:
      ElseIf TypeOf pLayer Is IGraphicsLayer Then
        m_pLayersToAnimate.Add pLayer
      End If
      
    Next
    
    ' add standalone tables as input:
    Dim pTables As IStandaloneTableCollection
    Set pTables = g_pSxDoc.Scene
    Dim pTable As IStandaloneTable
    For i = 0 To pTables.StandaloneTableCount - 1
      Set pTable = pTables.StandaloneTable(i)
      m_pTrackingLayers.Add pTable
    Next
  
    Dim p
    ' add the input layers to the dialog:
    For i = 1 To m_pTrackingLayers.Count
      If TypeOf m_pTrackingLayers.Item(i) Is ILayer Then
        Set pLayer = m_pTrackingLayers.Item(i)
        Me.cmbTrackingLayer.AddItem pLayer.name
      ElseIf TypeOf m_pTrackingLayers.Item(i) Is IStandaloneTable Then
        Set pTable = m_pTrackingLayers.Item(i)
        ' tag the standalone tables with brackets on the dialog:
        Me.cmbTrackingLayer.AddItem "<" & pTable.name & ">"
      End If
    Next
    
    ' add the animate layers to the dialog:
    For i = 1 To m_pLayersToAnimate.Count
      If TypeOf m_pLayersToAnimate.Item(i) Is ILayer Then
        Set pLayer = m_pLayersToAnimate.Item(i)
        Me.cmbAnimateLayer.AddItem pLayer.name
      End If
    Next
    
    m_bNoEvents = False ' process no dialog events
    
    If Me.cmbTrackingLayer.ListCount > 0 Then Me.cmbTrackingLayer.ListIndex = 0
    If Me.cmbAnimateLayer.ListCount > 0 Then Me.cmbAnimateLayer.ListIndex = 0
    
    ' dialog defaults:
    .txtFromTime = ""
    .txtToTime = ""
    .txtValueScale = 1
    .txtZOffset = 0
    .txtZUnitConversion = "1"

    
  End With
  
  Exit Sub
  
EH:
  MsgBox "Error during dialog setup: " & err.Description, vbExclamation, "Import Tracking Points"
  Resume Next
  
End Sub
'
' set a default time range to the dialog based on the first record for the input
' and the field name chosen
'
Private Sub cmbTimeField_Click()

  On Error GoTo EH
  
  SuggestTimeRange
  
  Exit Sub
  
EH:
  Me.txtFromTime = ""
  Me.txtToTime = ""
End Sub
'
' populate the field lists and the selection checkbox
' based on the layer selected
'
Private Sub cmbTrackingLayer_Click()
  
  If m_bNoEvents Then Exit Sub
  
  On Error GoTo EH
  
  Dim bCanUseSel As Boolean
  Dim i As Integer
  Dim pFLDS As IFields
  Dim pFld As IField
  Dim pLayer As ILayer
  Dim pTable As ITable
  Dim bCanUseGeom As Boolean
    
  ' point to the layer or table:
  If TypeOf m_pTrackingLayers.Item(Me.cmbTrackingLayer.ListIndex + 1) Is ILayer Then
    Set pLayer = m_pTrackingLayers.Item(Me.cmbTrackingLayer.ListIndex + 1)
  ElseIf TypeOf m_pTrackingLayers.Item(Me.cmbTrackingLayer.ListIndex + 1) Is ITable Then
    Set pTable = m_pTrackingLayers.Item(Me.cmbTrackingLayer.ListIndex + 1)
  End If
  
  ' determine if we should allow the 'use selection' checkbox on the dialog:
  If Not pLayer Is Nothing Then

    Dim pFS As IFeatureSelection
    Set pFS = pLayer
    If Not pFS Is Nothing Then
      If Not pFS.SelectionSet Is Nothing Then
        If pFS.SelectionSet.Count > 0 Then
          bCanUseSel = True
        Else
          bCanUseSel = False
        End If
      End If
    End If
    
    Dim pFLayer As IFeatureLayer
    Set pFLayer = pLayer
    
    Set pFLDS = pFLayer.FeatureClass.Fields
    bCanUseGeom = True
    
  ElseIf Not pTable Is Nothing Then
    Dim pTS As ITableSelection
    Set pTS = pTable
    If Not pTS Is Nothing Then
      If Not pTS.SelectionSet Is Nothing Then
        If pTS.SelectionSet.Count > 0 Then
          bCanUseSel = True
        End If
      End If
    End If
    Set pFLDS = pTable.Fields
    bCanUseGeom = False

  End If
    
  Me.cmbEventValue.Clear
  Me.cmbHeightField.Clear
  Me.cmbLatitude.Clear
  Me.cmbTimeField.Clear
  Me.cmbLongitude.Clear
  
  ' populate field lists:
  If Not pFLDS Is Nothing Then
    For i = 0 To pFLDS.FieldCount - 1
      Set pFld = pFLDS.Field(i)
      
      If pFld.Type < 6 Then ' not a geometry or system field
        Me.cmbEventValue.AddItem pFld.name
        Me.cmbHeightField.AddItem pFld.name
        Me.cmbLatitude.AddItem pFld.name
        Me.cmbLongitude.AddItem pFld.name
        Me.cmbTimeField.AddItem pFld.name
      End If
    Next
  End If
  
  On Error Resume Next

  Me.cmbEventValue.ListIndex = 0
  Me.cmbHeightField.ListIndex = 0
  Me.cmbLatitude.ListIndex = 0
  Me.cmbLongitude.ListIndex = 0
  Me.cmbTimeField.ListIndex = 0
  Me.optHeight(1).Value = bCanUseGeom
  If Me.optHeight(1).Value = False Then Me.optHeight(0).Value = True
  Me.optTimeRange(1).Value = True
  Me.optPosition(0).Value = bCanUseGeom
  If Me.optPosition(0).Value = False Then Me.optPosition(1).Value = True
  Me.optPosition(0).Enabled = bCanUseGeom
  Me.chkSelectedEvents.Enabled = bCanUseSel
  
  ' if there is a selection, have the default be to use it:
  If bCanUseSel Then
    Me.chkSelectedEvents.Value = 1
  Else
    Me.chkSelectedEvents.Value = 0
  End If
  
  SetFieldDefaults
  
  Exit Sub
  
EH:
  MsgBox "Selection Error: " & err.Description
  
End Sub

Private Sub cmdCancel_Click()
  Unload Me
End Sub

Private Sub cmdOK_Click()
  On Error Resume Next
  If RunCommand Then
    Unload Me
  End If
End Sub

'
' enable\disable the from and to time range text boxes
'
Private Sub optTimeRange_Click(Index As Integer)