传统地震灾情评估系统中对于地震影响场的计算是基于点源的圆模型及椭圆模型得出,并未考虑到大地震的实际破裂尺度,而本次汶川地震其破裂尺度达300公里,导致现有评估系统对震害的评估结果与实际差别较大.因此花了一天时间做出新的基于线源破裂的新地震影响场计算模型的实验代码.下一步有时间的话打算用AE重新开发一个独立的评估系统.
具体实现可见下图~~
当破裂方向为0时以最近活断层走向为破裂方向,当破裂尺度为0时采用华北地区地震破裂尺度与震级关系模型进行计算.


'========================== DZYXC ==========================
Public Function CreateEArcFull(pEnv As IEnvelope) As IEllipticArc
   Dim pConstEArc As IConstructEllipticArc
   Set pConstEArc = New EllipticArc
   pConstEArc.ConstructEnvelope pEnv
   Set CreateEArcFull = pConstEArc
End Function
Public Function GetFeatureLayer(strLayername As String) As IFeatureLayer
  Dim pMxDoc As IMxDocument
  Set pMxDoc = ThisDocument
  Dim pMap As IMap
  Set pMap = pMxDoc.FocusMap
  Dim pFeatureLayer As IFeatureLayer
  Dim i As Integer
  For i = 0 To pMap.LayerCount - 1
    If pMap.Layer(i).Name = strLayername Then
      Set pFeatureLayer = pMap.Layer(i)
      Exit For
    End If
  Next
  If pFeatureLayer Is Nothing Then
    MsgBox "找不到[" & strLayername & "]图层！", vbCritical, "DZPG"
    Exit Function
  End If
  Set GetFeatureLayer = pFeatureLayer
End Function
Public Function CreatEllipticFeatrue(pPoint As IPoint, dLong As Double, dShort As Double, iIntensity As Integer) As Boolean
'获取FeatureClass
  Dim pMxDoc As IMxDocument
  Set pMxDoc = ThisDocument
  Dim pMap As IMap
  Set pMap = pMxDoc.FocusMap
  Dim pFea