initialization.bas

485端口抄表程序

   ElseIf gIntMeters Mod 5 = 0 Then
      gIntGroupMeters = 5
   Else
      gIntGroupMeters = 3
   End If
End Sub

Function GetIniInfo(ByVal filename As String, ByVal Section As String, ByVal KeyName As String, Optional ByVal Default As Variant, Optional ByVal ByValue As Boolean) As Variant
  '从文件中读取INI信息
  Dim strDefault As String
  Dim Result As String
  Dim ValueLen As Long
  Dim MSG As String
  
  On Error Resume Next
  strDefault = Default
  ValueLen = 4096
  Result = Space$(ValueLen)
  ValueLen = GetPrivateProfileString(Section, KeyName, strDefault, Result, ValueLen, filename)
  If ByValue Then
    GetIniInfo = Val(Result)
  Else
    Result = Trim(Result)
    If Asc(Right(Result, 1)) = 0 Then Result = Left(Result, Len(Result) - 1)
    GetIniInfo = Trim(Result)
  End If
End Function

Sub SaveIniInfo(ByVal filename As String, ByVal Section As String, ByVal KeyName As String, ByVal Value As Variant)
  '向文件中写Ini信息
  Dim strValue As String
  strValue = Value
  WritePrivateProfileString Section, KeyName, strValue, filename
End Sub

Public Function StartDoc(DocName As String) As Long
  Dim Scr_hDC As Long
  Scr_hDC = GetDesktopWindow()
  StartDoc = ShellExecute(Scr_hDC, "Open", DocName, "", "C:\", 1)
End Function

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

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

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

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

Function isNumber(ByVal MSG As String) As Boolean
  isNumber = ((Len(MSG) > 0) And (InStr("0123456789", Left(MSG, 1)) > 0))
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


'''''''''''''''''''''
Public Function ErrorOrder_gFun(pIntID As Integer, pIntAddress As Long)
   '与误差计算器的通讯命令
   'pIntID 命令序号(1 号命令无效)   pIntAddress  误差计算器序号
   Dim lStrOrder As String
   Dim lFstAddress As String  ' * 1
   On Error Resume Next
   If pIntAddress < 0 Then
      lFstAddress = ChrB(&HFF)
   Else
      lFstAddress = ChrB(PTC8000BASEADDRESS + pIntAddress)    '对应地址 1-A ，2-B，...
   End If
   Select Case pIntID
      Case 1                     '送圈数和理论脉冲数, 此处调用无效
         lStrOrder = ChrB(&H2)   '实际调用见ErrorCircles_gFun()
      Case 2                     '读误差
         lStrOrder = ChrB(&H3)
      Case 3                     '准备寻表记
         lStrOrder = ChrB(&H4)
      Case 4                     '寻表记开始
         lStrOrder = ChrB(&H7)
      Case 5                     '读寻表记结果
         lStrOrder = ChrB(&H8)
      Case 6                     '寻表记结束
         lStrOrder = ChrB(&H9)
      Case 7                     '读起动/潜动试验开门脉冲(检测到否)
         lStrOrder = ChrB(&HA)
      Case 8                     '起动/潜动试验结束
         lStrOrder = ChrB(&HC)
      Case 9                     '状态查询
         lStrOrder = ChrB(&HB)
      Case 10                    '通讯线接通
         lStrOrder = ChrB(&H10) & ChrB(&H31)
      Case 11                    '通讯线断开
         lStrOrder = ChrB(&H10) & ChrB(&H30)
      Case &H14                  '读标准表脉冲
         lStrOrder = ChrB(&H14)
   End Select
   ErrorOrder_gFun = COMMSOH & lFstAddress & lStrOrder & CheckChar_gFun(1, lStrOrder) & COMMETB
End Function

Function CheckChar_gFun(pIntID As Integer, pStrCommString As String)
   '通讯校验字符
   '通讯发送或接收字符串的各字符 (不包括起始符, 地址, 校验字符, 结束符) 的 ASCII码值累加
   'pIntID  1-信号源，遇结束符取反；2-分机板，允许校验码与结束符相同
   'pStrCommString  通讯字符串(不包括起始符, 地址, 校验字符, 结束符)
   Dim lIntLen As Integer, i As Integer, lIntCharCode As Integer
   On Error Resume Next
   lIntLen = LenB(pStrCommString)    '字节长度
   lIntCharCode = 0
   For i = 1 To lIntLen
      lIntCharCode = lIntCharCode + AscB(MidB(pStrCommString, i, 1))
      If lIntCharCode > 255 Then lIntCharCode = lIntCharCode - 256
   Next i
   If pIntID = 1 Then
      If lIntCharCode = AscB(COMMETB) Then lIntCharCode = 255 - lIntCharCode
   End If
   CheckChar_gFun = ChrB(lIntCharCode)
End Function

Public Sub VoltageRase(ComPort As Variant, Voltage As String)  '上电

    Dim Result As Integer
    Dim Result1 As Integer
    On Error GoTo RaseVAError
    
    Set mySource = New ClassCky
    Set myHC3100 = New ClassHc3100
    mySource.SetVersion 3
    myHC3100.Commport = ComPort
    myHC3100.CommSetting = "9600,n,8,1"
    myHC3100.Address = 55
    Result = myHC3100.HcSetSync(1)
    If Result <> -1 Then
        Exit Sub
    End If
    mySource.Commport = ComPort
    mySource.CommSetting = "9600,n,8,1"
    If Voltage = "" Then
        Exit Sub
    End If

    mySource.Voltage = CSng(Voltage)
    If CSng(Voltage) > 85 And CSng(Voltage) < 120 Or CSng(Voltage) >= 380 Then
        mySource.PhaseWire = 1
        Result = myHC3100.HcSetPhaseWire(2)
    Else
        mySource.PhaseWire = 5
        Result = myHC3100.HcSetPhaseWire(1)
    End If
    
    If Result <> -1 Then
        Exit Sub
    End If
    mySource.Current = 0
    mySource.AdjustIABC = "Iabc"
    mySource.Freq = 50
    mySource.PhaseSequence = 1
    mySource.PF = "1.0"
    mySource.Revers = 0
    
    Result = mySource.RaiseVA
    If Result <> -1 Then
        Exit Sub
    End If
    Exit Sub
    
RaseVAError:
    MsgBox (Err.Description)
    
End Sub

Public Sub VoltageDown()               '降电
On Error GoTo DownVAError
Set mySource = New ClassCky
    mySource.ClearSource
Exit Sub
DownVAError:
    MsgBox (Err.Description)
End Sub






Public Sub Main()
  If App.PrevInstance = False Then
    ReadIniData_gSub
    Splash.Show
  End If
End Sub