vb源码.txt

VB6.0小程序控制单片机P1口8位LED.很好用的

              portswitch.Caption = "打开串口"
            End If
            If Cmdofflink.Enabled = True Then
              End ''''''''''''
            Else
              Call clearallkey
              thing = "关闭串口"
              Call record '''''''''''''''发送命令
              thing = "脱机成功，设备已断开连接"
              Call record
              lablink.Caption = "等待连接"
            End If
       '-------------通信状态检测与信息反馈------------
          Case "F" & Chr(inbuff(4)) & "\" & "\"
                        
            ledback1 = inbuff(4)
            Call ledreback
            lablink.Caption = "连接正常！"
            lablink.ForeColor = QBColor(2)
            linkerrorcount = 0
            If signmsg = False Then
              signmsg = True
              startsign = False
              thing = "通信已恢复！"
              Call record
              MsgBox "设备与PC通信已恢复！", vbExclamation, "信息提示"
            Else
              If startsign = True Then
                startsign = False
                thing = "系统已就绪！"
                Call record
              End If
            End If
       '------------校验信息-------------
          Case "I" & OUTdataB & OUTdataC & OUTdataD ''''''校验语句
            
            ledback1 = inbuff(5) * 16 + inbuff(6)
            If Asc(OUTdataB) = 0 Then                  'LED亮操作
              ledback1 = ledback1 And ledback2
            ElseIf Asc(OUTdataB) = 1 Then              'LED灭操作
              ledback1 = ledback1 Or ledback2
            End If
            Call ledreback
            OUTdataA = "A"       '发送 允许执行信号
            OUTdataB = "A"
            OUTdataC = "A"
            OUTdataD = "A"
            Call sendFirstbyte
            thing = "命令已接收！"
            Call record
     ''''''''''''''''''''''''''''
          Case Else
            Call linkerror
        ''''''''''
        End Select
  '''''''''''''''''''''''
      End If
    
    Case comEvSend

  End Select

  MSComm1.OutBufferCount = 0 '清空发送缓冲区
  
End Sub
Public Sub ledreback()
  ''''''''''LED状态反馈''''''''''
  ledback2 = ledback1
  ''''''整除'''''''   ''''''求余''''''
  b0 = (ledback2) \ 2: yu0 = (ledback2) Mod 2
  b1 = b0 \ 2: yu1 = b0 Mod 2
  b2 = b1 \ 2: yu2 = b1 Mod 2
  b3 = b2 \ 2: yu3 = b2 Mod 2
  b4 = b3 \ 2: yu4 = b3 Mod 2
  b5 = b4 \ 2: yu5 = b4 Mod 2
  b6 = b5 \ 2: yu6 = b5 Mod 2
  b7 = b6 \ 2: yu7 = b6 Mod 2
  thing = "收到LED状态" & yu7 & yu6 & yu5 & yu4 & yu3 & yu2 & yu1 & yu0
  Call record                        '
  '''''''''LED1状态'''''''''
  If yu0 = 0 Then
    ShapeLED1.FillColor = QBColor(12)
    FrameLED1.Caption = "LED1亮"
    FrameLED1.ForeColor = QBColor(12)
    CmdL1bright.Enabled = False
    CmdL1die.Enabled = True
  ElseIf yu0 = 1 Then
    ShapeLED1.FillColor = QBColor(8)
    FrameLED1.Caption = "LED1灭"
    FrameLED1.ForeColor = QBColor(0)
    CmdL1bright.Enabled = True
    CmdL1die.Enabled = False
  End If
  '''''''''LED2状态'''''''''
  If yu1 = 0 Then
    ShapeLED2.FillColor = QBColor(12)
    FrameLED2.Caption = "LED2亮"
    FrameLED2.ForeColor = QBColor(12)
    CmdL2bright.Enabled = False
    CmdL2die.Enabled = True
  ElseIf yu1 = 1 Then
    ShapeLED2.FillColor = QBColor(8)
    FrameLED2.Caption = "LED2灭"
    FrameLED2.ForeColor = QBColor(0)
    CmdL2bright.Enabled = True
    CmdL2die.Enabled = False
  End If
  '''''''''LED3状态'''''''''
  If yu2 = 0 Then
    ShapeLED3.FillColor = QBColor(12)
    FrameLED3.Caption = "LED3亮"
    FrameLED3.ForeColor = QBColor(12)
    CmdL3bright.Enabled = False
    CmdL3die.Enabled = True
  ElseIf yu2 = 1 Then
    ShapeLED3.FillColor = QBColor(8)
    FrameLED3.Caption = "LED3灭"
    FrameLED3.ForeColor = QBColor(0)
    CmdL3bright.Enabled = True
    CmdL3die.Enabled = False
  End If
  '''''''''LED4状态'''''''''
  If yu3 = 0 Then
    ShapeLED4.FillColor = QBColor(12)
    FrameLED4.Caption = "LED4亮"
    FrameLED4.ForeColor = QBColor(12)
    CmdL4bright.Enabled = False
    CmdL4die.Enabled = True
  ElseIf yu3 = 1 Then
    ShapeLED4.FillColor = QBColor(8)
    FrameLED4.Caption = "LED4灭"
    FrameLED4.ForeColor = QBColor(0)
    CmdL4bright.Enabled = True
    CmdL4die.Enabled = False
  End If
  '''''''''LED5状态'''''''''
  If yu4 = 0 Then
    ShapeLED5.FillColor = QBColor(12)
    FrameLED5.Caption = "LED5亮"
    FrameLED5.ForeColor = QBColor(12)
    CmdL5bright.Enabled = False
    CmdL5die.Enabled = True
  ElseIf yu4 = 1 Then
    ShapeLED5.FillColor = QBColor(8)
    FrameLED5.Caption = "LED5灭"
    FrameLED5.ForeColor = QBColor(0)
    CmdL5bright.Enabled = True
    CmdL5die.Enabled = False
  End If
  '''''''''LED6状态'''''''''
  If yu5 = 0 Then
    ShapeLED6.FillColor = QBColor(12)
    FrameLED6.Caption = "LED6亮"
    FrameLED6.ForeColor = QBColor(12)
    CmdL6bright.Enabled = False
    CmdL6die.Enabled = True
  ElseIf yu5 = 1 Then
    ShapeLED6.FillColor = QBColor(8)
    FrameLED6.Caption = "LED6灭"
    FrameLED6.ForeColor = QBColor(0)
    CmdL6bright.Enabled = True
    CmdL6die.Enabled = False
  End If
 '''''''''LED7状态'''''''''
  If yu6 = 0 Then
    ShapeLED7.FillColor = QBColor(12)
    FrameLED7.Caption = "LED7亮"
    FrameLED7.ForeColor = QBColor(12)
    CmdL7bright.Enabled = False
    CmdL7die.Enabled = True
  ElseIf yu6 = 1 Then
    ShapeLED7.FillColor = QBColor(8)
    FrameLED7.Caption = "LED7灭"
    FrameLED7.ForeColor = QBColor(0)
    CmdL7bright.Enabled = True
    CmdL7die.Enabled = False
  End If
  '''''''''LED8状态'''''''''
  If yu7 = 0 Then
    ShapeLED8.FillColor = QBColor(12)
    FrameLED8.Caption = "LED8亮"
    FrameLED8.ForeColor = QBColor(12)
    CmdL8bright.Enabled = False
    CmdL8die.Enabled = True
  ElseIf yu7 = 1 Then
    ShapeLED8.FillColor = QBColor(8)
    FrameLED8.Caption = "LED8灭"
    FrameLED8.ForeColor = QBColor(0)
    CmdL8bright.Enabled = True
    CmdL8die.Enabled = False
  End If

End Sub
Public Sub sendFirstbyte()

  outbuff(3) = OUTdataA
  outbuff(4) = OUTdataB
  outbuff(5) = OUTdataC
  outbuff(6) = OUTdataD
  outdata(0) = outbuff(0)
  outdata(1) = outbuff(1)
  outdata(2) = outbuff(2)
  outdata(3) = outbuff(3)
  outdata(4) = outbuff(4)
  outdata(5) = outbuff(5)
  outdata(6) = outbuff(6)
  outdata(7) = outbuff(7)
  
  'If MSComm1.PortOpen = True Then
    MSComm1.Output = outdata(0) '发送数据首字节
  'End If
  
End Sub
Public Sub resendFirstbyte()        '重新发送子程序

  MSComm1.Output = outdata(0)
  'thing = "重新发送" + outdata(3) + outdata(4) + outdata(5) + outdata(6)
  'Call record
End Sub

Private Sub SliderDelay_Scroll() '''调节延时时间
  
  Select Case SliderDelay.Value ''''''''延时时间＝delay×50ms
    Case 1
      Labeldelaytime = 100 & "ms"
      delaytime = 2
    Case 2
      Labeldelaytime = 200 & "ms"
      delaytime = 4
    Case 3
      Labeldelaytime = 500 & "ms"
      delaytime = 10
    Case 4
      Labeldelaytime = 1 & "S"
      delaytime = 20
    Case 5
      Labeldelaytime = 1.5 & "S"
      delaytime = 30
    Case 6
      Labeldelaytime = 2 & "S"
      delaytime = 40
    Case 7
      Labeldelaytime = 2.5 & "S"
      delaytime = 50
    Case 8
      Labeldelaytime = 3 & "S"
      delaytime = 60
    Case 9
      Labeldelaytime = 3.5 & "S"
      delaytime = 70
    Case 10
      Labeldelaytime = 4 & "S"
      delaytime = 80
    Case 11
      Labeldelaytime = 5 & "S"
      delaytime = 100
    End Select
  If Cmdpause.Enabled = True Then
    Cmdpause.Value = True
  End If
      
  Cmdturn.ToolTipText = "LED延时" & Labeldelaytime
  Cmdsundry.ToolTipText = "LED延时" & Labeldelaytime
  Cmdflash.ToolTipText = "LED延时" & Labeldelaytime
      
End Sub

Private Sub Clear_autoLED()

  Cmdflash.Enabled = True
  Cmdflash.BackColor = &H8000000F
  Cmdsundry.Enabled = True
  Cmdsundry.BackColor = &H8000000F
  Cmdturn.Enabled = True
  Cmdturn.BackColor = &H8000000F
  
End Sub
Private Sub clearallkey()

  CmdL1bright.Enabled = False
  CmdL1die.Enabled = False
  CmdL2bright.Enabled = False
  CmdL2die.Enabled = False
  CmdL3bright.Enabled = False
  CmdL3die.Enabled = False
  CmdL4bright.Enabled = False
  CmdL4die.Enabled = False
  CmdL5bright.Enabled = False
  CmdL5die.Enabled = False
  CmdL6bright.Enabled = False
  CmdL6die.Enabled = False
  CmdL7bright.Enabled = False
  CmdL7die.Enabled = False
  CmdL8bright.Enabled = False
  CmdL8die.Enabled = False
  CmdAllbright.Enabled = False
  CmdAlldie.Enabled = False
  
  
  
End Sub

Private Sub Textthing_Change()
    If Textthing.Text = "" Then
    Cmdclear.Enabled = False
  Else
    Cmdclear.Enabled = True
  End If
End Sub

Private Sub Timer1_Timer()  '加载时间
  
  lbltime.FontSize = 15
  lbltime.Caption = Time()
  
  If Cmdofflink.Enabled = False Then    ''''脱机按钮闪烁
    If offlinkSign = True Then
      offlinkSign = False
      Cmdofflink.BackColor = QBColor(12)
    Else
      Cmdofflink.BackColor = QBColor(2)
      offlinkSign = True
    End If
  Else
    Cmdofflink.BackColor = &H8000000F
    offlinkSign = True
  End If
  
  If lablink.Caption = "连接失败！" Then '''' "连接失败！"颜色交替变化
    If lablinkSign = True Then
      lablinkSign = False
      lablink.ForeColor = QBColor(12)
    Else
      lablinkSign = True
      lablink.ForeColor = QBColor(10)
    End If
  End If
  
  
End Sub

Private Sub Timer2_Timer() '100ms检测时间间隔、端口状态

  f = Timer3.Interval / 1000
  Labelsampling.Caption = "状态检测时间间隔：" & f & "秒"
  Labelsampling.ForeColor = &H800000
  
  If MSComm1.PortOpen = True Then
    portswitch.ToolTipText = "端口已打开"
  Else
    portswitch.ToolTipText = "端口已关闭"
  End If
  
  
End Sub

Private Sub Timer3_Timer() '每3秒检查通信状态

  Dim bDT As Boolean
  Dim sPrevious As Single
  bDT = True
  sPrevious = Timer
   '''''''''''''''''''检查空闲状态语句
  If MSComm1.InBufferCount = 0 Then
    Do While bDT
    If Timer - sPrevious >= 0.1 Then bDT = False '0.1延时确保系统在空闲状态
    Loop
    bDT = True
    If MSComm1.InBufferCount = 0 Then
      ''''''''''''''''''''''''''''''''发送通信状态检测信号
      OUTdataA = "C"
      MSComm1.Output = OUTdataA
      'OUTdataB = "\"       '''''''减少发送代码节省数据传送的时间
      'OUTdataC = "\"
      'OUTdataD = "\"
      'Call sendFirstbyte
     ''''''''''''''''''''''''延时等待接收数据
      Do While bDT
      If Timer - sPrevious >= 0.2 Then bDT = False '0.2修改此参数会影响检测通信结果
      Loop
      bDT = True
      If MSComm1.InBufferCount = 0 Then
        lablink.ForeColor = QBColor(12)
        lablink.Caption = "连接失败！"
        If signmsg = True Then
          thing = "PC与设备通信被中断！"
          Call record
          ret = MsgBox("PC与设备通信被中断！", 5 + 48 + 256, "故障提示")
          If ret = 4 Then
            relink.Value = True
          End If
          signmsg = False
        End If
      End If
    End If
  End If
  
End Sub