module1.bas

电力机车牵引变压器试验站总控程序

Attribute VB_Name = "Module1"
Public fMainForm As frmMain
Public ttype As String
Public ttrain As String
Public tobj As String
Public byqData(0 To 399) As Variant
Public dkqData(0 To 219) As Variant
Public hgqData(0 To 29) As Variant
Public dataFile As String
Public currentTime As String
Public needPrint As Boolean
Public isAdmin As Boolean
Public needSave As Boolean
Public continuedTest As Boolean
Public savewordIndexandLength(39, 2) As Integer
Public savewordTestType As Integer
Public bytSendByte() As Byte
Public choosenDate As String
Public scrollFlag As Boolean
Public autoFlag As Boolean
Public strInstrument(0 To 6) As String
Public singleTestFinished As Boolean
Public TempToday As Long

Public intPort As Integer       '串行口号
Public strSet As String         '协议设置
Public intTime As Integer       '发送时间间隔
Public strHex(0 To 9) As String         '十六进制编码
Public strHexAll(0 To 9) As String
Public strAscii(0 To 9) As String        'ASCII码
Public strAsciiAll(0 To 9) As String
Public bytReceiveByte() As Byte     '接收到的字节
Public intReceiveLen As Integer     '接收到的字节数
Public bytReceiveByteAll() As Byte     '接收到的字节
Public intReceiveLenAll As Integer     '接收到的字节数


Sub Main()
    Dim fLogin As New frmLogin

    fLogin.Show vbModal
    If Not fLogin.OK Then
        'Login Failed so exit app
        End
    End If
    Unload fLogin


    frmSplash.Show vbModal
    frmSplash.Refresh
    
    scrollFlag = True
    
    Set fMainForm = New frmMain
    
    Load fMainForm
    fMainForm.Show
End Sub



Sub LoadResStrings(frm As Form)
    On Error Resume Next


    Dim ctl As Control
    Dim obj As Object
    Dim fnt As Object
    Dim sCtlType As String
    Dim nVal As Integer


    'set the form's caption
    frm.Caption = LoadResString(CInt(frm.Tag))
    

    'set the font
    Set fnt = frm.Font
    fnt.Name = LoadResString(20)
    fnt.Size = CInt(LoadResString(21))
    

    'set the controls' captions using the caption
    'property for menu items and the Tag property
    'for all other controls
    For Each ctl In frm.Controls
        Set ctl.Font = fnt
        sCtlType = TypeName(ctl)
        If sCtlType = "Label" Then
            ctl.Caption = LoadResString(CInt(ctl.Tag))
        ElseIf sCtlType = "Menu" Then
            ctl.Caption = LoadResString(CInt(ctl.Caption))
        ElseIf sCtlType = "TabStrip" Then
            For Each obj In ctl.Tabs
                obj.Caption = LoadResString(CInt(obj.Tag))
                obj.ToolTipText = LoadResString(CInt(obj.ToolTipText))
            Next
        ElseIf sCtlType = "Toolbar" Then
            For Each obj In ctl.Buttons
                obj.ToolTipText = LoadResString(CInt(obj.ToolTipText))
            Next
        ElseIf sCtlType = "ListView" Then
            For Each obj In ctl.ColumnHeaders
                obj.Text = LoadResString(CInt(obj.Tag))
            Next
        Else
            nVal = 0
            nVal = Val(ctl.Tag)
            If nVal > 0 Then ctl.Caption = LoadResString(nVal)
            nVal = 0
            nVal = Val(ctl.ToolTipText)
            If nVal > 0 Then ctl.ToolTipText = LoadResString(nVal)
        End If
    Next


End Sub

Sub GetCurrentTime()
        Dim nowTime As String
        nowTime = Time
        Dim nowhour As String
        Dim nowminute As String
        Dim nowsecond As String
        
        nowhour = Hour(nowTime)
        nowminute = Minute(nowTime)
        nowsecond = Second(nowTime)
        
        currentTime = nowhour & "-" & nowminute & "-" & nowsecond
End Sub

Function numPatternChange(str As String) As String
    If Abs(Val(str)) < 1 Then
        numPatternChange = "0" + str
    Else
        numPatternChange = str
    End If
End Function

Sub initbyqData()
    Dim i As Integer
    For i = 0 To 224
        byqData(i) = Empty
    Next i
    
    For i = 225 To 238
        byqData(i) = "未完成"
    Next i
    
    For i = 239 To 399
        byqData(i) = Empty
    Next i
End Sub

Sub inithgqData()
    Dim i As Integer
    For i = 0 To 15
        hgqData(i) = Empty
    Next i
    
    For i = 16 To 20
        hgqData(i) = "未完成"
    Next i
    
    For i = 21 To 29
        hgqData(i) = Empty
    Next i
End Sub

Sub initdkqData()
    Dim i As Integer
    For i = 0 To 219
        dkqData(i) = Empty
    Next i
    
    For i = 65 To 71
        dkqData(i) = "未完成"
    Next i
    
    For i = 132 To 138
        dkqData(i) = "未完成"
    Next i
    
    For i = 199 To 205
        dkqData(i) = "未完成"
    Next i
End Sub

Public Sub InputManage(bytInput() As Byte, intInputLenth As Integer)
    Dim n As Integer                                '定义变量及初始化
    intReceiveLen = intInputLenth
    ReDim Preserve bytReceiveByte(intReceiveLen)
    
    For n = 1 To intInputLenth Step 1
        bytReceiveByte(n - 1) = bytInput(n - 1)
    Next n
End Sub

Public Sub InputManageTotal(bytInput() As Byte, intInputLenth As Integer)
    Dim n As Integer                                '定义变量及初始化
    
    ReDim Preserve bytReceiveByteAll(intReceiveLenAll + intInputLenth)

    For n = 1 To intInputLenth Step 1
        bytReceiveByteAll(intReceiveLenAll + n - 1) = bytInput(n - 1)
    Next n
    
    intReceiveLenAll = intReceiveLenAll + intInputLenth
End Sub

Function GetReceiveText(Index As Integer) As String
    Dim n As Integer
    Dim intValue As Integer
    Dim intHighHex As Integer
    Dim intLowHex As Integer
    Dim strSingleChr As String * 1
    
    strAscii(Index) = ""            '设置初值
    strHex(Index) = ""
    
    For n = 1 To intReceiveLen
        intValue = bytReceiveByte(n - 1)
        
        If intValue < 32 Or intValue > 128 Then         '处理非法字符
            strSingleChr = Chr(46)                      '对于不能显示的ASCII码,
        Else                                            '用"."表示
            strSingleChr = Chr(intValue)
        End If
        
        strAscii(Index) = strAscii(Index) + strSingleChr
'        strAsciiAll(Index) = strAsciiAll(Index) + strAscii(Index)
        
        intHighHex = intValue \ 16
        intLowHex = intValue - intHighHex * 16
        
        If intHighHex < 10 Then
            intHighHex = intHighHex + 48
        Else
            intHighHex = intHighHex + 55
        End If
        If intLowHex < 10 Then
            intLowHex = intLowHex + 48
        Else
            intLowHex = intLowHex + 55
        End If
        
        strHex(Index) = strHex(Index) + Chr$(intHighHex) + Chr$(intLowHex)
    Next n
End Function

Function GetReceiveTextTotal(Index As Integer) As String
    Dim n As Integer
    Dim intValue As Integer
    Dim intHighHex As Integer
    Dim intLowHex As Integer
    Dim strSingleChr As String * 1
    
    
    strAsciiAll(Index) = ""            '设置初值
    strHexAll(Index) = ""
    For n = 1 To intReceiveLenAll
        intValue = bytReceiveByteAll(n - 1)
        
        If intValue < 32 Or intValue > 128 Then         '处理非法字符
            strSingleChr = Chr(46)                      '对于不能显示的ASCII码,
        Else                                            '用"."表示
            strSingleChr = Chr(intValue)
        End If
        
        strAsciiAll(Index) = strAsciiAll(Index) + strSingleChr
        
        intHighHex = intValue \ 16
        intLowHex = intValue - intHighHex * 16
        
        If intHighHex < 10 Then
            intHighHex = intHighHex + 48
        Else
            intHighHex = intHighHex + 55
        End If
        If intLowHex < 10 Then
            intLowHex = intLowHex + 48
        Else
            intLowHex = intLowHex + 55
        End If
        
        strHexAll(Index) = strHexAll(Index) + Chr$(intHighHex) + Chr$(intLowHex)
    Next n
End Function

Function ConvertHexChr(str As String) As Integer
    
    Dim test As Integer
    
    test = Asc(str)
    If test >= Asc("0") And test <= Asc("9") Then
        test = test - Asc("0")
    ElseIf test >= Asc("a") And test <= Asc("f") Then
        test = test - Asc("a") + 10
    ElseIf test >= Asc("A") And test <= Asc("F") Then
        test = test - Asc("A") + 10
    Else
        test = -1                                       '出错信息
    End If
    ConvertHexChr = test
    
End Function


Function strHexToByteArray(strText As String, bytByte() As Byte) As Integer
    
    Dim HexData As Integer          '十六进制(二进制)数据字节对应值
    Dim hstr As String * 1          '高位字符
    Dim lstr As String * 1          '低位字符
    Dim HighHexData As Integer      '高位数值
    Dim LowHexData As Integer       '低位数值
    Dim HexDataLen As Integer       '字节数
    Dim StringLen As Integer        '字符串长度
    Dim Account As Integer          '计数
        
    strTestn = ""                   '设初值
    HexDataLen = 0
    strHexToByteArray = 0
    
    StringLen = Len(strText)
    Account = StringLen \ 2
    ReDim bytByte(Account)
    
    For n = 1 To StringLen
    
        Do                                              '清除空格
            hstr = Mid(strText, n, 1)
            n = n + 1
            If (n - 1) > StringLen Then
                HexDataLen = HexDataLen - 1
                
                Exit For
            End If
        Loop While hstr = " "
        
        Do
            lstr = Mid(strText, n, 1)
            n = n + 1
            If (n - 1) > StringLen Then
                HexDataLen = HexDataLen - 1
                
                Exit For
            End If
        Loop While lstr = " "
        n = n - 1
        If n > StringLen Then
            HexDataLen = HexDataLen - 1
            Exit For
        End If
        
        HighHexData = ConvertHexChr(hstr)
        LowHexData = ConvertHexChr(lstr)
        
        If HighHexData = -1 Or LowHexData = -1 Then     '遇到非法字符中断转化
            HexDataLen = HexDataLen - 1
            
            Exit For
        Else
            
            HexData = HighHexData * 16 + LowHexData
            bytByte(HexDataLen) = HexData
            HexDataLen = HexDataLen + 1
            
            
        End If
                        
    Next n
    
    If HexDataLen > 0 Then                              '修正最后一次循环改变的数值
        HexDataLen = HexDataLen - 1
        ReDim Preserve bytByte(HexDataLen)
    Else
        ReDim Preserve bytByte(0)
    End If
    
    
    If StringLen = 0 Then                               '如果是空串,则不会进入循环体
        strHexToByteArray = 0
    Else
        strHexToByteArray = HexDataLen + 1
    End If
    
    
End Function


Sub controlCommand(ByVal strCommand As String, ByVal commPort As Integer)
    On Error GoTo ErrorHandler
    
    Dim strTemp As String
    strTemp = strCommand
    Dim longth As Integer
    longth = strHexToByteArray(strTemp, bytSendByte())
    
    If longth <> 0 Then
        If Not frmMain.MSComm1(commPort).PortOpen Then
             frmMain.MSComm1(commPort).PortOpen = True
            frmMain.MSComm1(commPort).Output = bytSendByte()
 '           frmMain.MSComm1(commPort).PortOpen = False
        Else
            frmMain.MSComm1(commPort).Output = bytSendByte()
 '           frmMain.MSComm1(commPort).PortOpen = False
        End If
    End If
    Exit Sub
    
ErrorHandler:
   Select Case Err.Number
      Case 8005
        MsgBox "串口" & commPort + 1 & "已被占用，请检查！", vbOKOnly, "警告"
        Err.Clear
        Exit Sub
      Case 8002
        MsgBox "串口" & frmMain.MSComm1(commPort).commPort & "不存在，请检查！", vbOKOnly, "警告"
        Err.Clear
        Exit Sub
      Case Else
        MsgBox "未知错误", vbOKOnly, "警告"
        Err.Clear
        Exit Sub
   End Select
   Resume
End Sub

Sub saveWord()
'    Dim MyFile
'    MyFile = Dir(dataFile)
    On Error GoTo DocError
    Dim x As Long
    Dim Y As String
    Dim i As Integer
    Dim i1 As Integer
    
    Dim count As Integer
    count = 0
    Dim i2 As Integer
    For i2 = 0 To 39
        If savewordIndexandLength(i2, 0) <> 999 Then
            count = count + 1
        End If
    Next i2
    
    Dim wrd As Object
    Set wrd = CreateObject("Word.Application")
    wrd.Visible = False
    Dim templateFile As String
    
    If ttrain = "100" And savewordTestType = 0 Then
        templateFile = App.Path & "\模版\SS3B主变.doc"
        dlgSS3BTesttype.ProgressBar4.Max = count
    ElseIf ttrain = "100" And savewordTestType = 1 Then
        templateFile = App.Path & "\模版\SS3B电流互感器.doc"
        dlgSS3BTesttype.ProgressBar5.Max = count
    ElseIf ttrain = "100" And savewordTestType = 2 Then
        templateFile = App.Path & "\模版\SS3B电抗器.doc"
        dlgSS3BTesttype.ProgressBar6.Max = count
    ElseIf ttrain = "200" Then
        templateFile = App.Path & "\模版\SS4G主变.doc"
        dlgSS4GTesttype.ProgressBar4.Max = count
    ElseIf ttrain = "300" And savewordTestType = 0 Then
        templateFile = App.Path & "\模版\SS6B主变.doc"
        dlgSS6BTesttype.ProgressBar4.Max = count
    ElseIf ttrain = "300" And savewordTestType = 2 Then
        templateFile = App.Path & "\模版\SS6B平波电抗器.doc"
        dlgSS6BTesttype.ProgressBar5.Max = count
    ElseIf ttrain = "300" And savewordTestType = 3 Then
        templateFile = App.Path & "\模版\SS6B滤波电抗器.doc"