yuntai.frm

云台控制源代码

   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
'#######################################################################
'程序由迎风飘扬编写,供大家参考.有什么意见可以在我的qq:5488700上给我留言.
'#######################################################################





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

'*****************************************
'功能：确定是第一次运行本程序以及相关文件是否存在
'*****************************************
Private Sub FileTest()
    Dim IsInstalled As Boolean
    Dim IsExist As Boolean
    Dim file As New clsFile
    Dim strMsg As String
    
    '检测相关文件是否存在
    IsExist = file.IsFileExist(App.Path + "\" + "WinIo.sys")
    If Not IsExist Then
        MsgBox "找不到文件WinIo.sys，请确定与本应用程序在同一目录下！", vbCritical
        End
    End If
    IsExist = file.IsFileExist(App.Path + "\" + "WinIo.dll")
    If Not IsExist Then
        MsgBox "找不到文件WinIo.dll，请确定与本应用程序在同一目录下！", vbCritical
        End
    End If
    IsExist = file.IsFileExist(App.Path + "\" + "WinIo.vxd")
    If Not IsExist Then
        MsgBox "找不到文件WinIo.vxd，请确定与本应用程序在同一目录下！", vbCritical
        End
    End If
    
    Dim st As String
    st = GetSetting("Yuntai", "Settings", "IsInstalled")