kzfrm.frm

持续时间震级计算vb源码。利用地震波持续时间同地震震级的相关性来反映震源强度

      PicW.Line (j, AE.wavedata(j))-(j + 1, AE.wavedata(j + 1)), vbBlue

     Next j
     
End Sub
Private Sub CmdInput_Click()
 Start = 1
 over = KZ.SampleLength
 
 GetAverage
 'PicW.Cls
 'drawWave
 Beishu = Val(TextBeishu.Text)
 Call drawline(Beishu, Start, over)
End Sub
Private Sub CheckdrawWZoom_Click()
If CheckdrawWZoom.Value = True Then
     Zoom = True
     PicW.MousePointer = 2
     DoEvents
Else
     Zoom = False
     PicW.MousePointer = 1
End If
End Sub

Private Sub picw_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
 
 If Button = 1 And Zoom = True Then
        
        x1 = x
        x2 = x1
        y1 = y
        y2 = y1
        
        Call RubberLine(PicW, x1, y1, x2, y2)
         
    'Else
        'PicW.DrawMode = 7
        'PicW.Line (Lx, PicW.ScaleTop)-(Lx, PicW.ScaleTop + PicW.ScaleHeight), 255
        'Lx = x
        'PicW.Line (Lx, PicW.ScaleTop)-(Lx, PicW.ScaleTop + PicW.ScaleHeight), 255
  End If
   
End Sub

Private Sub PicW_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
     If Zoom = True And Button = 1 Then
        
        x2 = x
        y2 = y
        Call RubberLineErase(PicW)
        Call RubberLine(PicW, x1, y1, x2, y2)
     End If
    Label2.Caption = x + WinT0
    Label1.Caption = y
    
End Sub

Private Sub PicW_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
   Dim k As Long
   Dim w As Single
   Dim j As Long
   Dim n1 As Long, n2 As Long
   Dim t1 As Currency, t2 As Currency
   Dim En As Long, Em As Long
   
If Zoom = True And Button = 1 Then
    x2 = x
    y2 = y
    Call RubberLineErase(PicW)
    
    If x2 < x1 Then Call Swap(x1, x2)
    If y2 < y1 Then Call Swap(y1, y2)
    PicW.Cls
    n1 = Int(x1)
    n2 = Int(x2)
    PicW.Scale (n1, 1500)-(n2, -1500)

    For j = n1 To n2
      PicW.Line (j, wavedata(j))-(j + 1, wavedata(j + 1)), vbBlue
    Next j
   
    
   If Val(TextBeishu.Text) <> 1 Then
      'Draw_startLine
      'Call drawline(Beishu, n1, n2)
      'PicW.Line (n1, 0)-(n2, 0), 0
   End If
    
    Call drawline1(Sdev_Extremum)
End If

End Sub

 

Private Sub MaxValue()
 Dim i As Long
  Max = AE.wavedata(1)
 For i = 1 To KZ.SampleLength
      If AE.wavedata(i) > Max Then
           Max = AE.wavedata(i)
           M = i
      End If
    Min = AE.wavedata(1)
      If AE.wavedata(i) < Min Then
       Min = AE.wavedata(i)
      End If
 Next i
 
    
 
End Sub
Private Sub Form_Resize()

   'PicW.Width = frmDATADemo.ScaleWidth
    'frmDATADemo.ScaleHeight = 10000
    
    
    With KZfrm
     
     PicW.Left = .ScaleLeft
     PicW.Top = .ScaleTop
     PicW.Width = .ScaleWidth
   '  PicW.Height = (.ScaleHeight - Pictools.Height) / 2

     
     PicSdev.Left = .ScaleLeft
     PicSdev.Top = .ScaleTop + PicW.Height
     PicSdev.Width = .ScaleWidth
   '  PicSdev.Height = .ScaleHeight - Pictools.Height - PicW.Height
     
   End With
   
End Sub


Private Sub drawline(Beishu As Single, Start As Long, over As Long)
 LabAverage.Caption = AVE
 LabBeishu.Caption = Beishu * SDEV
 LabSquare.Caption = SDEV
 PicW.Line (Start, AVE + Beishu * SDEV)-(over, AVE + Beishu * SDEV), vbGreen
 PicW.Line (Start, AVE - Beishu * SDEV)-(over, AVE - Beishu * SDEV), vbGreen
 Draw_startLine
 Draw_overLine1
 'Draw_overLine2
 txtMaxT.Text = MaxT
End Sub
Private Sub Draw_startLine()
Dim i As Long
Dim k As Long
Dim j As Long
    k = 0
Call KZ.GetWaveDATA(1, ns, wavedata)
   For i = 100 To AE.SampleLength
    If AE.wavedata(i) - Abs(AVE) > Beishu * SDEV Then
       
        Exit For
        
    End If
    j = i
   Next i
PicW.Line (j - 200, 3000)-(j - 200, -3000), 200
TextPoint.Text = j

End Sub
Private Sub Draw_overLine1()

Dim i As Long
Dim k As Long
Dim j As Long
    k = 0
Call KZ.GetWaveDATA(Direction, ns, wavedata)
   For i = 1 To AE.SampleLength - 1
    If AE.wavedata(AE.SampleLength - i) - Abs(AVE) > Beishu * SDEV Then
        Exit For
    End If
    j = AE.SampleLength - i
  Next i
  MaxT = j
PicW.Line (j, 3000)-(j, -3000), 200
End Sub

Private Sub Draw_overLine2()
Dim i As Long
Dim k As Long
Dim j As Long
Dim sp As Double

    k = 0
Call KZ.GetWaveDATA(Direction, ns, wavedata)

sp = AE.wavedata(1)
For i = 2 To AE.SampleLength
    If AE.wavedata(i) > sp Then
       sp = AE.wavedata(i)
    End If
Next i
   For i = 1 To AE.SampleLength - 1
   j = AE.SampleLength - i
    If Abs(AE.wavedata(AE.SampleLength - i)) > Beishu * sp Then
        Exit For
    End If
   Next i
   MaxT = j
PicW.Line (j, 3000)-(j, -3000), 200
End Sub
Private Sub GetAverage()
   Dim chufa As Long
   Dim Sum As Long
   Dim Sum1 As Double
   Dim i As Long
   Dim pretrig As Long
     AVE = 0#
     SDEV = 0#
     pretrig = AE.TrigLevel / 100 * AE.SampleLength
     chufa = pretrig - Int(pretrig * 0.1)
  
     Sum = 0#
     For i = 1 To chufa
       Sum = AE.wavedata(i) + Sum
     Next i
     
     AVE = Sum / (chufa - 1)
     
     Debug.Print AVE
     'PicW.Line (1, AVE)-(AE.Samplelength, AVE), vbBlue
     
     Sum1 = 0#
     For i = 1 To chufa
       Sum1 = (AE.wavedata(i) - AVE) ^ 2 + Sum1
     Next i
     SDEV = Sqr(Sum1 / (chufa - 1))
     
End Sub

Private Function Get_Sdev(begin As Long, finish As Long) As Double
  Dim i As Long
  Dim s As Long, s1 As Double
  Dim average As Double
  
  s = 0#
  For i = begin To finish
   s = s + AE.wavedata(i)
  Next i
  average = s / (finish - begin)
  
  s1 = 0#
  For i = begin To finish
   s1 = (AE.wavedata(i) - average) ^ 2 + s1
  Next i
  Get_Sdev = Sqr(s1 / (finish - begin))
  
  
End Function
Private Sub drawline1(i As Long)

 PicW.Line (i, 3000)-(i, -3000), vbGreen
End Sub
Private Function Sdev_Extremum() As Long
 Dim i As Long
 Dim Squre1() As Double
 Dim Squre2() As Double
 Dim Ratio() As Double
 Dim Extremum As Double
 Dim Length As Long
 
 MaxValue
 Length = Val(TextWin.Text)
 
 ReDim Squre1(1 To M) As Double
 ReDim Squre2(1 To M) As Double
 ReDim Ratio(1 To M) As Double

 For i = 1 To M - Length
   Squre1(i) = Get_Sdev(i, i + Length)
 Next i
 
 For i = Length + 1 To M
   Squre2(i) = Get_Sdev(i, i + Length)
 Next i
 
 i = 1
 
 Do
   If Abs(Squre1(i)) < 0.001 Then Squre1(i) = 1#
   Ratio(i) = Squre2(i + Length) / Squre1(i)
   i = i + 1
 Loop Until i > M - Length
 'End If
 
 Extremum = Ratio(1)
 
 For i = 1 To M - Length
      If Ratio(i) > Extremum Then
           Extremum = Ratio(i)
           Sdev_Extremum = i + Length
      End If
      
 Next i
 
End Function
Private Sub draw_Sdev()
 Dim i As Long
 Dim Squre1() As Double
 Dim Squre2() As Double
 Dim Ratio() As Double
 Dim Extremum As Double
 Dim Length As Long
 
 MaxValue
 Length = Val(TextWin.Text)
 ReDim Squre1(1 To AE.SampleLength) As Double
 ReDim Squre2(1 To AE.SampleLength) As Double
 ReDim Ratio(1 To AE.SampleLength) As Double

 For i = 1 To AE.SampleLength - Length
   Squre1(i) = Get_Sdev(i, i + Length)
 Next i
 
 For i = Length + 1 To AE.SampleLength - Length
   Squre2(i) = Get_Sdev(i, i + Length)
 Next i
 
 i = 1
 Do
   If Abs(Squre1(i)) < 0.001 Then Squre1(i) = 1#
   Ratio(i) = Squre2(i + Length) / Squre1(i)
   i = i + 1
 Loop Until i > AE.SampleLength - Length
 
' Extremum = Ratio(1)
 
 'For i = 1 To M - Length
      'If Ratio(i) > Extremum Then
          ' Extremum = Ratio(i)
           'Sdev_Extremum = i + Length
     ' End If
      
 'Next i
PicSdev.Cls
PicSdev.Scale (0, 30)-(AE.SampleLength, -30)
For i = 1 To AE.SampleLength - Length

   PicSdev.Line (i + Length, Ratio(i))-(i + Length + 1, Ratio(i + 1))

Next i


End Sub

Private Sub CmdLine_Click()
 PicW.Cls
 drawWave
 'Line_Extremum
 Call drawline1(Line_Extremum)
End Sub

Private Function Line_Extremum() As Long
 Dim i As Integer
 Dim LineLen1() As Double
 Dim LineLen2() As Double
 Dim Ratio() As Double
 Dim Extremum As Double
 Dim Length As Integer
 
 MaxValue
 Length = Val(TextLine.Text)
 ReDim LineLen1(1 To M) As Double
 ReDim LineLen2(1 To M) As Double
 ReDim Ratio(1 To M) As Double
 
 
 For i = 1 To M - Length
   LineLen1(i) = Get_LineLen(i, i + Length)
 Next i
 
 For i = Length + 1 To M
   LineLen2(i) = Get_LineLen(i, i + Length)
 Next i
 
 i = 1
 Do
   Ratio(i) = LineLen2(i + Length) / LineLen1(i)
   i = i + 1
  
 Loop Until i > M - Length
 
 Extremum = Ratio(1)
 
 For i = 1 To M - Length
      If Ratio(i) > Extremum Then
           Extremum = Ratio(i)
           Line_Extremum = i + Length
      End If
      
 Next i
 
End Function
Private Sub draw_Sdev1()
 Dim i As Integer
 Dim LineLen1() As Double
 Dim LineLen2() As Double
 Dim Ratio() As Double
 Dim Extremum As Double
 Dim Length As Integer
 
 MaxValue
 Length = Val(TextLine.Text)
 ReDim LineLen1(1 To M) As Double
 ReDim LineLen2(1 To M) As Double
 ReDim Ratio(1 To M) As Double
 
 
 For i = 1 To M - Length
   LineLen1(i) = Get_LineLen(i, i + Length)
 Next i
 
 For i = Length + 1 To M
   LineLen2(i) = Get_LineLen(i, i + Length)
 Next i
 
 i = 1
 Do
   Ratio(i) = LineLen2(i + Length) / LineLen1(i)
   i = i + 1
 Loop Until i > M - Length
 
 
      
PicSdev.Cls
PicSdev.Scale (0, 20)-(AE.SampleLength, -20)
For i = 1 To M - Length

   PicSdev.Line (i + Length, Ratio(i))-(i + Length + 1, Ratio(i + 1))

Next i


End Sub

Private Function Get_LineLen(begin As Integer, finish As Integer) As Double
  Dim i As Long
  Dim LineLen() As Double
  Dim s As Double
  
  'MaxValue
  ReDim LineLen(1 To AE.SampleLength) As Double
  
  For i = 1 To AE.SampleLength - 1
    LineLen(i) = Sqr(1 + (AE.wavedata(i + 1) - AE.wavedata(i)) ^ 2)
  Next i
  
  s = 0#
  For i = begin To finish
   s = s + LineLen(i)
  Next i
  Get_LineLen = s
End Function