modulecomm.bas

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

Attribute VB_Name = "ModuleCommon"
Option Explicit
Private Declare Function GetDriveType Lib "kernel32" _
    Alias "GetDriveTypeA" _
        (ByVal nDrive As String) As Long


Private Declare Function GetDiskFreeSpace Lib "kernel32" _
    Alias "GetDiskFreeSpaceA" _
        (ByVal lpRootPathName As String, _
         lpSectorsPerCluster As Long, _
         lpBytesPerSector As Long, _
         lpNumberOfFreeClusters As Long, _
         lpTotalNumberOfClusters As Long) As Long
         
         
         
Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" _
Alias "GetDiskFreeSpaceExA" _
(ByVal lpRootPathName As String, _
lpFreeBytesAvailableToCaller As Currency, _
lpTotalNumberOfBytes As Currency, _
lpTotalNumberOfFreeBytes As Currency) As Long

Private Declare Function GetVolumeInformation Lib "kernel32" _
Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, _
ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, _
lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long



Public Type Point
  x As Single
  y As Single
End Type

Public Type IntPoint
  x As Integer
  y As Integer
End Type


Public Type MinMax
  Min As Single
  Max As Single
End Type


Public Type Rectangle
  x1 As Single
  x2 As Single
  y1 As Single
  y2 As Single
End Type


Dim RubberBak As Rectangle

Public Function ShotenString(TheStr As String) As String
Dim P1 As Integer, P2 As Integer
Dim Fnum As Integer
Dim temp As Long
    P1 = 0: P2 = Len(TheStr)
    If P2 > 1 Then
       Fnum = 1
       Do
         temp = AscW(Mid$(TheStr, Fnum, 1))
         If temp > 32 Or temp < 0 Then
            P1 = Fnum
         End If
         Fnum = Fnum + 1
       Loop Until Fnum > P2 Or P1 > 0
       If P1 = 0 Then P1 = 1
       Fnum = P2
       P2 = 0
       Do
         temp = AscW(Mid$(TheStr, Fnum, 1))
         If temp > 32 Or temp < 0 Then
            P2 = Fnum
         End If
         Fnum = Fnum - 1
       Loop Until Fnum <= 0 Or P2 > 0
       If P2 = 0 Then P2 = P1
       TheStr = Mid$(TheStr, P1, (P2 - P1 + 1))
    End If
    ShotenString = TheStr


End Function



Public Function GetDiverSerialNumber(strDrive As String) As Long
     Dim SerialNum As Long
     Dim Res As Long
     Dim Temp1 As String
     Dim Temp2 As String
     Temp1 = String$(255, Chr$(0))
     Temp2 = String$(255, Chr$(0))
     Res = GetVolumeInformation(strDrive, Temp1, _
     Len(Temp1), SerialNum, 0, 0, Temp2, Len(Temp2))
     
     'Debug.Print Temp1, Temp2
     GetDiverSerialNumber = SerialNum
     
End Function

Public Function DriverLabel(strDrive As String) As String

Dim SerialNum As Long
Dim Res As Long
Dim Temp1 As String
Dim Temp2 As String
Dim i As Integer
Dim Zero As Boolean
Dim temp As String

     Temp1 = String$(255, Chr$(0))
     Temp2 = String$(255, Chr$(0))
     Res = GetVolumeInformation(strDrive, Temp1, _
     Len(Temp1), SerialNum, 0, 0, Temp2, Len(Temp2))
     
     'Debug.Print Temp1, Temp2
     i = 1: Zero = False: Temp2 = ""
     
     Do
        temp = Mid$(Temp1, i, 1)
        If Asc(temp) >= 32 Or Asc(temp) < 0 Then
          Temp2 = Temp2 + temp
        Else
          Zero = True
        End If
        i = i + 1
     Loop Until i > 255 Or Zero = True
     
     
      DriverLabel = Trim$(Temp2)
     
End Function






Public Function FixedDATALength(ByVal TheDATA, ByVal TheLength As Integer) As String
Dim s As String
Dim fP As Integer
Dim fmt As String
Dim i As Integer
Dim tip As Single
    s = Format$(TheDATA)
    fP = InStr(1, s, ".")
    If fP = 0 Then fP = Len(s) + 1
    If fP <= TheLength And Abs(TheDATA) > 1 Then
       s = Mid$(s, 1, TheLength)
    Else
      If fP > TheLength Then
        fmt = ""
        If (TheLength - 5) > 0 Then
           For i = 1 To (TheLength - 5)
             fmt = fmt + "#"
           Next i
        End If
        fmt = "#." + fmt + "E+#"
        s = Format$(TheDATA, fmt)
      End If
      
      If Abs(TheDATA) < 1 Then
        tip = 1 / (10 ^ ((TheLength - fP) \ 2))
        If Abs(TheDATA) < tip Then
           fmt = ""
           If (TheLength - 5) > 0 Then
             For i = 1 To (TheLength - 5)
               fmt = fmt + "#"
             Next i
           End If
           fmt = "#." + fmt + "E+#"
           s = Format$(TheDATA, fmt)
        Else
           s = Mid$(s, 1, TheLength)
        End If
      End If
       
    End If
    
    FixedDATALength = s
End Function


Public Function DiskFreeSpace(DriverName As String) As Currency
Dim FreeBytesAvailableToCaller As Currency
Dim TotalNumberOfBytes As Currency
Dim TotalNumberOfFreeBytes As Currency
Dim Rt As Long

  Rt = GetDiskFreeSpaceEx(DriverName, FreeBytesAvailableToCaller, TotalNumberOfBytes, TotalNumberOfFreeBytes)
  
  DiskFreeSpace = FreeBytesAvailableToCaller * 10000
  
  


End Function






Public Function GetNumInString(NumNo As Integer, aStr As String) As String
Dim i As Integer
Dim L As Integer
Dim a As String
Dim First As Integer
Dim Last As Integer
Dim Counter As Integer

    L = Len(aStr)
    For i = 1 To L
       a = Mid$(aStr, i, 1)
      If Asc(a) < 48 Or Asc(a) > 57 Then
      
         If a <> "+" And a <> "-" And a <> "." Then
            a = "|"
         End If
         
         Mid$(aStr, i, 1) = a
      End If
    Next i
    aStr = "|" + aStr + "|"
    L = Len(aStr)
    First = 0
    Last = 0
    Counter = 0
    i = 1
    Do
      a = Mid$(aStr, i, 2)
      If Left$(a, 1) = "|" And Right$(a, 1) <> "|" Then Counter = Counter + 1
      If Counter = NumNo And First = 0 Then First = i + 1
      If First > 0 And Left$(a, 1) <> "|" And Right$(a, 1) = "|" Then Last = i
      i = i + 1
    Loop Until (i > (L - 1)) Or Last > 0
    
    If Last > 0 Then
       GetNumInString = Mid$(aStr, First, Last - First + 1)
    Else
       GetNumInString = "Null"
    
    End If
   
End Function



Public Sub RubberLineErase(DrawObject As PictureBox)

    DrawObject.DrawMode = 7
    With RubberBak
      DrawObject.Line (.x1, .y1)-(.x2, .y1), RGB(255, 0, 0)
      DrawObject.Line (.x2, .y1)-(.x2, .y2), RGB(255, 0, 0)
      DrawObject.Line (.x2, .y2)-(.x1, .y2), RGB(255, 0, 0)
      DrawObject.Line (.x1, .y2)-(.x1, .y1), RGB(255, 0, 0)
    End With
    DrawObject.DrawMode = 13
End Sub


Public Sub RubberLine(DrawObject As PictureBox, x1 As Single, y1 As Single, x2 As Single, y2 As Single)
    DrawObject.DrawMode = 7
    DrawObject.Line (x1, y1)-(x2, y1), RGB(255, 0, 0)
    DrawObject.Line (x2, y1)-(x2, y2), RGB(255, 0, 0)
    DrawObject.Line (x2, y2)-(x1, y2), RGB(255, 0, 0)
    DrawObject.Line (x1, y2)-(x1, y1), RGB(255, 0, 0)
    DrawObject.DrawMode = 13
    RubberBak.x1 = x1
    RubberBak.y1 = y1
    RubberBak.x2 = x2
    RubberBak.y2 = y2
    
End Sub



Public Function ByteToBinStr(OneByte As Byte) As String
Dim T As Integer, i As Byte
Dim temp As String
   temp = "": T = 1
   For i = 1 To 8
     If (T And OneByte) <> 0 Then
        temp = "1" + temp
     Else
       temp = "0" + temp
     End If
     T = T * 2
   Next i
   ByteToBinStr = temp
End Function

Public Function BinStrToByte(str As String) As Byte
Dim i As Integer
Dim temp As Byte
   temp = 0
   For i = 1 To 8
     temp = temp + (2 ^ (i - 1)) * Val(Mid$(str, 8 - i + 1, 1))
   Next i
   
   BinStrToByte = temp
   



End Function



Public Sub GetDiskAttribute(ByVal DiskName As String, ByRef DiskType As String, ByRef TotalSpace As Currency, ByRef FreeSpace As Currency)

Const DRIVE_UNKNOWN = 0
Const DRIVE_NOTEXIST = 1
Const DRIVE_REMOVABLE = 2
Const DRIVE_FIXED = 3
Const DRIVE_REMOTE = 4
Const DRIVE_RAMDISK = 6
Const DRIVE_CDROM = 5

Dim lSectorsPerCluster      As Long
Dim lBytesPerSector         As Long
Dim lFreeClusters           As Long
Dim lTotalClusters          As Long
Dim lReturn                 As Long