frmbf.frm

Visual Basic串口通信技术与典型实例

VERSION 5.00
Begin VB.Form frmbf 
   ClientHeight    =   3825
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   7440
   LinkTopic       =   "Form1"
   ScaleHeight     =   3825
   ScaleWidth      =   7440
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton cmdCancel 
      Caption         =   "取消"
      Height          =   495
      Left            =   5400
      TabIndex        =   15
      Top             =   2880
      Width           =   1215
   End
   Begin VB.CommandButton cmdEnter 
      Caption         =   "确定"
      Height          =   495
      Left            =   5400
      TabIndex        =   14
      Top             =   1920
      Width           =   1215
   End
   Begin VB.Frame Frame2 
      Height          =   615
      Left            =   1440
      TabIndex        =   11
      Top             =   2880
      Width           =   2895
      Begin VB.OptionButton Option4 
         Caption         =   "否"
         Height          =   255
         Left            =   1440
         TabIndex        =   13
         Top             =   240
         Width           =   975
      End
      Begin VB.OptionButton Option3 
         Caption         =   "是"
         Height          =   195
         Left            =   120
         TabIndex        =   12
         Top             =   240
         Width           =   975
      End
   End
   Begin VB.TextBox Text3 
      Height          =   495
      Left            =   1440
      TabIndex        =   9
      Top             =   1080
      Width           =   1935
   End
   Begin VB.Frame Frame1 
      Height          =   615
      Left            =   1440
      TabIndex        =   5
      Top             =   1920
      Width           =   2895
      Begin VB.OptionButton Option2 
         Caption         =   "并口"
         Height          =   255
         Left            =   1440
         TabIndex        =   7
         Top             =   240
         Width           =   1095
      End
      Begin VB.OptionButton Option1 
         Caption         =   "串口"
         Height          =   255
         Left            =   120
         TabIndex        =   6
         Top             =   240
         Width           =   1095
      End
   End
   Begin VB.TextBox Text2 
      Height          =   495
      Left            =   4920
      TabIndex        =   3
      Top             =   240
      Width           =   1695
   End
   Begin VB.TextBox Text1 
      Height          =   495
      Left            =   1440
      TabIndex        =   1
      Top             =   240
      Width           =   1695
   End
   Begin VB.Label Label5 
      Caption         =   "是否启用"
      Height          =   375
      Left            =   360
      TabIndex        =   10
      Top             =   2880
      Width           =   735
   End
   Begin VB.Label Label4 
      Caption         =   "端口编号"
      Height          =   375
      Left            =   360
      TabIndex        =   8
      Top             =   1080
      Width           =   855
   End
   Begin VB.Label Label3 
      Caption         =   "端口属性"
      Height          =   375
      Left            =   360
      TabIndex        =   4
      Top             =   2040
      Width           =   735
   End
   Begin VB.Label Label2 
      Caption         =   "编码"
      Height          =   375
      Left            =   3600
      TabIndex        =   2
      Top             =   360
      Width           =   615
   End
   Begin VB.Label Label1 
      Caption         =   "布防名称"
      Height          =   375
      Left            =   360
      TabIndex        =   0
      Top             =   360
      Width           =   735
   End
End
Attribute VB_Name = "frmbf"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'布防参数变量
Private gbfname As String            '添加删除编辑面板上记录各属性值
Private gbfcode As String
Private gporperty As String
Private gnum As String
Private gpm As Boolean
Private Sub cmdCancel_Click()
   Unload Me
End Sub

Private Sub cmdEnter_Click()
   Call getdata                    '从form上得到要写进数据库的数据
    
  
   '根据不同操作采取不同的action
  Select Case Me.Caption
      Case "删除布防"
         If MsgBox("是否确实要删除该条布防参数", vbYesNo, "询问") = vbYes Then
             Call deleteBf
         End If
      Case "添加布防"
           If dataCheck() Then          '数据检查并给以提示
                Call AddNew
              Else:
                 MsgBox ("事件编码重复，请检查")
           End If
      Case "编辑布防"
           If dataCheck() Then          '数据检查并给以提示
                 Call editBf
              Else:
                 MsgBox ("事件编码重复，请检查")
           End If
  End Select
  
  Unload Me
End Sub

Private Sub Form_Load()
   Me.Top = (frmbaojing.Height - Me.Height) / 2
   Me.Left = (frmbaojing.Width - Me.Width) / 2
   '添加布防需要初始化参数
   If Me.Caption <> "添加布防" Then Call paraInit
   
End Sub
'参数初始化
Private Sub paraInit()
     
   If chkIndex = 0 Then Exit Sub    '如果没有选中则不用进行表格内容写入。
   '初始化参数bfname,bfcode,porperty,number
   gbfname = frmSetbf.ListView.ListItems(chkIndex).Text
   gbfcode = frmSetbf.ListView.ListItems(chkIndex).SubItems(1)
   gporperty = frmSetbf.ListView.ListItems(chkIndex).SubItems(2)
   gnum = frmSetbf.ListView.ListItems(chkIndex).SubItems(3)
   
   Select Case frmSetbf.ListView.ListItems(chkIndex).SubItems(4)
          Case "启用"
                  gpm = True
          Case "禁用"
                  gpm = False
   End Select
   '将初始化完毕的参数返回到form上面
   Text1.Text = gbfname
   Text2.Text = gbfcode
   
   If gporperty = "串口" Then
      Option1.Value = True
      Option2.Value = False
   Else
      Option2.Value = True
      Option1.Value = False
   End If
   Text3.Text = gnum
   
   If gpm Then
          Option3.Value = True
          Option4.Value = False
   Else
         Option3.Value = False
         Option4.Value = True
   End If
End Sub
'新加一条记录
Private Sub AddNew()
  On Error GoTo x
     Dim rs As ADODB.Recordset
        Set rs = New ADODB.Recordset
        rs.Open "select * from bufangset;", cn, adOpenDynamic, adLockOptimistic
       rs.AddNew
           rs!bfname = gbfname
           rs!bfcode = BintoDec(gbfcode)
           rs!porperty = gporperty
           rs!Number = gnum
           rs!promote = gpm
        rs.Update
        rs.Close
      
        '将list更新
      Dim mitem As ListItem
        Set mitem = frmSetbf.ListView.ListItems.Add(Text:=gbfname)
        If IsNull(gbfcode) Then
             mitem.SubItems(1) = "-"
        Else
              mitem.SubItems(1) = gbfcode
        End If
        
        If IsNull(gporperty) Then
              mitem.SubItems(2) = "-"
        Else
              mitem.SubItems(2) = gporperty
        End If
        
        If IsNull(gnum) Then
              mitem.SubItems(3) = "-"
        Else
              mitem.SubItems(3) = gnum
        End If
        
        If IsNull(gpm) Then
              mitem.SubItems(4) = "-"
        Else
           If gpm Then
                 mitem.SubItems(4) = "启用"
           Else
                 mitem.SubItems(4) = "禁用"
           End If
        End If
       
      Exit Sub
x:
   MsgBox ("请再次检查数据")
End Sub
'删除一条记录
Private Sub deleteBf()
  On Error GoTo x
     Dim rs As ADODB.Recordset
         Set rs = New ADODB.Recordset
     Dim str As String
         str = "select * from BufangSet where bfname = '" & gbfname & "';"
       rs.Open str, cn, adOpenDynamic, adLockOptimistic
    If rs.EOF Or rs.BOF Then
        MsgBox ("数据库中没有这条记录")
        Exit Sub
    Else
        rs.Delete
        rs.Update
    End If
       rs.Close
   
   frmSetbf.ListView.ListItems.Remove chkIndex
   Exit Sub
   
x:
    MsgBox ("Error # " & CStr(Err.Number) & " was generated by " _
         & Err.Source & Chr(13) & Err.Description)
End Sub
'编辑一条纪录
Private Sub editBf()
  On Error GoTo errordo
    Dim rs As ADODB.Recordset
       Set rs = New ADODB.Recordset
    Dim str As String
    Dim tempbfname As String
       tempbfname = frmSetbf.ListView.ListItems(chkIndex)
       str = "select * from BufangSet where bfname = '" & tempbfname & "';"
       rs.Open str, cn, adOpenDynamic, adLockOptimistic
            rs!bfname = gbfname
            rs!bfcode = BintoDec(gbfcode)
            rs!porperty = gporperty
            rs!Number = gnum
            rs!promote = gpm
        rs.Update
        rs.Close
    
    Dim itemx As ListItem
        Set itemx = frmSetbf.ListView.ListItems(chkIndex)
            itemx.Text = gbfname
            itemx.SubItems(1) = gbfcode
            itemx.SubItems(2) = gporperty
            itemx.SubItems(3) = gnum
    
         If gpm Then
               itemx.SubItems(4) = "启用"
         Else
               itemx.SubItems(4) = "禁用"
         End If
     Exit Sub
     
errordo:
     MsgBox ("Error # " & CStr(Err.Number) & " was generated by " _
         & Err.Source & Chr(13) & Err.Description)
End Sub
'获得数据从操作面板上
Private Sub getdata()
  gbfname = Trim$(Text1.Text)
  gbfcode = Trim$(Text2.Text)
 
  If Option1.Value Then
      gporperty = "串口"
  Else
      gporperty = "并口"
  End If
   gnum = Trim$(Text3.Text)
 
  If Option3.Value Then
      gpm = True
  Else
      gpm = False
  End If
End Sub
'数据检查规则:事件编码是否重复
Private Function dataCheck() As Boolean
Dim i As Integer
Dim itemx As ListItem
    
    For i = 1 To frmSetbf.ListView.ListItems.count
        Set itemx = frmSetbf.ListView.ListItems(i)
If (itemx.SubItems(1) = gbfcode) And (itemx.SubItems(2) = gporperty) And (itemx.SubItems(3) = gnum) Then
              dataCheck = False
              Exit Function
End If
    Next i
    dataCheck = True
    
End Function
'字符串是否为二进制的判断
Private Function BinX(str As String) As Boolean
Dim i As Integer
Dim length As Integer
       length = Len(str)
     If length <= 8 Then
              BinX = True
     Else
          BinX = False
     End If
End Function

'事件编码的键盘输入限制条件:0 1
Private Sub Text2_KeyPress(KeyAscii As Integer)
   Select Case KeyAscii
          Case Asc(0), Asc(1)
             
          Case Else
             KeyAscii = 0
   End Select
End Sub

'触发事件编码判断
Private Sub Text2_Validate(Cancel As Boolean)
    If Not BinX(Text2.Text) Then
          MsgBox ("触发事件码应为0,1代码")
          Text2.Text = "0000"
    End If
End Sub

Private Sub Text3_Change()
    '判断端口编号是否为数字
    If Not IsNumeric(Text3.Text) Then
               If Text3.Text <= 0 Then
                   Dim n As Integer
                    n = MsgBox("端口编号应该为十进制数", , 重要提示)
                    Text3.Text = "0"
               End If
    End If
    '如果端口编号是数字的话
    '再分别按照端口类型判断
    'option1:串行端口
    If Option1.Value Then
             If CLng(Text3.Text) > 16 Then
                   MsgBox ("串口编号范围在0-16之间")
                   Text3.Text = "0"
             End If
    End If
    'option2:并行端口
    If Option2.Value Then
             If CLng(Text3.Text) > 65536 Then
                   MsgBox ("并口编号范围在0-65536之间")
                   Text3.Text = "0"
             End If
     End If
End Sub