frmfunchead.frm

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

        FrmFuncTest.ReadCom.Output = vSndAry
 
        'read from input buffer
        sTime = Timer
        bolWritePlcB_05 = True
        Do While bolWritePlcB_05
           If FrmFuncTest.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 = FrmFuncTest.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
              '设置运行状态信号灯
              Set FrmFuncTest.RunImage.Picture = LoadPicture(App.Path & "\button\redlamp.gif")
              
              
              Exit Function
           End If
        End If
        If bolWritePlcB_05 Then
            '设置运行状态信号灯
            Set FrmFuncTest.RunImage.Picture = LoadPicture(App.Path & "\button\greenlamp.gif")
        Else
            '设置运行状态信号灯
            Set FrmFuncTest.RunImage.Picture = LoadPicture(App.Path & "\button\redlamp.gif")
        End If
        
        Exit Function
       
      
        
WritePlcErr:
        bolWritePlcB_05 = False
        '设置运行状态信号灯
        Set FrmFuncTest.RunImage.Picture = LoadPicture(App.Path & "\button\redlamp.gif")
End Function
 




Private Sub Command2_Click()

End Sub

Private Sub CmdNo_Click()
    FillComp = True
    Unload Me
      SetWindowPos DefMsgBox.hwnd, HWND_TOPMOST, 200, 100, 400, 185, SWP_SHOWWINDOW
      DefMsgBox.Text1 = "You can't be test!"
      Do Until DefMsgComp
        DoEvents
      Loop

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

TempFileName = Trim$(TextWO)
'====开始保存文件
Open App.Path & "\ResultFiles\" & TempFileName & "func.txt" For Output As #1
Print #1, , "Function 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
    SetWindowPos DefMsgBox.hwnd, HWND_TOPMOST, 200, 100, 400, 185, SWP_SHOWWINDOW
    DefMsgBox.Text1 = Error$
    Do Until DefMsgComp
      DoEvents
    Loop
    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"
  'TextVersion = GetFromINI("REPORT", "VERSION", App.Path & "\INI\REPORT.INI")
  'TextType = GetFromINI("REPORT", "TYPE", App.Path & "\INI\REPORT.INI")
  'TextEquipID = GetFromINI("REPORT", "EQPID", App.Path & "\INI\REPORT.INI")
  TextDate.Text = TextDate
  FillComp = False
  FillSucc = False
Exit Sub
LoadErr:
    SetWindowPos DefMsgBox.hwnd, HWND_TOPMOST, 200, 100, 400, 185, SWP_SHOWWINDOW
    DefMsgBox.Text1 = Error$
    Do Until DefMsgComp
      DoEvents
    Loop
   
End Sub


Private Function bolReadPlcB_03(ByVal iDeviceID As Integer, ByVal iAddr As Integer, ByVal iLen As Integer, vRetAryB As Variant) As Boolean
'作者:Henry
'目的:
'     读取Plc中选定区段的数据
'传入:
'     iFuncIndex:功能号
'     iPlc:欲读取之Plc Id
'     iAddr:欲读取数据的起始地址
'     iLen:欲读取线圈或寄存器的个数(iLen=1代表读取2Bytes)
'     vRetAryB:传回区段数据的Byte数组
'传回:
'     True:成功
'     False:失败
'注:读取之区段数据将存入vRetAryB中
'   已修改成以二进位方式传送
'   有应答正确性检核
 
Dim sTime, cTime As Single
Dim Dummy As Integer
Dim bSndAry(7) As Byte
Dim vCrc As Variant
Dim vRetStr As Variant
Dim SndStr, CrcStr As String
Dim iHByte, iLByte As Integer
Dim iLenB As Integer    '以Byte为单位的取得长度
 
 
        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 FrmFuncTest.ReadCom.PortOpen = False Then
           FrmFuncTest.ReadCom.PortOpen = True
        End If
        
        '清除input/output buffer
        FrmFuncTest.ReadCom.InBufferCount = 0
        FrmFuncTest.ReadCom.OutBufferCount = 0
        
      
        '写入output buffer
        FrmFuncTest.ReadCom.Output = bSndAry
 
        '读取input buffer全部数据
        iLenB = iLen * 2
        sTime = Timer
        bolReadPlcB_03 = True
        Do While bolReadPlcB_03
           If FrmFuncTest.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 = FrmFuncTest.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
                '设置运行状态信号灯
                Set FrmFuncTest.RunImage.Picture = LoadPicture(App.Path & "\button\redlamp.gif")
              Exit Function
           End If
        End If
        
        If bolReadPlcB_03 Then
            '设置运行状态信号灯
            Set FrmFuncTest.RunImage.Picture = LoadPicture(App.Path & "\button\greenlamp.gif")
        Else
            '设置运行状态信号灯
            Set FrmFuncTest.RunImage.Picture = LoadPicture(App.Path & "\button\redlamp.gif")
        End If
        
        
        Exit Function
       
        
readplcerr:
        bolReadPlcB_03 = False
        '设置运行状态信号灯
        Set FrmFuncTest.RunImage.Picture = LoadPicture(App.Path & "\button\redlamp.gif")
End Function



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

End Sub


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

End Sub


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