module1.bas

自动化测试程序

Attribute VB_Name = "Module1"
Option Explicit
Public Const PI = 3.14159265358979

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, lpKeyName As Any, ByVal lpDefault As String, ByVal lpRetunedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Declare Function SaveINI Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As String, ByVal lplFileName As String) As Long

'--------------------------------------------------------------------------
Public fMainForm As frmMain

Public TreeWidth As Integer
Public TreeHeight As Integer

Public MsgListWidth As Integer
Public MsgListHeight As Integer

Public ComPort As Integer
Public ComSetStr As String

Public Para_init_flag As Boolean
'系统设备定义
'config.ini
Public Module_num As Integer
Public Module_type              '按照CLASS顺序排列
Public Module_name              '按照CLASS顺序排列
'工程.ini
Public Station_name As String
Public Device_num As Integer
Public Dev_Addr                 '工程目录树排列地址
Public dev_type                 '工程中的设备类型，按目录树排列
Public Comm_Gy As Integer       '通信规约
Public Com_Open As Boolean

Public Addr_NodKey(255) As Integer  '由地址查询节点
Public Select_ID As String      '设备类型
Public Device_Addr As Integer   '当前设备地址
Public Protect_Name As String   '工程名称
Public Comm_Mode As Integer     '通信方式
Public Comm_tx_tm As Integer    '通信发送延时
Public Comm_tx_end As Boolean  '串口发送数据完毕标志
Public Comm_tx_type As Byte     '串口发送数据类型
Public Comm_tx_type_bk As Byte  '数据类型重发保存
Public Comm_tx_loop_type As Byte    '循环发送数据类型
Public Comm_ms As Boolean       'true 多机通讯
Public Comm_loop_rx As Boolean  '循环接收标志
Public Comm_mast_slave As Boolean '主从方式

Public ProjectExist As Boolean  '在有无打开工程标志
Public BaoWen_Refresh As Boolean    '报文刷新标志

Public const_dd_tm As Integer   '电度计数
Public rd_dd_base As Boolean    '是否配置电度表底

Public Type Dev_Inf
addr(256) As Integer
Dev_tpye(256) As String
dev_key(256) As Integer
End Type

Public dev_NumToName(256) As String '设备类型序号对应的设备名称
Public Dev_info As Dev_Inf

Public Type Dev_infm
addr As Integer
dev_type As String
dev_key As Integer
dev_type_num As Integer
End Type
Public Cur_Dev As Dev_infm

Public Const SYS_CFG_NUM = 31
Public Const YC_CFG_NUM = 79
Public Const CH_CFG = 64
Public Const DD_RATE_CFG_NUM = 31

Public Const DI_CFG_NUM = 122
Public Const DO_CFG_NUM = 63
Public Const SETTLE_NUM = 63

Public Const EX_YX_NUM = 64
Public Const PRO_YX_NUM = 80
Public Const ORTH_YX_NUM = 112

Public Const DO_FUNC_NUM = 6

Public Type Par_Cfg
sys_cfg(256) As Long        '系统参数配置
yc_cfg(256) As Long         '模拟量配置
do_out_cfg(256) As Long
do_cfg(2 To DO_FUNC_NUM + 1, 256) As Long      '输出功能配置
di_cfg(256) As Long         '遥信配置
settle(256) As Long      '定值组
dd_rate_cfg(256) As Long    '电度脉冲变比
dd_base_cfg(256) As Long    '电度表底数据

di_func1_cfg(256) As Integer '外部输入遥信功能1
di_func2_cfg(256) As Integer '外部输入遥信功能2
di_delay_cfg(256) As Integer '外部输入延时
di_pro_cfg(256) As Integer '极性配置
di_dd_cfg(256) As Integer '遥信电度功能选择
chks(256, 2 To 4) As Double
angle(256) As Double          '角度
End Type

Public Type Dev_dat
cur_yc(256) As Integer
cur_ycxs(256) As Double
cur_yx(256) As Byte
cur_dd(256) As Long
End Type

Public BCD() As Byte
Public Dev_Par(255) As Par_Cfg
Public Dev_Cur_Dat(255) As Dev_dat
Public Cal_CH_type As Integer
Public Cal_CH_type1 As Integer
Public Cal_CH_num0 As Integer
Public Cal_CH_num1 As Integer


Sub Main()
    'frmSplash.Show
    'frmSplash.Refresh
    Set fMainForm = New frmMain
    Load fMainForm
    'Unload frmSplash

    fMainForm.Show
    
End Sub

Function GetINI(AppName As String, KeyName As String, filename As String) As String
   Dim RetStr As String
   RetStr = String(10000, Chr(0))
   GetINI = Left(RetStr, GetPrivateProfileString(AppName, ByVal KeyName, "", RetStr, Len(RetStr), filename))
End Function

Public Sub LoadNewForm(frm As Form)
frm.Left = TreeWidth
frm.Top = 0
frm.Width = fMainForm.ScaleWidth - TreeWidth
frm.Height = fMainForm.ScaleHeight - MsgListHeight
End Sub

Public Function OpenCom() As Boolean
On Error Resume Next
Dim i As Integer
Dim j, k As Long
With fMainForm.Comm
    If .PortOpen Then
         .PortOpen = False
    End If
    
    .CommPort = ComPort
    .Settings = ComSetStr
    i = InStr(1, ComSetStr, ",", vbBinaryCompare)
    j = CLng(Mid(ComSetStr, 1, i - 1))
    k = CLng(33) * CLng(300) * 4
    k = k / j
    If k > 4 Then
        Comm_tx_tm = k
    Else
        Comm_tx_tm = 4
    End If
    .RThreshold = 1 '接收一个字节产生一个事件
    .SThreshold = 1 '发送完毕产生事件
    .InputMode = comInputModeBinary
    .InBufferCount = 0
    .OutBufferCount = 0
    
    .PortOpen = True
    
    If Err.Number = 0 Then
        OpenCom = True
    Else
        OpenCom = False
    End If
    
End With

End Function

Public Sub WriteToTxt(str As String)
On Error Resume Next

Open App.Path & "\通讯纪录.txt" For Append As #300
Write #300, Format(Now, "yyyy-mm-dd hh:mm:ss") & "   " & str
Close #300

End Sub

Function DecToBin(ByVal Dec As Integer) As String
Dim temp As String
Dim i As Integer

Do
    temp = Dec Mod 2 & temp
    Dec = Dec \ 2
Loop While Dec

For i = Len(temp) + 1 To 8
    temp = "0" & temp
Next i

DecToBin = temp

End Function

Function BinToDec(ByVal bin As String) As Long
Dim i As Integer
Dim temp As Long
temp = 0
For i = 1 To Len(bin)
    temp = temp * 2 + Val(Mid(bin, i, 1))
Next i
'If temp > 32767 Then
'temp = temp - 65536
'End If
BinToDec = temp
End Function

Public Function HexToBin(ByVal Hex As String) As String
    Dim i As Long
    Dim b As String
    
    Hex = UCase(Hex)
    For i = 1 To Len(Hex)
        Select Case Mid(Hex, i, 1)
            Case "0": b = b & "0000"
            Case "1": b = b & "0001"
            Case "2": b = b & "0010"
            Case "3": b = b & "0011"
            Case "4": b = b & "0100"
            Case "5": b = b & "0101"
            Case "6": b = b & "0110"
            Case "7": b = b & "0111"
            Case "8": b = b & "1000"
            Case "9": b = b & "1001"
            Case "A": b = b & "1010"
            Case "B": b = b & "1011"
            Case "C": b = b & "1100"
            Case "D": b = b & "1101"
            Case "E": b = b & "1110"
            Case "F": b = b & "1111"
        End Select
    Next i
    
    For i = Len(b) + 1 To 16
        b = "0" & b
    Next i
    
    HexToBin = b
End Function

Public Function sHexToBin(ByVal bin As String) As String
Dim b As String
Select Case bin
    Case "0": b = "0000"
    Case "1": b = "0001"
    Case "2": b = "0010"
    Case "3": b = "0011"
    Case "4": b = "0100"
    Case "5": b = "0101"
    Case "6": b = "0110"
    Case "7": b = "0111"
    Case "8": b = "1000"
    Case "9": b = "1001"
    Case "A": b = "1010"
    Case "B": b = "1011"
    Case "C": b = "1100"
    Case "D": b = "1101"
    Case "E": b = "1110"
    Case "F": b = "1111"
End Select
sHexToBin = b
End Function

Public Function BinToHex(ByVal bin As String) As String
    Dim i As Long
    Dim h As String
    If Len(bin) Mod 4 <> 0 Then
        bin = String(4 - Len(bin) Mod 4, "0") & bin
    End If
    
    For i = 1 To Len(bin) Step 4
        Select Case Mid(bin, i, 4)
            Case "0000": h = h & "0"
            Case "0001": h = h & "1"
            Case "0010": h = h & "2"
            Case "0011": h = h & "3"
            Case "0100": h = h & "4"
            Case "0101": h = h & "5"
            Case "0110": h = h & "6"
            Case "0111": h = h & "7"
            Case "1000": h = h & "8"
            Case "1001": h = h & "9"
            Case "1010": h = h & "A"
            Case "1011": h = h & "B"
            Case "1100": h = h & "C"
            Case "1101": h = h & "D"
            Case "1110": h = h & "E"
            Case "1111": h = h & "F"
        End Select
    Next i
    BinToHex = h
End Function

Public Function HexToDec(LData, HData) As String
Dim LTemp, HTemp As String
Dim temp
Dim i As Integer

LTemp = Hex(LData)
For i = Len(LTemp) To 1
    LTemp = "0" & LTemp
Next i

HTemp = Hex(HData)
For i = Len(HTemp) To 1
    HTemp = "0" & HTemp
Next i

temp = "&H" & HTemp & LTemp

If HData > 127 Then
    temp = temp - 65535
End If

HexToDec = CInt(temp)

End Function


Public Sub DecToBCD(data, DataCount As String)
Dim i As Integer
Dim temp As String
Dim TempChr As String
Dim Datalen As Integer
ReDim BCD(DataCount - 1)

Datalen = DataCount * 2

For i = 1 To Len(CStr(data))
    TempChr = Mid(CStr(data), i, 1)
    If IsNumeric(TempChr) Then
        temp = temp & TempChr
    End If
Next i

For i = Len(temp) To Datalen - 1
    temp = "0" & temp
Next i

For i = 0 To DataCount - 1
    BCD(i) = "&H" & Mid(temp, Datalen - i * 2 - 1, 2)
Next i

If data < 0 Then '负数
    BCD(DataCount - 1) = BCD(DataCount - 1) + 128
End If

End Sub

Public Function BCDToDec() As Long
Dim i, j As Integer
Dim temp As String

For i = 0 To UBound(BCD)
    temp = Hex(BCD(i)) & temp
    
    For j = Len(temp) To 2 * (i + 1) - 1
        temp = "0" & temp
    Next j
    
Next i

BCDToDec = temp

End Function

Public Function LongToHex(lng As Long) As String
Dim str As String
str = Hex(lng)
Dim i As Integer
For i = Len(str) + 1 To 8
    str = "0" & str
Next i

LongToHex = str
End Function

'检查文件是否存在
Function FileExists(filename As String) As Integer
Dim i As Integer
On Error Resume Next
i = Len(Dir$(filename))
If Err Or i = 0 Then FileExists = False Else FileExists = True
End Function
'数字和小数点
Function Text_Num_Dec(KeyAscii As Integer) As Integer
If (KeyAscii >= vbKey0 And KeyAscii <= vbKey9) Or KeyAscii = vbKeyDelete Or KeyAscii = vbKeyBack Then
    Text_Num_Dec = KeyAscii
Else
    Text_Num_Dec = 0
End If
End Function

'数字
Function Text_Num(KeyAscii As Integer) As Integer
If (KeyAscii >= vbKey0 And KeyAscii <= vbKey9) Or KeyAscii = vbKeyBack Then
    Text_Num = KeyAscii
Else
    Text_Num = 0
End If
End Function

'数字 - . number
Function Text_Num_Sub(KeyAscii As Integer) As Integer
If (KeyAscii >= vbKey0 And KeyAscii <= vbKey9) Or KeyAscii = vbKeyBack Or KeyAscii = vbKeyDelete Or KeyAscii = vbKeyInsert Then
    Text_Num_Sub = KeyAscii
Else
    Text_Num_Sub = 0
End If
End Function

'输入十六进制数据
'数字和小数点
Function Text_Hex(KeyAscii As Integer) As Integer
If (KeyAscii >= vbKey0 And KeyAscii <= vbKey9) Or KeyAscii = vbKeyDelete Or KeyAscii = vbKeyBack Then
    Text_Hex = KeyAscii
Else
    Text_Hex = 0
End If
End Function

Function Cnt(ByVal s1 As String, ByVal s2 As String) As Long
Dim xt As Long
Cnt = 0
xt = 1
xt = InStr(xt, s1, s2)
Do Until xt = 0
Cnt = Cnt + 1
xt = xt + 1
xt = InStr(xt, s1, s2)
Loop
End Function