bastrackingimport.bas

esir公司的产品MapObject的vb例子

        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 Event Values"
        Exit Function
      End If
    End If
  End If
  
  Dim nMax As Double
  
  ' read table for start and end times - pass the time range filter - it will be used if it was given:
  If Not ParseRecordsForStartAndEndTime(pLayerWithSelection, pORStandAloneTable, bUseSelectedEvents, nTimeFieldIndex, "", -1, sTimeFilterStart, sTimeFilterEnd, sTotalEventsStartTime, sTotalEventsEndTime, nMaxTracks) Then
    Debug.Assert 0
    SetDoneWorkingState
    MsgBox "There was a error reading the table for start and end times.", vbExclamation, "Import Event Values"
    Exit Function
  End If
  
  nMax = nMaxTracks
  
  ' 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 & ")"

  nAniTotalTime = nAniEndTime - nAniStartTime
  
  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, such as an earthquake:
  Dim pAniTracks As Collection
  Set pAniTracks = New Collection
  
  ' build the outgoing group layer, and name it:
  Dim pOutGroupLayer As IGroupLayer
  Dim pLayerNaming As ILayer
  Set pOutGroupLayer = New GroupLayer
  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

  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
              
  ' sort the table and generate a list of sorted FIDs,
  ' set the cursor to the record with the first FID:
  If bUseFeatures Then  ' end result here is the 'pSelSet'
    ' use a feature selection:
    Set pTable = pLayerWithSelection
    If bUseSelectedEvents Then
    Set pFeatSel = pLayerWithSelection
      Set pSelSet = pFeatSel.SelectionSet
    Else
      Set pSelSet = Nothing
    End If
  Else
    ' use a table selection:
    Set pTable = pORStandAloneTable
    If bUseSelectedEvents Then
      Set pRowSel = pORStandAloneTable
      Set pSelSet = pRowSel.SelectionSet
    End If
  End If
  
  Set pTableSort = New esriCore.TableSort
  pTableSort.Fields = sTimeStampField2
  pTableSort.Ascending(sTimeStampField2) = True
  Set pTableSort.Table = pTable
  Set pTableSort.SelectionSet = pSelSet
  pTableSort.Sort Nothing
  
  Set pIDSorted = pTableSort.IDs
  lID = pIDSorted.Next  ' the first sorted record ID
  
  For i = 0 To nMaxTracks - 1 ' MAIN TRACK LOOP  ========================================================================
    
    If OffsetProgressMSG("Track " & nTrackCount + 1 & "\" & nMax, True, nMaxTracks, 0, nProgBarOwnerHWND, i) Then
      Debug.Assert 0
      If MsgBox("Abort operation?", vbYesNo, "Operation") = vbYes Then
        Debug.Assert 0
          ' return what we can:
          Set ppOutGroupLayer = pOutGroupLayer
          Set ppOutAnimationTracks = pAniTracks
        Exit Function
      End If
     End If
       
    ' create the new animation track:
    Set pTrack = New AnimationTrack
    pTrack.EvenTimeStamps = False
    
    ' set the name of the track:
    pTrack.name = sBaseTrackName & pAniTracks.Count + 1
    
    ' and set the type:
    Dim pAT As IAnimationType
    Set pAT = New AnimationTypeLayer
    Set pTrack.AnimationType = pAT

    ' clone the layer and add to the group layer:
    Dim pNewSymbolLayer As ILayer
    
    If TypeOf pSymbolLayer Is IFeatureLayer Then

      Set pNewSymbolLayer = CloneSingleElement_FeatureLayer(pSymbolLayer)
      
    ElseIf TypeOf pSymbolLayer Is ICadLayer Then
      Set pNewSymbolLayer = CloneSingleElement_CadLayer(pSymbolLayer)
    ElseIf TypeOf pSymbolLayer Is IGraphicsLayer Then
      Set pNewSymbolLayer = CloneSingleElement_GraphicsLayer(pSymbolLayer)
    Else
      MsgBox "Symbol layer was not of type FeatureLayer, CADLayer, or GraphicsLayer.", vbExclamation, "Import Event Values"
    End If
    
    If pNewSymbolLayer Is Nothing Then
      MsgBox "There was an error cloning " & pSymbolLayer.name & ".", vbExclamation, "Import Event Values"
      Exit Function
    End If
    
    ' name the outgoing layer, and add to group layer:
    Set pLayerNaming = pNewSymbolLayer
    
    Set pQF_FID = New QueryFilter
    pQF_FID.SubFields = "*.*"
    pQF_FID.WhereClause = sIDName & lID
  
    ' set either a feature or row variable:
    If bUseFeatures Then
      Set pFC_FID = pFeatureLayer.Search(pQF_FID, False)
      Set pTrackFeat = pFC_FID.NextFeature ' will be only one with this FID
    Else
      Set pRC_FID = pStandAloneEventTable.Search(pQF_FID, False)
      Set pTrackRow = pRC_FID.NextRow
    End If

    ' validate that we can continue:
    If (bUseFeatures And pTrackFeat Is Nothing) Or (Not bUseFeatures And pTrackRow Is Nothing) Then
      MsgBox "Error searching records.", vbExclamation, "Import Event Values"
      Exit Function
    End If
    
    ' calculate track start and finish time for the new track
    ' by looking at the attribute table for the time events:
    Dim nTrackBegin As Double
    Dim nTrackEnd As Double
    Dim nBegin As Double
    Dim nEnd As Double
    Dim sTimeString As String
    Dim nTime As Double
    nBegin = 1000000000
    nEnd = -1000000000
    Dim nSec As Double
    Dim nMin As Double
    Dim nHour As Double
    Dim nKeyStart As Double
    Dim sBegin As String
    Dim sEnd As String
    Dim bUseThisEvent As Boolean
    
    ' use 0 and 1 for track begin and end times:
    ' store the begin and end times:
    nTrackBegin = 0
    nTrackEnd = 1
    pTrack.BeginTime = 0
    pTrack.EndTime = 1

    ' for each time event for this group, add to the current track
    ' as a layer keyframe:
    If bUseFeatures Then
      Set pRow = pTrackFeat
    Else
      Set pRow = pTrackRow
    End If
    
    Dim bUseEvent As Boolean
    
    ' create a new keyframe:
    Set pKeyFrame = New LayerKeyframe
    
    ' the time stamp from the attribute table:
    sTimeString = pRow.Value(nTimeFieldIndex)
    pLayerNaming.name = sTimeString
    
    ' decide whether or not to use this event- if we are not using a time range filter, then it is ok,
    ' otherwise ensure the event happened inside this range:
    If Not bUseTimeFilter Then
      bUseEvent = True
    Else
      If (CDate(sTimeString) >= CDate(sTimeFilterStart)) And (CDate(sTimeString) <= CDate(sTimeFilterEnd)) Then
        bUseEvent = True
      Else
        Debug.Print "Event with timestamp " & sTimeString & " filtered out keyframe import."
        bUseEvent = False
      End If
    End If
    
    ' MAIN KEYFRAME LOOP (only event per track; several keyframes to control animation) ===============================================================
    If Not pRow Is Nothing And bUseEvent Then
    
      nTime = TokenTime(sTimeString)


      ' DETERMINE THE LOCATION OF THE EVENT.
      ' the layer transformation is the difference between the
      ' time event location and the symbol layer location:
      If bUseFeatures And (nXFieldIndex < 1 And nYFieldIndex < 1) Then
        nTrackX = pTrackFeat.Shape.Envelope.xmin
        nTrackY = pTrackFeat.Shape.Envelope.ymin
      Else
        nTrackX = pRow.Value(nXFieldIndex)
        nTrackY = pRow.Value(nYFieldIndex)
      End If

      nTrackZ = 0
      Dim sZValue As String
      Dim sZValue2 As String
      Dim iZ As Integer
      Dim sZ1 As String
      
      If bUseFeatures And nZFieldIndex < 1 Then
        If Not IsNaN(pTrackFeat.Shape.Envelope.zmin) Then
          nTrackZ = (pTrackFeat.Shape.Envelope.zmin + pTrackFeat.Shape.Envelope.zmax) / 2
        End If
      ElseIf (Not bUseFeatures And nZFieldIndex <> -1) Or (bUseFeatures And nZFieldIndex <> -1) Then
        sZValue = pRow.Value(nZFieldIndex)
        sZValue2 = ""
        ' for now, remove any non-numeric values: 'todo:
        If Not IsNumeric(sZValue) Then
          For iZ = 0 To Len(sZValue) - 1
            sZ1 = Mid(sZValue, iZ + 1, 1)
            If IsNumeric(sZ1) Or sZ1 = "." Then sZValue2 = sZValue2 + sZ1
          Next
        Else
          sZValue2 = sZValue
        End If
        nTrackZ = CDbl(sZValue2)
      Else
        nTrackZ = 0
      End If
      nTrackZ = nTrackZ + nZOffset
      
      ' determine the layer transformation properties:
      nTransX = nTrackX - nSymbolLayerX
      nTransY = nTrackY - nSymbolLayerY
      nTransZ = nTrackZ - nSymbolLayerZ
      nTransZ = nTransZ * nZUnitConversion
  
      ' encapsulate the layer transformation for this keyframe into a point:
      Dim pPt As IPoint
      Set pPt = New Point
      pPt.X = nTransX
      pPt.Y = nTransY
      pPt.Z = nTransZ
      
      ' determine the scale of the event from the attribute:
      Dim pPtScale As IPoint
      Set pPtScale = New Point
      
      Dim sValue
      sValue = pRow.Value(nEventValueField)
      Dim nValue As Double
      
      If IsNumeric(sValue) Then
        nValue = CDbl(sValue)
        nValue = nValue * nEventScale
      Else
        nValue = 1
      End If
      
      If bAnimateXScale Then
        pPtScale.X = nValue
      Else
        pPtScale.X = 1
      End If
      
      If bAnimateYScale Then
        pPtScale.Y = nValue
      Else
        pPtScale.Y = 1
      End If
      
      If bAnimateZScale Then
        pPtScale.Z = nValue
      Else
        pPtScale.Z = 1
      End If
      
      ' add a invisible keyframe for the first keyframe of each track so that when
      ' the animation starts, the layer will be not visible:
      If bHideEventAtStartAndFinish Then
        Set pKeyFrame = New LayerKeyframe
        pKeyFrame.PropertyValueBoolean(0) = False
        pTrack.InsertKeyframe pKeyFrame, 0
        pKeyFrame.PropertyValuePoint(2) = pPt
        pKeyFrame.TimeStamp = 0
        pKeyFrame.PropertyValuePoint(3) = pPtScale
      End If
    
      ' set time stamp - this is the proportionate starting time for the track in the
      ' entire event time range:
      nKeyStart = (nTime - nAniStartTime) / (nAniEndTime - nAniStartTime)
        
      
      'Debug.Print "Record: " & nNumFeatures & " - " & sTimeString & " (" & nKeyStart & ")" & " - " & nTime


      ' do an static keyframe right before the event:
      ' create a new keyframe:
      Set pKeyFrame = New LayerKeyframe
      pTrack.InsertKeyframe pKeyFrame, pTrack.KeyframeCount
      pKeyFrame.TimeStamp = nKeyStart - 0.00000001
      pKeyFrame.PropertyValueBoolean(0) = False
      pKeyFrame.PropertyValuePoint(2) = pPt
      If pKeyFrame.TimeStamp < 0 Then pKeyFrame.TimeStamp = 0
      pKeyFrame.PropertyValuePoint(3) = pPtScale
      
      ' insert the event keyframe into the track: