modulecomm.bas

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

Dim sDrive                  As String
Dim dByteSize               As Double
Dim dSpace                  As Double

DiskName = Left$(DiskName, 3)
If Len(DiskName) < 2 Then DiskName = DiskName + ":\"
If Len(DiskName) < 3 Then DiskName = DiskName + "\"
If Mid$(DiskName, 3, 1) <> "\" Then Mid(DiskName, 3, 1) = "\"
If Mid$(DiskName, 2, 1) <> ":" Then Mid(DiskName, 2, 1) = ":"

lReturn = GetDriveType(DiskName)
Select Case lReturn
    Case DRIVE_UNKNOWN
        DiskType = "Unknown"
    Case DRIVE_NOTEXIST
        DiskType = "Not Found"
    Case DRIVE_REMOVABLE
        DiskType = "Removable"
    Case DRIVE_FIXED
        DiskType = "Fixed"
    Case DRIVE_REMOTE
        DiskType = "Remote"
    Case DRIVE_RAMDISK
        DiskType = "Ram Disk"
    Case DRIVE_CDROM
        DiskType = "CD-ROM"
End Select

lReturn = GetDiskFreeSpace(DiskName, lSectorsPerCluster, lBytesPerSector, lFreeClusters, lTotalClusters)

TotalSpace = 0
FreeSpace = 0

If lFreeClusters >= 65526 Then
  DiskType = DiskType + "(>2G)"
  

End If



If lReturn = 1 Then
   ' Compute and show the total free Mb
' All values are cast to doubles to avoid
' overflow problems for large disks
  FreeSpace = CCur(lSectorsPerCluster) * CCur(lBytesPerSector) * CCur(lFreeClusters)

' Compute and show the total drive Mb
' All values are cast to doubles to avoid
' overflow problems for large disks
  TotalSpace = CCur(lSectorsPerCluster) * CCur(lBytesPerSector) * CCur(lTotalClusters)
End If









End Sub







Public Sub GetRGBComponent(ColorNo As Long, r As Long, G As Long, b As Long)
   r = &HFF And ColorNo
   
   G = (ColorNo \ 256) And &HFF
   
   b = (&HFF0000 And ColorNo) / 65536
End Sub






Public Function GetDirPart(FileName As String) As String
Dim tempStr As String
Dim i As Byte
Dim P As Byte

   i = Len(FileName): P = 0
   Do
     tempStr = Mid$(FileName, i, 1)
     If tempStr = ":" Or tempStr = "\" Then
       P = i
     End If
     i = i - 1
   Loop Until (P > 0) Or (i <= 0)
   
   
   If P > 0 Then
    tempStr = Mid(FileName, 1, P)
   Else
    tempStr = ""
   End If
  GetDirPart = tempStr
  
End Function

Public Function GetSecondFromStr(ByVal TimeStr As String) As Long
   GetSecondFromStr = Val(Mid(TimeStr, 1, 2)) * 3600 + Val(Mid(TimeStr, 4, 2)) * 60 + Val(Mid(TimeStr, 7, 2))
End Function

Public Function LTrimChar(Source As String, CharCode As Byte) As String
Dim i As Integer
Dim L As Integer
   L = Len(Source)
   Do While Asc(Mid$(Source, 1, 1)) = CharCode
      Source = Mid$(Source, 2, Len(Source))
   Loop
   LTrimChar = Source
End Function

Public Sub GetDigitalStr(Source As String, StartPos As Integer, DigitalStr As String)

Dim P1 As Integer, P2 As Integer
Dim L As Integer
Dim i As Integer
Dim tempS As String
Dim Temp1 As String * 1
Dim CharASC As Byte
   P1 = 0: P2 = 0
   i = StartPos
   L = Len(Source)
   
   Do While (P2 = 0) And (i <= L)
     Temp1 = Mid$(Source, i, 1)
     CharASC = Asc(Temp1)
     If P1 = 0 And CharASC >= 43 And (CharASC <= 58) Then P1 = i
     If P1 <> 0 And CharASC < 43 Or P1 <> 0 And (CharASC > 58) Then P2 = i - 1
     i = i + 1
   Loop
   
   'Debug.Print "p1="; P1, "p2="; P2
   If P1 = 0 Then
     DigitalStr = ""
     StartPos = 0
   End If
   If P1 > 0 And P2 = 0 Then
     P2 = Len(Source)
     StartPos = 0
     DigitalStr = Mid$(Source, P1, P2 - P1 + 1)
   End If
   If (P1 > 0) And (P2 >= P1) Then
     DigitalStr = Mid$(Source, P1, P2 - P1 + 1)
     StartPos = P2 + 1
   End If
   

End Sub

Public Function GetFileExt(FileName As String) As String
Dim temp As String
Dim PointPos As Byte, i As Byte

    'PointPos = InStr(FileName, ".")
    
    i = Len(FileName)
    PointPos = 0
    Do While (i > 0) And (PointPos = 0)
      If Mid$(FileName, i, 1) = "." Then PointPos = i
      i = i - 1
    Loop
    If (PointPos > 0) Then
      temp = Mid(FileName, PointPos + 1, 3)
    Else
      temp = ""
    End If
    
    GetFileExt = temp
End Function

Public Sub SplitFileName(FileName As String, Drive As String, path As String, MainFileName As String, ExtFileName As String)
    'Debug.Print "Catalog FileName", FileName

    Drive = GetDriveName(FileName)
    path = GetDirPart(FileName)
    MainFileName = GetMainFileName(FileName)
    ExtFileName = GetFileExt(FileName)
End Sub


Public Function GetMainFileName(FileName As String) As String
Dim temp As String
Dim PointPos As Byte
Dim i As Integer
Dim L As Integer
    
    i = Len(FileName)
    PointPos = 0
    Do While (i > 0) And (PointPos = 0)
      If Mid$(FileName, i, 1) = "." Then PointPos = i
      i = i - 1
    Loop
    
    'PointPos = InStr(FileName, ".")
    
    
    If PointPos > 0 Then
       temp = Mid$(FileName, 1, PointPos - 1)
    Else
       temp = FileName
    End If
    
    i = Len(temp)
    PointPos = 0
    Do While (i > 0) And (PointPos) = 0
      If Mid$(temp, i, 1) = ":" Or Mid$(temp, i, 1) = "\" Then
        PointPos = i
      End If
      i = i - 1
    Loop
    
    If PointPos > 0 Then
      temp = Mid$(temp, PointPos + 1, Len(temp) - PointPos)
    End If
    GetMainFileName = temp
End Function

Public Function GetDriveName(FileName As String) As String
Dim P As Integer
   P = InStr(FileName, ":")
   If P = 2 Then
     GetDriveName = Mid$(FileName, 1, 2)
   Else
     GetDriveName = ""
   End If
   
   



End Function

Public Function GetNextTimeStr(SeedTime As String, Step As Integer) As String
Dim tempH As Long
Dim tempM As Long
Dim tempS As Long
Dim tempHs As String
Dim tempMs As String
Dim tempSs As String



        tempH = Val(Mid(SeedTime, 1, 2))
        tempM = Val(Mid(SeedTime, 4, 2))
        tempS = Val(Mid(SeedTime, 7, 2))
        
        tempS = tempS + Step
        tempM = tempM + tempS \ 60
        tempS = tempS Mod 60
        tempH = tempH + tempM \ 60
        tempM = tempM Mod 60
        tempH = tempH Mod 24
        
        
        tempHs = Mid(str(tempH), 2, 2)
        tempMs = Mid(str(tempM), 2, 2)
        tempSs = Mid(str(tempS), 2, 2)
       
        
        
        
        
        
        tempHs = GetCharStr("0", 2 - Len(tempHs)) + tempHs
        tempMs = GetCharStr("0", 2 - Len(tempMs)) + tempMs
        tempSs = GetCharStr("0", 2 - Len(tempSs)) + tempSs
        
        
        
        
        
        GetNextTimeStr = tempHs + ":" + tempMs + ":" + tempSs
        
End Function

Public Function GetCharStr(Char As String, Num As Byte) As String
Dim i As Byte
Dim temp As String
   temp = ""
   If Num >= 1 Then
   For i = 1 To Num
     temp = temp + Char
   Next i
   End If
   GetCharStr = temp
End Function

Public Sub Swap(a, b)
Dim temp
   temp = a
   a = b
   b = temp
End Sub

Public Function ReplaceFileExt(ByVal FileName As String, Ext As String) As String
Dim i As Integer, L As Integer
Dim quit As Boolean
  quit = False
  L = Len(FileName)
  Do
    If Mid$(FileName, L, 1) = "." Then
      quit = True
      i = L
    End If
    L = L - 1
  Loop Until quit Or L < 1
  
  If quit Then
    FileName = Mid$(FileName, 1, i - 1)
  End If
  ReplaceFileExt = FileName + "." + Ext
End Function

Public Function EraseRightSpace(str As String) As String
Dim i As Integer
    i = Len(str)
    Do While i > 0 And Asc(Mid$(str, i, 1)) <= 32
       i = i - 1
    Loop
    If i > 0 Then EraseRightSpace = Mid$(str, 1, i)
End Function