yuntai.frm

VB串口 云台镜头控制系统 完整源码

      Align           =   2  'Align Bottom
      Height          =   285
      Left            =   0
      TabIndex        =   3
      Top             =   4320
      Width           =   7395
      _ExtentX        =   13044
      _ExtentY        =   503
      _Version        =   393216
      BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628} 
         NumPanels       =   1
         BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
         EndProperty
      EndProperty
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin VB.Frame fraYuntai 
      Caption         =   "请选择云台镜头组合"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   3855
      Left            =   240
      TabIndex        =   2
      Top             =   240
      Width           =   2175
   End
   Begin VB.PictureBox picChoose 
      BackColor       =   &H8000000A&
      BorderStyle     =   0  'None
      DrawStyle       =   6  'Inside Solid
      Height          =   350
      IMEMode         =   1  'ON
      Index           =   0
      Left            =   1440
      ScaleHeight     =   345
      ScaleMode       =   0  'User
      ScaleWidth      =   345
      TabIndex        =   0
      Top             =   1920
      Width           =   350
      Begin VB.Label labChoose 
         AutoSize        =   -1  'True
         BackColor       =   &H8000000D&
         BackStyle       =   0  'Transparent
         Caption         =   "0"
         Height          =   195
         Index           =   0
         Left            =   0
         TabIndex        =   1
         Top             =   0
         Width           =   90
      End
   End
   Begin VB.Line OuterLineBottom 
      BorderColor     =   &H80000009&
      Index           =   0
      X1              =   1560
      X2              =   1920
      Y1              =   3000
      Y2              =   3000
   End
   Begin VB.Line OuterLineRight 
      BorderColor     =   &H80000009&
      Index           =   0
      X1              =   2040
      X2              =   2040
      Y1              =   2280
      Y2              =   2640
   End
   Begin VB.Shape shpFrame 
      Height          =   375
      Index           =   0
      Left            =   1080
      Top             =   1200
      Width           =   375
   End
   Begin VB.Line InnerLineLeft 
      BorderColor     =   &H80000009&
      Index           =   0
      X1              =   720
      X2              =   720
      Y1              =   2520
      Y2              =   2160
   End
   Begin VB.Line InnerLineTop 
      BorderColor     =   &H80000009&
      Index           =   0
      X1              =   960
      X2              =   1320
      Y1              =   2640
      Y2              =   2640
   End
End
Attribute VB_Name = "frmYuntai"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'*****************************
'定义颜色
'*****************************
Private frameRgb As Long            '选择按扭边框的颜色
Private brightRgb As Long           '亮色
Private darkRgb As Long             '深色
Private bkUpRgb As Long             '上浮按钮的背景色
Private bkDownRgb As Long           '下沉按钮的背景色
'*****************************
'定义指令集和云台状态集
'*****************************
Private ByteCodeChoose(32) As Byte  '云台选择指令集
Private ByteCodeAct(5) As Byte      '状态控制指令集
Private ByteCodeMir(6) As Byte      '镜头控制指令集
Private ByteCodeStatus(3) As Byte   '状态控制指令集
Private ByteStatus(32, 2) As Byte   '所有云台的状态集合
'*****************************
'其它
'*****************************
Private curChoose As Integer        '当前选中的云台
Private Scale_X, Scale_Y As Integer '当前屏幕上一个像素所包含的twip
Private bSerial As Byte             '是否使用串口进行通信
Private IoPort As Long              '使用IO口时端口号
Private conSerialPort As New clsSerialPort  '串口类对象，存储串口设置参数
Private strFileName As String       '配置文件名
'*****************************
'定义结束
'*****************************

'*****************************
'功能：绘制云台选择按钮
'参数说明：
'gLeft：按钮组距离容器的左边界距离
'gTop：按钮组距离容器的上边界距离
'*****************************
Private Sub DrawChooseButtom(gLeft As Integer, gTop As Integer)
    Dim index As Integer '按钮的序号
    '两个按钮中心点的X方向距离和Y向距离
    Dim eleWidth, eleHeight As Integer
    Dim i, j As Integer '计数器，i表示行，j表示列
    Dim curTop As Integer   '当前按钮的左上角相对y坐标值
    Dim curLeft As Integer  '当前按钮的左上角相对x坐标值
    '定义类模块clsPushButton的对象，用于绘制按钮
    Dim PushButton As New clsPushButton
       
    frmYuntai.ScaleMode = 1     '以twip为单位，绘制精确
    
    '指定按钮之间的距离
    eleWidth = Scale_X * 30
    eleHeight = Scale_Y * 28
    
    index = 0  '初值
    
    '指定控件数组中初始元素的属性，新加载的均采取与之相同的默认值
    '设置按钮（图片框）的背景色
    picChoose(0).BackColor = bkUpRgb
    picChoose(0).Visible = False
    
    '设置按钮边框的颜色和大小
    shpFrame(0).BorderColor = frameRgb
    shpFrame(0).Width = picChoose(0).Width + Scale_X * 2
    shpFrame(0).Height = picChoose(0).Height + Scale_Y * 2
    
    '设置四条边线的初始颜色
    InnerLineTop(index).BorderColor = brightRgb
    InnerLineLeft(index).BorderColor = brightRgb
    OuterLineRight(0).BorderColor = brightRgb
    OuterLineBottom(0).BorderColor = brightRgb
    
    '加载和绘制32个按钮
    For i = 0 To 7
        For j = 0 To 3  '添加8行4列共32个按钮
            index = index + 1
            '加载绘制按钮所需的各项材料
            Load picChoose(index)  '加载label
            Load shpFrame(index)
            Load labChoose(index)  '加载label
            Load InnerLineTop(index)
            Load InnerLineLeft(index)
            Load OuterLineRight(index)
            Load OuterLineBottom(index)
            
            labChoose(index).Caption = index '加载内容
            '计算当前按钮的左上角坐标
            curTop = gTop + i * eleHeight
            curLeft = gLeft + j * eleWidth
            
            '设置按钮位置，绘制按钮
            'step1
            PushButton.SetBasePosition curLeft, curTop
            'step2
            PushButton.AttachObjectToFrame fraYuntai, shpFrame(index), _
                picChoose(index), OuterLineRight(index), OuterLineBottom(index)
            'step3
            PushButton.AttachObjectToPictureBox picChoose(index), _
                labChoose(index), InnerLineTop(index), InnerLineLeft(index)
        Next j
    Next i
End Sub

'**************************************
'功能：绘制程序中所有用到的选择按钮，包括32个云台选择按钮和3个状态按钮
'**************************************
Private Sub DrawPushButton()
    '定义类模块的对象
    Dim PushButton As New clsPushButton
    Dim i As Integer
    
    '绘制云台选择按钮
    DrawChooseButtom Scale_X * 15, Scale_Y * 25
    
    '绘制“自动”、“射灯”和“雨刷”按钮
    'i=33:射灯
    'i=34:雨刷
    'i=35:自动
    For i = 33 To 35
        '加载各种线框
        Load shpFrame(i)
        Load InnerLineTop(i)
        Load InnerLineLeft(i)
        Load OuterLineRight(i)
        Load OuterLineBottom(i)
        '绘制
        shpFrame(i).Width = picChoose(i).Width + Scale_X * 2
        shpFrame(i).Height = picChoose(i).Height + Scale_Y * 2
        '设置按钮的基准位置（左上角坐标）
        PushButton.SetBasePosition picChoose(i).left - Scale_X, _
            picChoose(i).top - Scale_Y
        '捆绑按钮到对应的容器，绘制按钮边框，右边线和下边线
        PushButton.AttachObjectToFrame FraControl, shpFrame(i), _
            picChoose(i), OuterLineRight(i), OuterLineBottom(i)
        '捆绑文本框到图片框，绘制左边线和上边线
        PushButton.AttachObjectToPictureBox picChoose(i), _
            labChoose(i), InnerLineTop(i), InnerLineLeft(i)
    Next i
End Sub

'********************************************
'动作按钮响应鼠标按下事件
'********************************************
Private Sub cmdAct_MouseDown(index As Integer, Button As Integer, Shift As Integer, x As Single, Y As Single)
    '若当前没有云台被选中，则返回
    If curChoose < 1 Or curChoose > 32 Then Exit Sub
    '若当前选中云台正以自动状态旋转，则关闭自动状态，停止旋转
    If ByteStatus(curChoose, 2) = 1 Then
        Call picChoose_Click(35)
    End If
    
    '若云台旋转方向为上、下、左、右之一，则直接发送一条指令，
    '使相应电机旋转即可
    If index < 4 Then
        Call WriteToPort(ByteCodeAct(index), 1)
    '若云台旋转方向为左上、左下、右上、右下之一，则必须同时发送两条指令；
    '如要使云台向左上方旋转，必须同时发送一条向左旋转的指令和向上旋转的指令
    Else
        If index = 4 Or index = 5 Then
            Call WriteToPort(ByteCodeAct(0), 1)
        Else
            Call WriteToPort(ByteCodeAct(1), 1)
        End If
        

        If index = 4 Or index = 6 Then
            Call WriteToPort(ByteCodeAct(2), 1)
        Else
            Call WriteToPort(ByteCodeAct(3), 1)
        End If
    End If
End Sub

'********************************************
'动作按钮响应鼠标抬起事件
'********************************************
Private Sub cmdAct_MouseUp(index As Integer, Button As Integer, Shift As Integer, x As Single, Y As Single)
    Dim i As Integer
    '若当前没有云台被选中，则返回
    If curChoose < 1 Or curChoose > 32 Then Exit Sub
    '发送复位指令，停止方向控制或镜头控制电机旋转
    Call WriteToPort(ByteCodeAct(4), 1)
End Sub

'***********************************************
'调用frmCode窗体
'***********************************************
Private Sub cmdCode_Click()
    '将当前指令集传送给编码对话框
    frmCode.SetInitData ByteCodeChoose, ByteCodeAct, ByteCodeMir, ByteCodeStatus
    frmCode.Show vbModal

    '若在编码对话框，用户点击确定退出，则将编码对话框中
    '新的指令集作为程序指令集
    If frmCode.UserResult = vbOK Then
        frmCode.GetCodeData ByteCodeChoose, ByteCodeAct, ByteCodeMir, ByteCodeStatus
    End If
End Sub

'********************************************
'调用frmConfig窗体，并实现数据的传递
'********************************************
Private Sub cmdConfig_Click()
On Error GoTo ErrProcess:
    frmConfig.SetInitData CBool(bSerial), conSerialPort, IoPort
    frmConfig.Show vbModal
    '若在控制端口对话框中用户点击"确定"退出…
    If frmConfig.UserResult = vbCancel Then
        Exit Sub
    End If
    'change变量确定用户是否改变了通信方式
    Dim change As Boolean
    change = False
    If bSerial <> frmConfig.bSerial Then
        bSerial = frmConfig.bSerial
        change = True
    End If
    '保存新的串口通信参数
    With conSerialPort
        .Parity = frmConfig.conSerialPort.Parity
        .BaudRate = frmConfig.conSerialPort.BaudRate
        .DataBits = frmConfig.conSerialPort.DataBits
        .StopBits = frmConfig.conSerialPort.StopBits
        .PortNr = frmConfig.conSerialPort.PortNr
       '以新的串口参数初始化串口
        If MSComm1.PortOpen = True Then
            MSComm1.PortOpen = False
        End If
        MSComm1.CommPort = .PortNr
        MSComm1.InputMode = comInputModeText
        MSComm1.Settings = CStr(.BaudRate) + "," + Chr(.Parity) + "," + CStr(.DataBits) + "," + CStr(.StopBits)
    End With
    '保存新的IO端口通信参数
    IoPort = frmConfig.txtIO
                        
    '若新的通信方式使用串口:
    If bSerial Then
        '若之前的通信采用IO端口，则终止WinIO库
        If change Then
            ShutdownWinIo
            '开启串口监听
            If MSComm1.PortOpen = False Then
                MSComm1.PortOpen = True
            End If
        End If
    '若新的通信方式使用IO口:
    Else
        '若之前使用串口，则关闭串口，并初始化WinIO库
        If change Then
            If MSComm1.PortOpen = True Then
                MSComm1.PortOpen = False
            End If
            Dim bResult As Boolean
            bResult = InitializeWinIo()
            If bResult <> True Then
                MsgBox ("WINIO库初始化失败")
            End If
        End If
    End If
    Exit Sub
ErrProcess:
    MsgBox "错误提示：" + Err.Description, vbCritical
End Sub

Private Sub cmdMir_MouseDown(index As Integer, Button As Integer, Shift As Integer, x As Single, Y As Single)
    '若当前没有云台被选中，则返回
    If curChoose < 1 Or curChoose > 32 Then Exit Sub
    '发送镜头控制指令
    Call WriteToPort(ByteCodeMir(index), 1)
End Sub

Private Sub cmdMir_MouseUp(index As Integer, Button As Integer, Shift As Integer, x As Single, Y As Single)
    '若当前没有云台被选中，则返回
    If curChoose < 1 Or curChoose > 32 Then Exit Sub
    '发送复位指令，停止方向控制或镜头控制电机旋转
    Call WriteToPort(ByteCodeAct(4), 1)
End Sub

Private Sub cmdOK_Click()
    Unload Me
End Sub