bastrackingimport.bas

esir公司的产品MapObject的vb例子

      Set pKeyFrame = New LayerKeyframe
      pTrack.InsertKeyframe pKeyFrame, pTrack.KeyframeCount

      With pKeyFrame
        ' set translation property:
        .PropertyValuePoint(2) = pPt
      
        ' set Z scale property:
        .PropertyValuePoint(3) = pPtScale
        .TimeStamp = nKeyStart
  
        ' set the keyframe name:
        .name = sTimeString
      End With

      
    End If  ' bUseEvent and not pRow is nothing

    ' UPDATE THE CURSOR TO THE NEXT RECORD.
    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

    nNumFeatures = nNumFeatures + 1
    DoEvents
    
    ' insert one final invisible keyframe after event, and at end of track if requested:
    Dim nT As Double
    If bHideEventAtStartAndFinish Then
      nT = pKeyFrame.TimeStamp
      nT = nKeyStart + nEventDuration '0.02
      Set pKeyFrame = New LayerKeyframe
      pKeyFrame.PropertyValueBoolean(0) = False
      pKeyFrame.PropertyValueInt(1) = 100
      pKeyFrame.PropertyValuePoint(2) = pPt
      pKeyFrame.PropertyValuePoint(3) = pPtScale
      pTrack.InsertKeyframe pKeyFrame, pTrack.KeyframeCount
      pKeyFrame.TimeStamp = nT
      
      Set pKeyFrame = New LayerKeyframe
      pKeyFrame.PropertyValueBoolean(0) = False
      pKeyFrame.PropertyValueInt(1) = 100
      pKeyFrame.PropertyValuePoint(3) = pPtScale
      pTrack.InsertKeyframe pKeyFrame, pTrack.KeyframeCount
      pKeyFrame.TimeStamp = 1
      pKeyFrame.PropertyValuePoint(2) = pPt
    End If
    
    ' attach the new track to the layer to be animated:
    ' add the track to the collection:
    pOutGroupLayer.Add pNewSymbolLayer
    ' attach the new track to the layer to be animated:
    pTrack.AttachObject pNewSymbolLayer
  
    pTrack.name = sTimeString
    pAniTracks.Add pTrack

    
    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)
  ImportEventValuePointsToLayerKeyframes = bSuccess ' return success
  SetDoneWorkingState
  Exit Function
  
ImportEventValuePointsToLayerKeyframes_ERR:
  Debug.Assert 0
  If MsgBox("ImportEventValuePointsToLayerKeyframes_ERR: " & err.Description & vbCrLf & "Resume?", vbYesNo, "Import Event Values") = vbYes Then
    Debug.Assert 0
    Resume Next
  End If

  
  Set ppOutGroupLayer = Nothing
  Set ppOutAnimationTracks = Nothing
  ImportEventValuePointsToLayerKeyframes = False
  SetDoneWorkingState
End Function

'
' remove any 'busy' cursor
'
Public Sub SetDoneWorkingState()
      
  On Error Resume Next

  If Not m_pProgDialog Is Nothing Then
    OffsetProgressMSG "Done", True
    m_pProgDialog.HideDialog
    Set m_pProgDialog = Nothing
  End If


        
End Sub

'
' increment the progress dialog, including a message
'
Private Function OffsetProgressMSG(Message As String, bIncrement As Boolean, Optional MaxRange As Long, Optional MinRange As Long, Optional ProgBarOwnerHWND As Long, Optional Position As Long) As Boolean
  On Error GoTo OffsetProgMSG_ERR

  If m_pProgDialog Is Nothing Then
    Dim p As IProgressDialogFactory
    Set p = New ProgressDialogFactory
    Set m_pTrackCancel = New CancelTracker
    With m_pTrackCancel
      .CancelOnClick = True
      .CancelOnKeyPress = True
    End With
    Set m_pProgDialog = p.Create(m_pTrackCancel, ProgBarOwnerHWND)
    Set m_pStepProgressor = m_pTrackCancel.Progressor
    With m_pStepProgressor
      .MaxRange = MaxRange
      .MinRange = MinRange
      .Show
    End With
    m_pProgDialog.ShowDialog
  End If
    
  With m_pTrackCancel
    .Progressor.Message = Message
    If Not .Continue() Then
      Debug.Assert 0
      OffsetProgressMSG = True
    End If
  End With
    
  With m_pStepProgressor
  
    If bIncrement Then
      If Position > 0 And MaxRange > 0 And MinRange > -1 Then
        .MaxRange = MaxRange
        .MinRange = MinRange
        .Position = Position
      Else
        .OffsetPosition 1
      End If
    End If
    
  End With

  DoEvents
  
  Exit Function
    
OffsetProgMSG_ERR:
    Resume Next
    
End Function
'
' return an IFeatureCursor from the layer\queryfilter
'
Private Function priv_GetFeatureCursorFromLayer(pLayer As ILayer, pQF As IQueryFilter) As ICursor
  On Error GoTo EH
  
  Dim pFeatLayer As IFeatureLayer
  Dim pFeatClass As IFeatureClass
  Dim pFeatCursor As IFeatureCursor
  
  ' get the feature cursor:
  Set pFeatLayer = pLayer
  Set pFeatClass = pFeatLayer.FeatureClass
  Set pFeatCursor = pFeatClass.Search(pQF, False)
    
  ' return:
  Set priv_GetFeatureCursorFromLayer = pFeatCursor
    
  Exit Function
    
EH:
  Debug.Print "GetFeatureCursor_ERR: " & err.Description
  Debug.Assert 0
End Function
'
' return a feature cursor for all records in the table
'
Private Function priv_GetAllRecords(pSOT As IStandaloneTable, pQF As IQueryFilter) As ICursor
  On Error GoTo EH
    
  Dim pTable As ITable
  Set pTable = pSOT
  
  ' return:
  Set priv_GetAllRecords = pTable.Search(pQF, True)
    
  Exit Function
    
EH:
  Debug.Print "priv_GetAllRecords: " & err.Description
  Debug.Assert 0
  
End Function
'
'  return an IFeatureCursor for the selected features
'
Private Function priv_GetSelectedFeatures(pLayer As ILayer, bReturnFullOnNoSelection As Boolean, pQF As IQueryFilter) As IFeatureCursor
  On Error GoTo EH
  

  Dim pFLayer As IFeatureLayer
  If pLayer Is Nothing Then Exit Function
  
  '  exit if not applicable:
  If Not TypeOf pLayer Is IFeatureLayer Then
    Exit Function
  End If
  
  Dim pFSelection As IFeatureSelection
  
  Set pFLayer = pLayer
  Set pFSelection = pFLayer
  
  Dim pReturnFeatureCursor As IFeatureCursor
  
  pFSelection.SelectionSet.Search pQF, False, pReturnFeatureCursor

  If bReturnFullOnNoSelection Then
    If pReturnFeatureCursor.NextFeature Is Nothing Then
      Set pReturnFeatureCursor = pFLayer.Search(pQF, True)
    Else
      pFSelection.SelectionSet.Search pQF, True, pReturnFeatureCursor
    End If
    
  Else
    
  End If
  
  Set priv_GetSelectedFeatures = pReturnFeatureCursor
  Exit Function
    
EH:
  Debug.Print "GetSelFeatures_ERR: " & err.Description
  Debug.Assert 0
  Resume Next
End Function

Private Function ArcTan2(X As Double, Y As Double) As Double
  On Error GoTo ArcTan2_ERR
  
  If X > 0 Then
    ArcTan2 = Atn(Y / X)
  ElseIf X < 0 Then
    ArcTan2 = Atn(Y / X) + 3.1415926
  ElseIf Y > 0 Then
    ArcTan2 = 3.1415926 / 2
  Else
    ArcTan2 = -3.1415926 / 2
  End If

  Exit Function
  
ArcTan2_ERR:
  Debug.Print "ArcTan2_ERR: " & err.Description
  Debug.Assert 0
  
End Function
'
' evalutate the value as "Not a Number"
'
Private Function IsNaN(expression As Variant) As Boolean
  On Error Resume Next
  If Not IsNumeric(expression) Then
    IsNaN = False
    Exit Function
  End If
  If (CStr(expression) = "1.#QNAN") Or (CStr(expression) = "1,#QNAN") Then ' can vary by locale
    IsNaN = True
  Else
    IsNaN = False
  End If
End Function
'
' create a double from the date\time value
'
Private Function oldTokenTime(ByVal sTime As String) As Double
  On Error Resume Next
  
  Dim nH As Double, nM As Double, nS As Double
  Dim sDate As String
  Dim sTimeIn As String
  Dim sTime2 As String
  Dim nD As Double
  
  sTimeIn = sTime
  
  sTime2 = Trim(Mid(sTimeIn, InStr(1, sTimeIn, " ", vbTextCompare) + 1))
  sDate = Trim(Mid(sTimeIn, 1, InStr(1, sTimeIn, " ", vbTextCompare)))
  
  If 0 = 1 Then
    nD = CDbl(Format(sDate, "dmy"))
  Else
    Dim nMonth As Double, nDay As Double, nY As Double
    
    nDay = CDbl(Format(sDate, "dd") * dayF)
    nMonth = CDbl(Format(sDate, "mm") * monthF)
    nY = CDbl(Format(sDate, "yyyy"))
    nD = nY + nMonth + nDay

  End If
  
  nH = CDbl(Format(sTime2, "hh"))
  nM = CDbl(Format(sTime2, "nn") * minF)
  nS = CDbl(Format(sTime2, "ss") * secF)

  Dim dReturn As Double
  dReturn = nD + nH + nM + nS
  oldTokenTime = dReturn
  

End Function
'
' create a double from the date\time value
'
Private Function TokenTime(ByVal sTime As String) As Double
  On Error Resume Next
  
  Dim nYear As Integer, nMonth As Integer, nDay As Integer
  Dim nHour As Integer, nMinute As Integer, nSecond As Integer
  
  Dim nYear2 As Double, nMonth2 As Double, nDay2 As Double
  Dim nHour2 As Double, nMinute2 As Double, nSecond2 As Double
  
  Dim sDate2 As String
  Dim sTimeIn As String
  Dim sTime2 As String

  ' separate the date and time in the string:
  sTimeIn = sTime
  sTime2 = Trim(Mid(sTimeIn, InStr(1, sTimeIn, " ", vbTextCompare) + 1))
  sDate2 = Trim(Mid(sTimeIn, 1, InStr(1, sTimeIn, " ", vbTextCompare)))
  
  nYear = Format(sDate2, "YYYY")
  nMonth = Format(sDate2, "MM")
  nDay = Format(sDate2, "DD")
  
  nHour = Format(sTime2, "HH")
  nMinute = Format(sTime2, "nn")  ' why nn, not mm?
  nSecond = Format(sTime2, "ss")
  
  Dim nDaysInMonth As Integer
  
  ' convert all date\times into hours:
  nHour2 = nHour * 1
  nMinute2 = nMinute * minF
  nSecond2 = nSecond * secF
  nDay2 = (nDay - 1) * (24)
  
  ' determine the number of hours