frmwirehead.frm

电梯检测系统是对电梯性能进行检测的系统。是一个用来学习的程序。

        iHByte = iAddr \ 256 '取商数
        iLByte = iAddr Mod 256 '取余数
        
        '将整数变量内容置入Byte变数组中
        bSndAry(0) = iDeviceID
        bSndAry(1) = 3
        bSndAry(2) = iHByte
        bSndAry(3) = iLByte
        bSndAry(4) = iLen \ 256
        bSndAry(5) = iLen Mod 256
        
        vCrc = CrcB(bSndAry(), 6)
        bSndAry(6) = vCrc(0)
        bSndAry(7) = vCrc(1)
        If FrmWireTest.ReadCom.PortOpen = False Then
           FrmWireTest.ReadCom.PortOpen = True
        End If
        
        '清除input/output buffer
        FrmWireTest.ReadCom.InBufferCount = 0
        FrmWireTest.ReadCom.OutBufferCount = 0
        
      
        '写入output buffer
        FrmWireTest.ReadCom.Output = bSndAry
 
        '读取input buffer全部数据
        iLenB = iLen * 2
        sTime = Timer
        bolReadPlcB_03 = True
        Do While bolReadPlcB_03
           If FrmWireTest.ReadCom.InBufferCount >= iLenB + 5 Then
              bolReadPlcB_03 = True
              Exit Do
           End If
           cTime = Timer
           If (cTime - sTime) > cTimeOut Then
              bolReadPlcB_03 = False
           Else
              If (Timer - sTime) < 0 Then sTime = Timer
           End If
          ' Dummy = DoEvents()
        Loop
 
        If bolReadPlcB_03 Then
           vRetAryB = FrmWireTest.ReadCom.Input
            vCrc = CrcB(vRetAryB, iLenB + 3)
           If vRetAryB(0) <> bSndAry(0) Or vRetAryB(1) <> bSndAry(1) Or _
              vCrc(0) <> vRetAryB(iLenB + 3) Or vCrc(1) <> vRetAryB(iLenB + 4) Then
             bolReadPlcB_03 = False
              Exit Function
           End If
        End If
        
        
        
        Exit Function
       
        
readplcerr:
        bolReadPlcB_03 = False
        '设置运行状态信号灯
        Set RunImage.Picture = LoadPicture(App.Path & "\button\redlamp.gif")
End Function



Private Sub CmdNo_Click()
    Unload Me
    MsgBox "You can't be test!", vbExclamation
    FillComp = True
End Sub

Private Sub CmdYes_Click()
  Dim i As Integer

  On Error Resume Next
  If InStr(1, TextID.Text, "e", vbTextCompare) <> 0 Or InStr(1, TextWO.Text, "e", vbTextCompare) <> 0 Or InStr(1, TextEquipID.Text, "e", vbTextCompare) <> 0 _
   Or InStr(1, TextID.Text, "&", vbTextCompare) <> 0 Or InStr(1, TextWO.Text, "&", vbTextCompare) <> 0 Or InStr(1, TextEquipID.Text, "e", vbTextCompare) <> 0 Then
    SetWindowPos DefMsgBox.hwnd, HWND_TOPMOST, 200, 100, 400, 185, SWP_SHOWWINDOW
    DefMsgBox.Text1 = "Tester ID ,internal work number,Equipment ID only can be numberic."
    Do Until DefMsgComp
      DoEvents
    Loop
    Exit Sub
  End If
  Label3.Caption = TextID.Text * TextWO.Text * TextEquipID.Text
  If Err.number = 13 Then
    SetWindowPos DefMsgBox.hwnd, HWND_TOPMOST, 200, 100, 400, 185, SWP_SHOWWINDOW
    DefMsgBox.Text1 = "Tester ID ,internal work number,Equipment ID only can be numberic."
    Do Until DefMsgComp
      DoEvents
    Loop
    Exit Sub
  End If


On Error GoTo ClickErr

If Trim$(TextID) = "" Then
    SetWindowPos DefMsgBox.hwnd, HWND_TOPMOST, 200, 100, 400, 185, SWP_SHOWWINDOW
  DefMsgBox.Text1 = "Tester ID can't be null!"
  Do Until DefMsgComp
    DoEvents
  Loop
  Exit Sub
End If

If Trim$(TextWO) = "" Then
    SetWindowPos DefMsgBox.hwnd, HWND_TOPMOST, 200, 100, 400, 185, SWP_SHOWWINDOW
  DefMsgBox.Text1 = "Tester product internal work order number can't be null!"
  Do Until DefMsgComp
    DoEvents
  Loop
  Exit Sub
End If

If Trim$(TextEquipID) = "" Then
    SetWindowPos DefMsgBox.hwnd, HWND_TOPMOST, 200, 100, 400, 185, SWP_SHOWWINDOW
  DefMsgBox.Text1 = "Equipment ID can't be null!"
  Do Until DefMsgComp
    DoEvents
  Loop
  
  Exit Sub
End If
'check IT2
'delay 1 second
cTime = Timer
  Do Until Timer - cTime > 1
   DoEvents
  Loop
 
  If bolReadPlcB_03(iDeviceID, CountAddr, 9, LngVRetAryB) Then
  Else
    FrmWireTest.TestResult.Text = FrmWireTest.TestResult.Text + "Signal read error." & Chr(10)
    SetWindowPos DefMsgBox.hwnd, HWND_TOPMOST, 200, 100, 400, 185, SWP_SHOWWINDOW
    DefMsgBox.Text1 = "Signal read error."
    Exit Sub
  End If
  If Not SignalBitRight(LngVRetAryB, IT2 - 16, 0) Then
    SetWindowPos DefMsgBox.hwnd, HWND_TOPMOST, 200, 100, 400, 185, SWP_SHOWWINDOW
    DefMsgBox.Text1 = "IT2 signal is not off. Wire test can't go on."
    Do Until DefMsgComp
      DoEvents
    Loop
    Exit Sub
  End If


TempFileName = Trim$(TextWO)
'====开始保存文件
Open App.Path & "\ResultFiles\" & TempFileName & "Wire.txt" For Output As #1
Print #1, , "Wire Test Report"
Print #1, "Tester Id:" & Trim$(TextID)
Print #1, "Test product internal work order number:" & Trim$(TextWO)
Print #1, "Test date and test time:" & Trim$(TextDate)
Print #1, "Test software version:" & Trim$(TextVersion)
Print #1, "Type of tested product:" & Trim$(TextType.Text)
Print #1, "Test equipment ID:" & Trim$(TextEquipID.Text)
Close #1
FillComp = True
FillSucc = True
Unload Me
Exit Sub
ClickErr:
    Unload Me
    MsgBox Err.Description, vbExclamation
    Resume
    On Error Resume Next
    Close #1
End Sub

Private Sub Form_Load()
On Error GoTo LoadErr

  TextDate = Format$(Now, "MM-DD-YYYY HH:MM")
  TextVersion = "V1.0"

  TextDate.Text = TextDate
  FillComp = False
  FillSucc = False
Exit Sub
LoadErr:
   MsgBox Err.Description, vbExclamation
   
End Sub

Private Function bolWritePlcB_05(ByVal iDeviceID As Integer, ByVal iAddr As Integer, ByVal iSetValue As Integer) As Boolean
'作者:Henry
'目的:
'     写入传入字符串至Plc，可选定地址
'传入:
'     iFuncIndex:功能号
'     iAddr:欲写入数据的起始地址
'     iSetValue:欲强制的状态（&HFF or &H00)
'传回:
'     True:成功
'     False:失败
'   有应答正确性检核
 
 
        Dim sTime, cTime As Single
        Dim Dummy As Integer
        Dim vSndAry As Variant
        Dim iSndLen As Integer
        Dim vRetAry As Variant
        Dim vCrcAry As Variant
        Dim i As Integer
        Dim bHeadAry(5) As Byte
        Dim k As Long, m As Long
        On Error GoTo WritePlcErr
        
        bHeadAry(0) = iDeviceID
        bHeadAry(1) = 5
        bHeadAry(2) = iAddr \ 256
        bHeadAry(3) = iAddr Mod 256 - 1
        bHeadAry(4) = iSetValue
        bHeadAry(5) = 0
                        
        iSndLen = 8 '9 + iLenB - 1
        ReDim vSndAry(0 To iSndLen - 1)
        
        vSndAry = CmbAryB(bHeadAry, CrcB(bHeadAry, 6))
        CommBusy = True
        If ReadCom.PortOpen = False Then
            ReadCom.PortOpen = True
        End If

        'clear input/output buffer
        ReadCom.InBufferCount = 0
        ReadCom.OutBufferCount = 0
 
        'write to output buffer
        ReadCom.Output = vSndAry
 
        'read from input buffer
        sTime = Timer
        bolWritePlcB_05 = True
        Do While bolWritePlcB_05
           If ReadCom.InBufferCount >= 8 Then
              bolWritePlcB_05 = True
              Exit Do
           End If
           cTime = Timer
           If (cTime - sTime) > cTimeOut Then
              bolWritePlcB_05 = False
           Else
              If (Timer - sTime) < 0 Then sTime = Timer
           End If
           Dummy = DoEvents()
        Loop
        
        If bolWritePlcB_05 Then
           vRetAry = ReadCom.Input
           vCrcAry = CrcB(vRetAry, 6)
           If vCrcAry(0) <> vRetAry(6) Or vCrcAry(1) <> vRetAry(7) _
              Or vSndAry(0) <> vRetAry(0) Or vSndAry(1) <> vRetAry(1) Then
              bolWritePlcB_05 = False
              Exit Function
           End If
        End If
        
        Exit Function
       
      
        
WritePlcErr:
        bolWritePlcB_05 = False
End Function
 




Private Sub TextID_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
   SendKeys "{TAB}"
End If
End Sub


Private Sub TextWO_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
   SendKeys "{TAB}"
End If

End Sub