bastrackingimport.bas

esir公司的产品MapObject的vb例子

Attribute VB_Name = "basTrackingImport"
'
' ESRI
' 3D Analyst Developer Sample - sxTrackingEventImport
' basTrackingImport.bas
'
' Includes command to import layer keyframes from event features or records,
' * ImportTrackingPointsToLayerKeyframes

' Requires references to
' ESRI ArcScene Object Library
' ESRI ArcMap Object Library
' ESRI TIN Object Library
' ESRI Object Library

Option Explicit

Dim g_pGraphicElement As IElement


' we will need to normalize all date\time events inside a 0-1 range.
' we will first convert all date\times to a double using these constants:
Const minF = (1# / 60#)
Const secF = (1# / 3600#)

Const dayF = (1# / 365#)
Const monthF = (1# / 12#)

Dim varIDS() As String  ' an array of all unique group IDs (such as airline flight #'s)

' for progress dialog:
Dim m_pTrackCancel As ITrackCancel
Dim m_pProgDialog As IProgressDialog
Dim m_pStepProgressor As IStepProgressor
'
' Accepting a feature layer or standalone table with attributes defining the position of
' and time of an event (such as the location of an airline), and a ID fieldname which will
' link occurances of the same group (such as the path of an airplane with a flight ID),
' as well as a layer which to animate,
' return a group layer containing layers cloned from the animate layer (CAD, graphics, feature layer)
' and a collection of animation tracks which control their movement through the event locations
' they designate.
' Additional parameters control the filtering of events via their selection or time range,
' a height offset and\or z conversion, and control over how the layer azimuthal rotation changes
' along the event paths.
' (bSetKeyframeAzimuth = TRUE & bSetAdditionalKeyframeForAzimuth = FALSE)
' - will set the azimuth property for each keyframe based on it's and the next event in the group's location.
' - This will rotate the direction the layer is pointing in along the path.
' - However, for an path which moves through various postions that should not be considered in
'   factoring the azimuth, such as a flight from LA to NY to Miami which should not be turning
'   towards Miami until reaching NY, use
' (bSetKeyframeAzimuth = TRUE & bSetAdditionalKeyframeForAzimuth = TRUE)
' - which will add a duplicate keyframe for each event with the last azimuth position so that the
'   rotation effect is not consider throughout the entire path, but from location to location.
'
Public Function ImportTrackingPointsToLayerKeyframes(pLayerWithSelection As ILayer, pORStandAloneTable As IStandaloneTable, sTimeStampField As String, _
sEventGroupIDField As String, pSymbolLayer As ILayer, sOutputGroupLayerName As String, _
ByRef ppOutAnimationTracks As Collection, ByRef ppOutGroupLayer As IGroupLayer, _
Optional nZOffset As Double = 0, _
Optional nZUnitConversion As Double = 1, _
Optional sTimeFilterStart As String, Optional sTimeFilterEnd As String, _
Optional sXFieldName As String, Optional sYFieldName As String, Optional sZFieldName As String, _
Optional nMaxTracks As Long = -1, Optional bUseSelectedEvents As Boolean, Optional bSortRecords As Boolean = False, _
Optional bHideEventAtStartAndFinish As Boolean = True, Optional bSetKeyframeAzimuth As Boolean = True, _
Optional bSetAdditionalKeyframeForAzimuth As Boolean = False, Optional sBaseTrackName As String = "Import Track", Optional nProgBarOwnerHWND As Long) As Boolean

  Debug.Assert 0
  On Error GoTo ImportTrackingPointsToLayerKeyframes_ERR
  
  Dim sTotalEventsStartTime As String
  Dim sTotalEventsEndTime As String
  Dim nGroupIDField As Long
  Dim nTimeFieldIndex As Long
  Dim nXFieldIndex As Long
  Dim nYFieldIndex As Long
  Dim nZFieldIndex As Long
  Dim nAniStartTime As Double
  Dim nAniEndTime As Double
  Dim nAniTotalTime As Double
  Dim dLastAzi As Double
  Dim nTrackCount As Double
  Dim nSymbolLayerX As Double
  Dim nSymbolLayerY As Double
  Dim nSymbolLayerZ As Double
  Dim pCursorEvents As ICursor
  Dim pRow As IRow
  Dim sID As String
  Dim pF As IField
  Dim nIDCount As Double
  Dim i As Long
  Dim bFound As Boolean
  Dim sEventGroupIDField2 As String ' the given fieldname with any modifications such as an underscore where spaces were
  Dim sTimeStampField2 As String    ' ""  ""  ""
  Dim sXField2 As String            ' ""  ""  ""
  Dim sYField2 As String            ' ""  ""  ""
  Dim sZField2 As String            ' ""  ""  ""
  Dim nNumFeatures As Double
  Dim pFCFullRecords As ICursor
  Dim pFCSortIndividual As ICursor
  Dim pFC_FID As IFeatureCursor
  Dim pRC_FID As ICursor
  Dim bUseFeatures As Boolean
  Dim pFakeAzimuthKeyframe As IKeyframe
  Dim bUseRecordsCurrentSorting As Boolean
  Dim bUseTimeFilter As Boolean
  ReDim varIDS(0)
  nZFieldIndex = -1
  nXFieldIndex = -1
  nYFieldIndex = -1
  
  If Right(sBaseTrackName, 1) <> " " Then sBaseTrackName = sBaseTrackName & " "
  bUseRecordsCurrentSorting = Not (bSortRecords)
  If bSetAdditionalKeyframeForAzimuth Then bSetKeyframeAzimuth = True
  If Len(Trim(sTimeFilterStart)) > 0 And Len(Trim(sTimeFilterEnd)) > 0 Then bUseTimeFilter = True
  
  ' evaluate if the input is a feature layer or an attribute table:
  If Not pLayerWithSelection Is Nothing Then
    If Not TypeOf pLayerWithSelection Is IFeatureLayer Then
      MsgBox "Input layer type was not feature layer.", vbExclamation, "Import Tracking Points"
      Exit Function
    End If
    bUseFeatures = True
  ElseIf Not pORStandAloneTable Is Nothing Then
    bUseFeatures = False
  Else
    MsgBox "No valid input was designated.", vbExclamation, "Import Tracking Points"
    Exit Function
  End If
  
  If pSymbolLayer Is Nothing Then
    MsgBox "No layer to animate was found.", vbExclamation, "Import Tracking Points"
    Exit Function
  End If
  
  Dim sIDName As String
  If bUseFeatures Then  ' todo -get this from table, not hardcoded
    sIDName = "FID = "
  Else
    sIDName = "OID = "
  End If
      
  ' retrieve a cursor for all, or selected, event records:
  If bUseSelectedEvents Then
    If bUseFeatures Then
      Set pCursorEvents = priv_GetSelectedFeatures(pLayerWithSelection, True, Nothing)
    Else
      Set pCursorEvents = priv_GetSelectedRecords(pORStandAloneTable, True, Nothing)
    End If
  Else
    If bUseFeatures Then
      Set pCursorEvents = priv_GetFeatureCursorFromLayer(pLayerWithSelection, Nothing)
    Else
      Set pCursorEvents = priv_GetAllRecords(pORStandAloneTable, Nothing)
    End If
  End If

  If pCursorEvents Is Nothing Then
    Debug.Assert 0
    MsgBox "Error retrieving cursor from input records.", vbExclamation, "Import Tracking Points"
    Exit Function
  End If
  
  ' get the index of the eventgroupID field:
  nGroupIDField = pCursorEvents.FindField(sEventGroupIDField)
  If nGroupIDField < 1 Then  ' try modifying the field name to use underscores:
    sEventGroupIDField2 = Replace(sEventGroupIDField, " ", "_")
    nGroupIDField = pCursorEvents.FindField(sEventGroupIDField2)
  Else
    sEventGroupIDField2 = sEventGroupIDField  ' the original fieldname to use is OK
  End If
  If nGroupIDField < 0 Then
    MsgBox "There was a error accessing field: " & sEventGroupIDField & ".", vbExclamation, "Import Tracking Points"
    Exit Function
  End If
  
  ' get the index of the timestamp field:
  nTimeFieldIndex = pCursorEvents.FindField(sTimeStampField)
  If nTimeFieldIndex < 0 Then ' try modifying the field name to use underscores:
    sTimeStampField2 = Replace(sTimeStampField, " ", "_")
    nTimeFieldIndex = pCursorEvents.FindField(sTimeStampField2)
  Else
    sTimeStampField2 = sTimeStampField ' the original fieldname to use is OK
  End If
  If nTimeFieldIndex < 0 Then
    MsgBox "There was a error accessing field: " & sTimeStampField & ".", vbExclamation, "Import Tracking Points"
    Exit Function
  End If
    
  ' get the index of the X and y field:
  If Not bUseFeatures Or (bUseFeatures And (sXFieldName <> "" And sYFieldName <> "")) Then
    nXFieldIndex = pCursorEvents.FindField(sXFieldName)
    If nXFieldIndex < 0 Then ' try modifying the field name to use underscores:
      sXField2 = Replace(sXFieldName, " ", "_")
      nXFieldIndex = pCursorEvents.FindField(sXField2)
    Else
      sXField2 = sXFieldName ' the original fieldname to use is OK
    End If
    If nXFieldIndex < 0 And Not bUseFeatures Then
      MsgBox "There was a error accessing field: " & sXFieldName & ".", vbExclamation, "Import Tracking Points"
      Exit Function
    End If
  
    nYFieldIndex = pCursorEvents.FindField(sYFieldName)
    If nYFieldIndex < 0 Then ' try modifying the field name to use underscores:
      sYField2 = Replace(sYFieldName, " ", "_")
      nYFieldIndex = pCursorEvents.FindField(sYField2)
    Else
      sYField2 = sYFieldName ' the original fieldname to use is OK
    End If
    If nYFieldIndex < 0 And Not bUseFeatures Then
      MsgBox "There was a error accessing field: " & sYFieldName & ".", vbExclamation, "Import Tracking Points"
      Exit Function
    End If
    
  
  End If
  
  ' get the index of the Z field (either features or table)
  If (bUseFeatures And (nZFieldIndex < 0)) Or Not bUseFeatures Then
    If sZFieldName <> "" Then
      nZFieldIndex = pCursorEvents.FindField(sZFieldName)
      If nZFieldIndex < 0 Then ' try modifying the field name to use underscores:
        sZField2 = Replace(sZFieldName, " ", "_")
        nZFieldIndex = pCursorEvents.FindField(sZFieldName)
      Else
        sZField2 = sZFieldName ' the original fieldname to use is OK
      End If
      If nZFieldIndex < 0 Then
        MsgBox "There was a error accessing field: " & sZFieldName & ".", vbExclamation, "Import Tracking Points"
        Exit Function
      End If
    End If
  End If
  
  
  ' create an array containing the unique group IDS of the events:
  Set pRow = pCursorEvents.NextRow
  Dim iRowCount As Double
  Do While Not pRow Is Nothing
    sID = pRow.Value(nGroupIDField)
    bFound = False
    For i = 0 To nIDCount - 1
      If UCase(varIDS(i)) = UCase(sID) Then
        bFound = True
        Exit For
      End If
    Next
    If Not bFound Then
      ReDim Preserve varIDS(nIDCount)
      varIDS(nIDCount) = sID
      nIDCount = nIDCount + 1
      If nMaxTracks > 0 And nIDCount = nMaxTracks Then Exit Do
    End If
    Set pRow = pCursorEvents.NextRow
    iRowCount = iRowCount + 1
    DoEvents
  Loop

  ' if the real world animation start and end times, were not given, we must parse this
  ' information ourselves:
  Dim nMax As Double
  If (nMaxTracks = -1) Or (nIDCount < nMaxTracks) Then nMaxTracks = nIDCount
  If (nMaxTracks = -1) Then  ' was there a maximum number of tracks, and therefore, group IDs?
    nMax = nIDCount
  Else
    nMax = nMaxTracks
  End If
  
  ' read table for start and end times if they were not given:
  'If (Len(Trim(sTotalEventsStartTime)) < 1 Or Len(Trim(sTotalEventsEndTime)) < 1) Then
    If Not ParseRecordsForStartAndEndTime(pLayerWithSelection, pORStandAloneTable, bUseSelectedEvents, nTimeFieldIndex, sEventGroupIDField2, nMax, sTimeFilterStart, sTimeFilterEnd, sTotalEventsStartTime, sTotalEventsEndTime) Then
      Debug.Assert 0
      SetDoneWorkingState
      MsgBox "There was a error reading the table for start and end times.", vbExclamation, "Import Tracking Points"
      
      Exit Function
    End If
  'End If
  
  ' since the total events range was either given or just parsed, now we can
  ' tokenize (convert to a double)
  nAniStartTime = TokenTime(sTotalEventsStartTime)
  nAniEndTime = TokenTime(sTotalEventsEndTime)
  Debug.Print "Events start at: " & sTotalEventsStartTime & "(" & nAniStartTime & ") - Events end at: " & sTotalEventsEndTime & "(" & nAniEndTime & ")"
  'OffsetProgressMSG "Events start at: " & sTotalEventsStartTime & "(" & nAniStartTime & ") - Events end at: " & sTotalEventsEndTime & "(" & nAniEndTime & ")", False
  
  nAniTotalTime = nAniEndTime - nAniStartTime
  
  Debug.Print nIDCount & " unique groups out of " & iRowCount & " total records."
  'OffsetProgressMSG nIDCount & " unique groups out of " & iRowCount & " total records.", False
  
  Dim pQF_Group As IQueryFilter
  Set pQF_Group = New QueryFilter
  
  Dim lID As Double
  Dim pQF_FID As IQueryFilter
    
  Dim pTrack As IAnimationTrack
  Dim pKeyFrame As IKeyframe
  Dim pTrackFeat As IFeature
  Dim pTrackRow As IRow
  Dim nTrackX As Double
  Dim nTrackY As Double
  Dim nTrackZ As Double
  Dim nTransX As Double
  Dim nTransY As Double
  Dim nTransZ As Double
  
  ' inevitably, we will build a collection of animation tracks to return,
  ' as well as a group layer representing a layer for each event group, such as a flight:
  Dim pAniTracks As Collection
  Set pAniTracks = New Collection
  
  ' build the outgoing group layer, and name it:
  Dim pOutGroupLayer As IGroupLayer
  Set pOutGroupLayer = New GroupLayer
  
  Dim pLayerNaming As ILayer
  Set pLayerNaming = pOutGroupLayer
  pLayerNaming.name = sOutputGroupLayerName

  Dim pTable As IAttributeTable
  Dim pSelSet As ISelectionSet
  Dim pFeatSel As IFeatureSelection
  Dim pRowSel As ITableSelection
  Dim pTableSort As ITableSort
  Dim pIDSorted As IEnumIDs
  Dim pFeatureLayer As IFeatureLayer
  Dim pStandAloneEventTable As ITable
  Dim pFeatureCur As IFeatureCursor
  Dim pFLayer As IFeatureLayer
  Dim pFeat2 As IFeature
  
  ' for each unique group ID, create a new animation track
  ' and use the geometries of the point locations and their time stamps
  ' to create layer keyframes with proper time stamps and translations:
  If nMaxTracks <= 0 Then nMaxTracks = nIDCount

  If bUseFeatures Then
    Set pFeatureLayer = pLayerWithSelection
  Else
    Set pStandAloneEventTable = pORStandAloneTable
  End If
    
  ' DETERMINE THE POSITION OF THE ANIMATED LAYER.
  ' get the original location of the symbol layer (use 1st feature):
  If TypeOf pSymbolLayer Is IFeatureLayer Then
    
    Set pFLayer = pSymbolLayer
    Set pFeatureCur = pFLayer.Search(Nothing, False)
    Set pFeat2 = pFeatureCur.NextFeature
    nSymbolLayerX = (pFeat2.Extent.xmax + pFeat2.Extent.xmin) / 2
    nSymbolLayerY = (pFeat2.Extent.ymax + pFeat2.Extent.ymin) / 2
    
    If Not IsNaN(pFeat2.Extent.zmax) And Not (IsNaN(pFeat2.Extent.zmin)) Then
      nSymbolLayerZ = (pFeat2.Extent.zmax + pFeat2.Extent.zmin) / 2
    Else
      nSymbolLayerZ = 0
    End If
    
  ElseIf TypeOf pSymbolLayer Is IGraphicsLayer Then
    
    Dim pElem As IElement
    Dim pGC As IGraphicsContainer3D
    Set pGC = pSymbolLayer
    Set pElem = pGC.Element(0)
    nSymbolLayerX = (pElem.Geometry.Envelope.xmax + pElem.Geometry.Envelope.xmin) / 2
    nSymbolLayerY = (pElem.Geometry.Envelope.ymax + pElem.Geometry.Envelope.ymin) / 2
    nSymbolLayerZ = (pElem.Geometry.Envelope.zmax + pElem.Geometry.Envelope.zmin) / 2
    
  End If
              
  For i = 0 To nMaxTracks - 1 ' MAIN TRACK LOOP  ========================================================================