frmstart.frm

来自「16 relay output channels and 16 isolated」· FRM 代码 · 共 552 行 · 第 1/2 页

  ' Add selectable items of Thermocouple type
  lstThermocouple.AddItem "J type"            ' 0
  lstThermocouple.AddItem "K type"            ' 1
  lstThermocouple.AddItem "S type"            ' 2
  lstThermocouple.AddItem "T type"            ' 3
  lstThermocouple.AddItem "B type"            ' 4
  lstThermocouple.AddItem "R type"            ' 5
  lstThermocouple.AddItem "E type"            ' 6

  ' Set the default selection of thermocouple type
  lstThermocouple.ListIndex = 0

  ' Since no display on screen, you'd better to disable the following function
  labModule.Enabled = False
  lstModule.Enabled = False
  labChannel.Enabled = False
  lstChannel.Enabled = False
  labVoltageRange.Enabled = False
  lstVoltageRange.Enabled = False
  labExpChl.Enabled = False
  lstExpChl.Enabled = False
  labThermocouple.Enabled = False
  lstThermocouple.Enabled = False
  cmdRun.Enabled = False
End Sub

Private Sub lstChannel_Click()

     labExpChl.Enabled = False
     lstExpChl.Enabled = False
     lstExpChl.Clear
     ' Add Expansion card channel
        If (lpAIGetConfig.Daughter(lstChannel.ListIndex).dwBoardID > 0) Then
            For I = 0 To (lpAIGetConfig.Daughter(lstChannel.ListIndex).usNum - 1)
                tempStr = "Chan#" + Str(I)
                lstExpChl.AddItem tempStr
            Next I
            lstExpChl.Text = lstExpChl.List(0)
            labExpChl.Enabled = True
            lstExpChl.Enabled = True
        End If
        
    If (BurnOutSupport = True) Then
      cmbBTEnable.ListIndex = BurnOutProperty(lstChannel.ListIndex)
    End If
    
End Sub

Private Sub lstDevice_Click()
  Dim I, ii As Integer
  Dim tempNum As Integer
  Dim TestRes As Boolean
  Dim nOutEntries As Integer
  Dim lpSubDeviceList As Long
  Dim dwDeviceNum As Long
  Dim Length As Long
    

  lstModule.Clear
  lstChannel.Clear
  lstVoltageRange.Clear
  lstExpChl.Clear

  ' Avoid to open Advantech Demo Card
  TestRes = TestStr(lstDevice.Text, "DEMO")
  If (TestRes) Then
    labModule.Enabled = False
    lstModule.Enabled = False
    labChannel.Enabled = False
    lstChannel.Enabled = False
    labVoltageRange.Enabled = False
    lstVoltageRange.Enabled = False
    labExpChl.Enabled = False
    lstExpChl.Enabled = False
    labThermocouple.Enabled = False
    lstThermocouple.Enabled = False
    cmdRun.Enabled = False
    lstChannel.AddItem "No Use"
  End If

  If (Not TestRes) Then
    ' Check if there is any device attatched on this COM port or CAN
    gnNumOfSubdevices = devicelist(lstDevice.ListIndex).nNumOfSubdevices
    If (gnNumOfSubdevices > MaxDev) Then
      gnNumOfSubdevices = MaxDev
    End If

    ' retrieve the information of all installed devices
    If (gnNumOfSubdevices <> 0) Then
      dwDeviceNum = devicelist(lstDevice.ListIndex).dwDeviceNum
      lpSubDeviceList = DRV_GetAddress(SubDevicelist(0))
      ErrCde = DRV_DeviceGetSubList(dwDeviceNum, lpSubDeviceList, gnNumOfSubdevices, nOutEntries)
      If (ErrCde <> 0) Then
        DRV_GetErrorMessage ErrCde, szErrMsg
        Response = MsgBox(szErrMsg, vbOKOnly, "Error!!")
        Exit Sub
      End If
      For I = 0 To (gnNumOfSubdevices - 1)
        tempStr = ""
        For ii = 0 To MaxDevNameLen
            tempStr = tempStr + Chr(SubDevicelist(I).szDeviceName(ii))
        Next ii
        lstModule.AddItem tempStr
      Next I
      lstModule.Enabled = True
      labModule.Enabled = True
   End If

    ' Open PCL card device
    If (gnNumOfSubdevices = 0) Then
        dwDeviceNum = devicelist(lstDevice.ListIndex).dwDeviceNum
        ErrCde = DRV_DeviceOpen(dwDeviceNum, DeviceHandle)
        If (ErrCde <> 0) Then
            DRV_GetErrorMessage ErrCde, szErrMsg
            Response = MsgBox(szErrMsg, vbOKOnly, "Error!!")
            Exit Sub
        Else
            bRun = True
        End If

        ptDevGetFeatures.buffer = DRV_GetAddress(lpDevFeatures)
        ErrCde = DRV_DeviceGetFeatures(DeviceHandle, ptDevGetFeatures)
        If (ErrCde <> 0) Then
            DRV_GetErrorMessage ErrCde, szErrMsg
            Response = MsgBox(szErrMsg, vbOKOnly, "Error!!")
            Exit Sub
        End If

        ptAIGetConfig.buffer = DRV_GetAddress(lpAIGetConfig)
        ErrCde = DRV_AIGetConfig(DeviceHandle, ptAIGetConfig)
        If (ErrCde <> 0) Then
            DRV_GetErrorMessage ErrCde, szErrMsg
            Response = MsgBox(szErrMsg, vbOKOnly, "Error!!")
            Exit Sub
        End If
        
        
        ' Add thermo channel item
        If (lpDevFeatures.usMaxAISiglChl > lpDevFeatures.usMaxAIDiffChl) Then
           tempNum = lpDevFeatures.usMaxAISiglChl
        Else
           tempNum = lpDevFeatures.usMaxAIDiffChl
        End If
        
        For I = 0 To (tempNum - 1)
            tempStr = "Chan#" + Str(I)
            lstChannel.AddItem tempStr, I
        Next I
        lstChannel.Text = lstChannel.List(0)

        For I = 0 To (lpDevFeatures.usNumGain - 1)
            tempStr = ""
            For ii = 0 To 15
                tempStr = tempStr + Chr(lpDevFeatures.glGainList(I).szGainStr(ii))
            Next ii
            lstVoltageRange.AddItem tempStr
        Next I
        lstVoltageRange.Text = lstVoltageRange.List(0)


          
        ' Support Burn Test?
        
        ' Please refer the software manual for the return value when burn out occurs.
        ' Here is for USB-4718, 0: Disable, 1: 888888, 2: -888888, 3: Maximum value, 4: Minimum value
        cmbBTEnable.Clear
        cmbBTEnable.AddItem ("Disable")
        cmbBTEnable.AddItem ("888888")
        cmbBTEnable.AddItem ("-888888")
        cmbBTEnable.AddItem ("Maximum value")
        cmbBTEnable.AddItem ("Minimum value")
        
        Length = 4 * MaxAIChl
        ErrCde = DRV_DeviceGetProperty(DeviceHandle, CFG_BURNTEST, BurnOutProperty(0), Length)
        If (ErrCde = InvalidInputParam) Then
           ErrCde = DRV_DeviceGetProperty(DeviceHandle, CFG_BURNTEST, BurnOutProperty(0), Length)
        End If
        
        If (ErrCde = FunctionNotSupported) Then
            cmbBTEnable.Enabled = False
            BurnOutSupport = False
        ElseIf ErrCde = 0 Then
        
            cmbBTEnable.Enabled = True
                        
            cmbBTEnable.ListIndex = BurnOutProperty(lstChannel.ListIndex)
            BurnOutSupport = True
            
        Else
            DRV_GetErrorMessage ErrCde, szErrMsg
            Response = MsgBox(szErrMsg, vbOKOnly, "Error!!")
            Exit Sub
        End If

        'Since you have selected a PC-Lab Card, you can choose the channel and gain code as you want
        labChannel.Enabled = True
        lstChannel.Enabled = True
        lstVoltageRange.Enabled = True
        labVoltageRange.Enabled = True
        labThermocouple.Enabled = True
        lstThermocouple.Enabled = True
        cmdRun.Enabled = True
    End If
  End If
End Sub


Private Sub lstModule_Click()
    Dim I, ii As Integer
    Dim dwDeviceNum As Long
    Dim tempNum As Integer

    lstChannel.Clear
    lstVoltageRange.Clear
    ' open COM device or CAN device
    dwDeviceNum = SubDevicelist(lstModule.ListIndex).dwDeviceNum
    ErrCde = DRV_DeviceOpen(dwDeviceNum, DeviceHandle)
    If (ErrCde <> 0) Then
       DRV_GetErrorMessage ErrCde, szErrMsg
       Response = MsgBox(szErrMsg, vbOKOnly, "Error!!")
       Exit Sub
    Else
       bRun = True
    End If

    ptDevGetFeatures.buffer = DRV_GetAddress(lpDevFeatures)
    ErrCde = DRV_DeviceGetFeatures(DeviceHandle, ptDevGetFeatures)
    If (ErrCde <> 0) Then
       DRV_GetErrorMessage ErrCde, szErrMsg
       Response = MsgBox(szErrMsg, vbOKOnly, "Error!!")
       Exit Sub
    End If

    ' Add analog input channel item
      tempNum = lpDevFeatures.usMaxAIDiffChl
      If (tempNum > 0) Then
        For I = 0 To (tempNum - 1)
          temp$ = "Chan#" + Str(I)
          lstChannel.AddItem temp$, I
        Next I
        lstChannel.Text = lstChannel.List(0)
        labChannel.Enabled = True
        lstChannel.Enabled = True
      End If

      ' add gain code list
      tempNum = lpDevFeatures.usNumGain
      If (lpDevFeatures.usNumGain > 0) Then
        For I = 0 To (lpDevFeatures.usNumGain - 1)
          tempStr = ""
          For ii = 0 To 15
              tempStr = tempStr + Chr(lpDevFeatures.glGainList(I).szGainStr(ii))
          Next ii
          lstVoltageRange.AddItem tempStr
        Next I
        lstVoltageRange.Text = lstVoltageRange.List(0)
        lstVoltageRange.Enabled = True
        labVoltageRange.Enabled = True
      End If

      labThermocouple.Enabled = True
      lstThermocouple.Enabled = True
      cmdRun.Enabled = True
End Sub

Public Function SHL(OPR As Byte, n As Integer) As Byte
Dim BD As Byte
Dim I As Integer
BD = OPR
For I = 1 To n - 1
BD = (BD And &H7F) * 2 '将D7位屏蔽左移，防止字节溢出
Next I
CF = BD And &H80 '判断D7位是否进位
SHL = (BD And &H7F) * 2
End Function