bastrackingimport.bas

esir公司的产品MapObject的vb例子

      If bSetKeyframeAzimuth And bSetAdditionalKeyframeForAzimuth And Not pFakeAzimuthKeyframe Is Nothing Then 'work
        
        pTrack.InsertKeyframe pFakeAzimuthKeyframe, pTrack.KeyframeCount
        pFakeAzimuthKeyframe.PropertyValuePoint(2) = pPt
        pFakeAzimuthKeyframe.TimeStamp = nKeyStart
        pFakeAzimuthKeyframe.name = "AZI- " & varIDS(i) & " - " & sTimeString
      End If

      ' insert the keyframe into the track:
      pTrack.InsertKeyframe pKeyFrame, pTrack.KeyframeCount

      With pKeyFrame
        ' set translation property:
        .PropertyValuePoint(2) = pPt
      
        .TimeStamp = nKeyStart
  
        ' set the keyframe name:
        .name = varIDS(i) & " - " & sTimeString
      End With

      
    End If  ' bUseEvent

      ' UPDATE THE CURSOR TO THE NEXT RECORD.
      ' do this here because if we are setting azimuth, we need to know the position
      ' of the next event:
      If bUseRecordsCurrentSorting Then
        If bUseFeatures Then
          Set pTrackFeat = pCursorEvents.NextRow
          Set pRow = pTrackFeat
        Else
          Set pTrackRow = pCursorEvents.NextRow
          Set pRow = pTrackRow
        End If
      Else
        Set pQF_FID = New QueryFilter
        pQF_FID.SubFields = "*.*"
        lID = pIDSorted.Next
        pQF_FID.WhereClause = sIDName & lID
        If bUseFeatures Then
          Set pFC_FID = pFeatureLayer.Search(pQF_FID, False)
          Set pTrackFeat = pFC_FID.NextFeature
          Set pRow = pTrackFeat
        Else
          Set pRC_FID = pStandAloneEventTable.Search(pQF_FID, False)
          Set pRow = pRC_FID.NextRow
          Set pTrackRow = pRow
          
        End If
        
      End If
      
    If bUseEvent Then
      ' if requested, set the azimuth of this keyframe- calculate this value by
      ' looking at the next event location:
      Dim dAzi As Double
      Dim nTrackX2 As Double, nTrackY2 As Double, nTrackZ2 As Double
      
      
      If bSetKeyframeAzimuth Then
            
        If (bUseFeatures And Not pTrackFeat Is Nothing) Or (bUseFeatures And (nXFieldIndex > 0 And nYFieldIndex > 0) And Not pTrackRow Is Nothing) Then
          ' determine the position of the subsequent event:
          If bUseFeatures Then
            nTrackX2 = pTrackFeat.Shape.Envelope.xmin
            nTrackY2 = pTrackFeat.Shape.Envelope.ymin

          Else
            nTrackX2 = pTrackRow.Value(nXFieldIndex)
            nTrackY2 = pTrackRow.Value(nYFieldIndex)
          End If
          
          ' calculate the azimuth:
          dAzi = ArcTan2(nTrackX2 - nTrackX, nTrackY2 - nTrackY)
          
          ' track the last azimuth, since we will use that for the last keyframe:
          dLastAzi = dAzi
        
        ElseIf Not bUseFeatures And Not pRow Is Nothing Then
          nTrackX2 = pRow.Value(nXFieldIndex)
          nTrackY2 = pRow.Value(nYFieldIndex)
  
          ' calculate the azimuth:
          dAzi = ArcTan2(nTrackX2 - nTrackX, nTrackY2 - nTrackY)
          
          ' track the last azimuth, since we will use that for the last keyframe:
          dLastAzi = dAzi
          
        Else
          ' this is the last keyframe:
          dAzi = dLastAzi
        End If
      
        ' store the azimuth value (rotation Z) as a point, and add to the keyframe:
        Dim pAziPt As IPoint
        Set pAziPt = New Point
        pAziPt.X = 0
        pAziPt.Y = 0
        pAziPt.Z = dAzi * 180 / 3.1415926
        pKeyFrame.PropertyValuePoint(4) = pAziPt
      

        If bSetAdditionalKeyframeForAzimuth Then
          Set pFakeAzimuthKeyframe = New LayerKeyframe
          Set pAziPt = New Point
          pAziPt.X = 0
          pAziPt.Y = 0
          pAziPt.Z = dAzi * 180 / 3.1415926
          pFakeAzimuthKeyframe.PropertyValuePoint(4) = pAziPt
        End If

      Else
        Set pFakeAzimuthKeyframe = Nothing
      End If
      
      ' update our debug counter:
      nNumFeatures = nNumFeatures + 1
       
    End If  ' bsuseevent

      DoEvents
    Loop
    
    Set pFakeAzimuthKeyframe = Nothing
    
    Debug.Print " - " & nNumFeatures & " records."
    OffsetProgressMSG " - " & nNumFeatures & " records.", False
    
    ' insert two final invisible keyframes at end:
    Dim nT As Double
    If bHideEventAtStartAndFinish Then
      nT = pKeyFrame.TimeStamp
      nT = nKeyStart + 0.000000001
      Set pKeyFrame = New LayerKeyframe
      pKeyFrame.PropertyValueBoolean(0) = False
      pKeyFrame.PropertyValueInt(1) = 100
      pTrack.InsertKeyframe pKeyFrame, pTrack.KeyframeCount
      pKeyFrame.TimeStamp = nT
      
      Set pKeyFrame = New LayerKeyframe
      pKeyFrame.PropertyValueBoolean(0) = False
      pKeyFrame.PropertyValueInt(1) = 100
      pTrack.InsertKeyframe pKeyFrame, pTrack.KeyframeCount
      pKeyFrame.TimeStamp = 1
      
    End If
    
    ' attach the new track to the layer to be animated:
    ' add the track to the collection:
    If pTrack.KeyframeCount > 3 Then
      pOutGroupLayer.Add pNewSymbolLayer
      ' attach the new track to the layer to be animated:
      pTrack.AttachObject pNewSymbolLayer
    
      pAniTracks.Add pTrack
    End If
    
    nTrackCount = nTrackCount + 1 ' update our debug counter
    
    DoEvents
  Next
  
  ' set the return variables:
  Set ppOutGroupLayer = pOutGroupLayer
  Set ppOutAnimationTracks = pAniTracks
  
  ' end
  Debug.Assert 0

  ReDim varIDS(0)
  Dim bSuccess As Boolean
  bSuccess = (Not ppOutGroupLayer Is Nothing) And (Not ppOutAnimationTracks Is Nothing) And (ppOutAnimationTracks.Count > 0)
  ImportTrackingPointsToLayerKeyframes = bSuccess ' return success
  SetDoneWorkingState
  Exit Function
  
ImportTrackingPointsToLayerKeyframes_ERR:
  Debug.Assert 0
  If MsgBox("ImportTrackingPointsToLayerKeyframes_ERR: " & err.Description & vbCrLf & "Resume?", vbYesNo, "Import Tracking Points") = vbYes Then
    Debug.Assert 0
    Resume Next
  End If

  
  Set ppOutGroupLayer = Nothing
  Set ppOutAnimationTracks = Nothing
  ImportTrackingPointsToLayerKeyframes = False
  SetDoneWorkingState
End Function
'
' Accepting a feature layer or standalone table with attributes defining the position of
' and time of an event (such as the location of an earthquake), and an attribute name which will
' link the event to a value (such as earthquake magnitude),
' 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 ZScale through the event time range
' depending on the attribute designated.
' Additional parameters control the filtering of events via their selection or time range,
' a height offset and\or z conversion, and scale for the value attribute.
'
Public Function ImportEventValuePointsToLayerKeyframes(pLayerWithSelection As ILayer, pORStandAloneTable As IStandaloneTable, sTimeStampField As String, _
sEventValueField As String, pSymbolLayer As ILayer, sOutputGroupLayerName As String, _
ByRef ppOutAnimationTracks As Collection, ByRef ppOutGroupLayer As IGroupLayer, _
bAnimateXScale As Boolean, bAnimateYScale As Boolean, bAnimateZScale As Boolean, _
Optional nEventScale As Double = 1, _
Optional nZOffset As Double = 0, _
Optional nZUnitConversion As Double = 1, _
Optional nEventDuration As Double = 0.02, _
Optional sTimeFilterStart As String, Optional sTimeFilterEnd As String, _
Optional sXFieldName As String, Optional sYFieldName As String, Optional sZFieldName As String, _
Optional bUseSelectedEvents As Boolean, _
Optional bHideEventAtStartAndFinish As Boolean = True, _
Optional sBaseTrackName As String = "Import Track", Optional nProgBarOwnerHWND As Long) As Boolean

  Debug.Assert 0
  On Error GoTo ImportEventValuePointsToLayerKeyframes_ERR
  
  Dim sTotalEventsStartTime As String
  Dim sTotalEventsEndTime As String
  Dim nEventValueField 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 pF As IField
  Dim i As Long
  Dim bFound As Boolean
  Dim sEventValueField2 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 bUseTimeFilter As Boolean
  Dim nMaxTracks As Long
  Dim p3DFProps As I3DProperties
  Dim sExtrudeHeight As String
  Dim nExtrudeType As Integer
  Dim sExtrudeHeight2 As String
  
  ReDim varIDS(0)
  nZFieldIndex = -1
  nXFieldIndex = -1
  nYFieldIndex = -1
  
  If Right(sBaseTrackName, 1) <> " " Then sBaseTrackName = sBaseTrackName & " "
 
  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 Event Values"
      Exit Function
    End If
    bUseFeatures = True
  ElseIf Not pORStandAloneTable Is Nothing Then
    bUseFeatures = False
  Else
    MsgBox "No valid input was designated.", vbExclamation, "Import Event Values"
    Exit Function
  End If
  
  If pSymbolLayer Is Nothing Then
    MsgBox "No layer to animate was found.", vbExclamation, "Import Event Values"
    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 Event Values"
    Exit Function
  End If
  
  ' get the index of the event value field:
  nEventValueField = pCursorEvents.FindField(sEventValueField)
  If nEventValueField < 1 Then  ' try modifying the field name to use underscores:
    sEventValueField2 = Replace(sEventValueField, " ", "_")
    nEventValueField = pCursorEvents.FindField(sEventValueField2)
  Else
    sEventValueField2 = sEventValueField  ' the original fieldname to use is OK
  End If
  If nEventValueField < 0 Then
    MsgBox "There was a error accessing field: " & sEventValueField & ".", vbExclamation, "Import Event Values"
    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 Event Values"
    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 Event Values"
      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 Event Values"
      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