function.bas

VB编写的基于645规约的电表行业485通讯抄表程序

Attribute VB_Name = "Function"
'Download by http://www.codefans.net
Public Function IsNumber(ByVal Msg As String) As Boolean
  IsNumber = ((Len(Msg) > 0) And (InStr("0123456789", Left(Msg, 1)) > 0))
End Function

Public Sub Delay(msValue As Long, Optional AdvanceExit, Optional ByVal WaitFalse As Boolean)
  '延时,满足条件(AdvanceExit=Not WaitFalse)时提前退出
  Dim EndTime As Long
  On Error Resume Next
  EndTime = GetTickCount + msValue
  Do
    DoEvents
    If Not IsMissing(AdvanceExit) Then If AdvanceExit = Not WaitFalse Then Exit Sub
  Loop Until (GetTickCount >= EndTime)
End Sub

Public Function AddZero(Num As Integer) As String
  '在前边加 Num 个 0
  AddZero = ""
  Dim I As Variant
  For I = 1 To Num
    AddZero = "0" & AddZero
  Next I
End Function

Public Function GetItemNo(ByVal Msg As String, Split As String, Item As String) As Long
  '取指定项的序号(0..N),找不到返回-1
  Dim SplitLen As Long
  Dim S As Long
  Dim N As Long
  Dim Count As Long
  
  GetItemNo = -1
  SplitLen = Len(Split)
  If SplitLen > 0 Then  '有效的分隔符
    S = 1
    Do
      N = InStr(S, Msg, Split)
      If N = 0 Then
        If Mid(Msg, S) = Item Then GetItemNo = Count
      Else
        If Mid(Msg, S, N - S) = Item Then GetItemNo = Count
        S = N + SplitLen
        Count = Count + 1
      End If
    Loop Until (N = 0)
  End If
  
End Function

Public Function GetItem(ByVal Msg As String, ByVal Split As String, ByVal Index As Long, Optional ByVal ByValue As Boolean) As Variant
  '取指定项,EX: GetItem("1A,5A,10A,20A",",",2) = "10A"
  'Index = -1 , Get Items Count
  Dim SplitLen As Long
  Dim S As Long
  Dim N As Long
  Dim Count As Long
  Dim Item As String
  
  SplitLen = Len(Split)
  If Len(Msg) * SplitLen > 0 Then   '有效的字符串和分隔符
    S = 1
    If Index < 0 Then   '取项数
      Do
        N = InStr(S, Msg, Split)
        Count = Count + 1
        If N > 0 Then S = N + SplitLen
      Loop Until (N = 0)
      GetItem = Count
    Else                '取指定项
      Do
        N = InStr(S, Msg, Split)
        If Count = Index Then
          Item = Mid(Msg, S, IIf(N = 0, Len(Msg), N - S))
          Exit Do
        Else
          Count = Count + 1
          If N > 0 Then S = N + SplitLen
        End If
      Loop Until (N = 0)
      'GetItem = IIf(ByValue, Val(Item), Item)
      If ByValue Then
        GetItem = Val(Item)
      Else
        GetItem = Item
      End If
    End If
  End If
  
End Function

Public Function GetItemNo_SpecialString(ByVal Index As Long, ByVal Msg As String) As Variant
  '取特殊字符在字符串中出现的位置
  If Index <= 0 Then
    GetItemNo_SpecialString = 0
    Exit Function
  End If
  Dim I, J, K As Variant
  Dim TempS As String
  J = 1
  For I = 1 To Len(Msg)
    TempS = Mid(Msg, I, 1)
    If IsNumOrStr(TempS) = False Then
      If Index = J Then
         GetItemNo_SpecialString = I
         Exit Function
      Else
         J = J + 1
      End If
    End If
  Next I
  
End Function

Public Function IsNumOrStr(ByVal Msg As String) As Boolean
' 用于对特殊字符处理判断
Select Case UCase(Msg)
   Case "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z"
     IsNumOrStr = True
   Case Else
     IsNumOrStr = False
End Select

End Function

Public Function StringFormat(DataMsg As String, StrFormat As String) As String
'字符串格式化处理

'DataMsg           :  待格式化的字符串                      如   99.9
'StrFormat         :  数据格式                              如   NNNNNN.NN

'转换后成为                                                 000099.90

Dim I, J, K As Variant
Dim MStr As Variant
Dim TempS, StrTmp As String
Dim SpecialStr As String
Dim P, Q As Variant
Dim S As String

If Len(DataMsg) = Len(StrFormat) Then                       '  长度相同直接处理
  StringFormat = DataMsg
  Exit Function
End If

StrTmp = ""
J = 0

For I = 1 To Len(DataMsg)
  TempS = Mid(DataMsg, I, 1)
  If IsNumber(TempS) = False Then J = J + 1                 '  有 J 个特殊字符
Next I
 
Select Case J

    Case 0                                                  '  NNNNNN            ( 99 -> 000099 )
        StrTmp = AddZero(Len(StrFormat) - Len(DataMsg)) & DataMsg
    Case 1                                                  '  NNNNNN.NN 零补后  ( 99.99 -> 000099.9900 )
        For K = 1 To J
          StrTmp = StrTmp & AddZero((GetItemNo_SpecialString(K, StrFormat) - GetItemNo_SpecialString(K - 1, StrFormat)) - (GetItemNo_SpecialString(K, DataMsg) - GetItemNo_SpecialString(K - 1, DataMsg))) & Mid(DataMsg, GetItemNo_SpecialString(K - 1, DataMsg) + 1, GetItemNo_SpecialString(K, DataMsg) - GetItemNo_SpecialString(K - 1, DataMsg))
        Next K
        StrTmp = StrTmp & Mid(DataMsg, GetItemNo_SpecialString(J, DataMsg) + 1, Len(DataMsg) - GetItemNo_SpecialString(K, DataMsg))
        StrTmp = StrTmp & AddZero(Len(StrFormat) - Len(StrTmp))
    Case Else                                               '  HH:MM:SS 零补前   ( 2:3:2 -> 02:03:02 )
        For K = 1 To J
          StrTmp = StrTmp & AddZero((GetItemNo_SpecialString(K, StrFormat) - GetItemNo_SpecialString(K - 1, StrFormat)) - (GetItemNo_SpecialString(K, DataMsg) - GetItemNo_SpecialString(K - 1, DataMsg))) & Mid(DataMsg, GetItemNo_SpecialString(K - 1, DataMsg) + 1, GetItemNo_SpecialString(K, DataMsg) - GetItemNo_SpecialString(K - 1, DataMsg))
        Next K
        StrTmp = StrTmp & AddZero(Len(StrFormat) - Len(StrTmp) - (Len(DataMsg) - GetItemNo_SpecialString(J, DataMsg)))
        StrTmp = StrTmp & Mid(DataMsg, GetItemNo_SpecialString(J, DataMsg) + 1, Len(DataMsg) - GetItemNo_SpecialString(K, DataMsg))

End Select

'输出格式化后的数据
StringFormat = StrTmp
  
End Function