classfilehead.cls

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

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ClassFileHead"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Dim HeadChar(1 To 128) As Byte
Dim c(1 To 4) As Byte

Public Property Get FileHeadByteNum()
  FileHeadByteNum = UBound(HeadChar)
End Property



Private Function CodeCheck(CodeStr As String) As Boolean
Dim CodeOk As Boolean
Dim i As Integer
    For i = 1 To 4
      c(i) = Asc(Mid$(CodeStr, i, 1))
    Next i
    CodeOk = True
    If c(1) < 65 Or c(1) > 122 Then CodeOk = False
    If c(2) < 65 Or c(2) > 122 Then CodeOk = False
    If c(3) < 48 Or c(3) > 57 Then CodeOk = False
    If c(4) < 48 Or c(4) > 57 Then CodeOk = False
    CodeCheck = CodeOk
End Function

Public Property Get Summary() As String
Dim FCode As String
Dim i As Integer
    FCode = ""
    For i = 11 To 124
      FCode = FCode + Chr$(HeadChar(i))
    Next i
    Summary = FCode
End Property

Public Property Let Summary(Max114 As String)
Dim i As Integer
Dim Fs As String
Dim L As Integer

  Fs = Mid$(Max114, 1, 114)
  L = Len(Fs)
  For i = 1 To L
    HeadChar(i + 10) = Asc(Mid$(Fs, i, 1))
  Next i
End Property
 
Public Property Get DATAFormatCode() As String
Dim FCode As String
Dim i As Integer
    FCode = ""
    For i = 1 To 4
      FCode = FCode + Chr$(HeadChar(i))
    Next i
    DATAFormatCode = FCode

End Property

Public Property Let DATAFormatCode(ByVal FormatCode As String)
Dim FCode As String
Dim i As Integer
    FCode = Mid$(FormatCode, 1, 4)
    If CodeCheck(FCode) = True Then
       For i = 1 To 4
         HeadChar(i) = c(i)
       Next i
    Else
       MsgBox "数据格式代码由4个字符组成，前两个为英文字母，后两个为数字。", vbCritical, "代码形式错误"
    End If
End Property

Public Property Get DeviceCode() As String
Dim FCode As String
Dim i As Integer
    FCode = ""
    For i = 1 To 4
      FCode = FCode + Chr$(HeadChar(i + 4))
    Next i
    DeviceCode = FCode

End Property

Public Property Let DeviceCode(ByVal DeviceCode As String)
Dim FCode As String
Dim i As Integer
    FCode = Mid$(DeviceCode, 1, 4)
    If CodeCheck(FCode) = True Then
       For i = 1 To 4
         HeadChar(i + 4) = c(i)
       Next i
    Else
       MsgBox "设备代码由4个字符组成，前两个为英文字母，后两个为数字。", vbCritical, "代码形式错误"
    End If
End Property

Public Function ReadFileHead(DATAFileName As String) As String
Dim FNo As Integer
Dim CodeOk As Boolean
Dim ErrCode As Integer
Dim i As Integer
Dim FCode As String

    FNo = FreeFile
    Open DATAFileName For Binary As #FNo
      Get #FNo, 1, HeadChar
    Close #FNo
    '查尾代码
    CodeOk = True
       If HeadChar(125) <> 13 Then CodeOk = False
       If HeadChar(126) <> 10 Then CodeOk = False
       If HeadChar(127) <> 0 Then CodeOk = False
       If HeadChar(128) <> 26 Then CodeOk = False
    If CodeOk = False Then
       ErrCode = 1
       GoTo WrongHead
    End If
    '查定界码
       If HeadChar(9) <> Asc("/") Then CodeOk = False
       If HeadChar(10) <> Asc("/") Then CodeOk = False
    If CodeOk = False Then
       ErrCode = 2
       GoTo WrongHead
    End If
    '查数据格式代码
      FCode = ""
      For i = 1 To 4
        FCode = FCode + Chr$(HeadChar(i))
      Next i
      If CodeCheck(FCode) = False Then
         ErrCode = 3
      End If
    '查设备格式代码
      FCode = ""
      For i = 1 To 4
        FCode = FCode + Chr$(HeadChar(i + 4))
      Next i
      If CodeCheck(FCode) = False Then
         ErrCode = 4
      End If
    
    ReadFileHead = ""
    Exit Function
    
WrongHead:
    Select Case ErrCode
      Case 1:
         ReadFileHead = "文件头结束符错误"
      Case 2:
         ReadFileHead = "文件头分界符错误"
      Case 3:
         ReadFileHead = "数据格式代码错误"
      Case 4:
         ReadFileHead = "设备代码错误"
    End Select
End Function




Public Sub WriteFileHead(DATAFileName As String)
Dim FNo As Integer
    FNo = FreeFile
    Open DATAFileName For Binary As #FNo
      Put #FNo, 1, HeadChar
    Close #FNo
End Sub




Private Sub Class_Initialize()
Const Default As String = "Undefined DATA Format // Unknow Device"
Dim i As Integer
Dim L As Integer
  '1-4字符为数据类型定义代码，其中前两个应为英文，后两个为数字。在数据库中对应唯一一组数据格式定义与读写类
  '5-8字符为设备类型定义代码，其中前两个应为英文，后两个为数字。在数据库中对应唯一一组设备参数与使用手册。
  '9，10永远取 “//”
  '11-124为开发者对数据类型及设备的两个描述区，区之间建议用//分开。
  '建议文件头用英文书写，不要写中文。

  For i = 1 To 8
    HeadChar(i) = Asc("0")
  Next i
  HeadChar(9) = Asc("/")
  HeadChar(10) = Asc("/")
  L = Len(Default)
  For i = 11 To 11 + L - 1
      HeadChar(i) = Asc(Mid$(Default, i - 10, 1))
  Next i
  For i = 11 + L To 124
    HeadChar(i) = 32
  Next i
  HeadChar(125) = 13
  HeadChar(126) = 10
  HeadChar(127) = 0
  HeadChar(128) = 26
  
  
  
  
End Sub