thread.bas

来自「16 relay output channels and 16 isolated」· BAS 代码 · 共 139 行

Attribute VB_Name = "Thread"
Option Explicit

Public HandleofForm1 As Long
Private Const GWL_WNDPROC = -4
Public Const GWL_USERDATA = (-21)
Public Const WM_USER = &H400

' Windows (Constant, Data structure, API) declaration
Public Const CREATE_SUSPENDED = &H4
Public Const THREAD_PRIORITY_NORMAL = &H0
Public Const THREAD_PRIORITY_TIME_CRITICAL = &H15

'WindowProc message
Public Const WM_ADVMSGERR = WM_USER + 1
Public Const WM_ADVMSGUPDATE = WM_USER + 2
Public Const WM_ADVMSGUPDATECOMPDATA = WM_USER + 3

Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Boolean
End Type

Global ThreadHandle As Long

Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare Function TerminateThread Lib "kernel32" (ByVal hThread As Long, ByVal dwExitCode As Long) As Long
Declare Function ResumeThread Lib "kernel32" (ByVal hThread As Long) As Long
Declare Function SetThreadPriority Lib "kernel32" (ByVal hThread As Long, ByVal nPriority As Long) As Long
Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, lpExitCode As Long) As Long
Declare Function CreateThread Lib "kernel32" (ByVal lpThreadAttributes As Long, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Sub ExitProcess Lib "kernel32" (ByVal uExitCode As Long)

Sub EventThread()
    Dim dwEvtCountOver As Long, dwEvtCountUnder As Long
    Dim usEventType As Long
    Dim CompareData() As Long
    Dim ptCounterEventRead As PT_CounterEventRead
    Dim ulSize As Long
    Dim dimensition As Integer
    Dim ulCount As Long
    Dim usOverflow As Integer
    Dim szBuf As String
    
    DRV_DeviceGetProperty m_DriverHandle, CFG_CntrCompareData, Null, ulSize
    dimensition = ulSize / Len(ulSize)
    ReDim CompareData(dimensition)
    
    ptCounterEventRead.counter = m_CurCounter
    ptCounterEventRead.Count = DRV_GetAddress(ulCount)
    ptCounterEventRead.overflow = DRV_GetAddress(usOverflow)
    
    ptCheckEvent.EventType = DRV_GetAddress(usEventType)
    ptCheckEvent.Milliseconds = 1000

    While (m_bContinue)
        m_ErrCde = DRV_CheckEvent(m_DriverHandle, ptCheckEvent)
        If (m_ErrCde = SUCCESS) Then
            If ((usEventType = ADS_EVT_OVERCOMPARE_CNT0 + m_CurCounter) Or (usEventType = ADS_EVT_UNDERCOMPARE_CNT0 + m_CurCounter)) Then
                If (usEventType = ADS_EVT_OVERCOMPARE_CNT0 + m_CurCounter) Then
                    dwEvtCountOver = dwEvtCountOver + 1
                    Form1.txtEvtCountOver.Text = dwEvtCountOver
                End If
                If (usEventType = ADS_EVT_UNDERCOMPARE_CNT0 + m_CurCounter) Then
                    dwEvtCountUnder = dwEvtCountUnder + 1
                    Form1.txtEvtCountUnder.Text = dwEvtCountUnder
                End If
                
                If ((m_CompType = 1) And (m_CompIndex < 7)) Then
                    m_CompIndex = m_CompIndex + 1
                    
                    DRV_DeviceGetProperty m_DriverHandle, CFG_CntrCompareData, CompareData(0), ulSize
                    CompareData(m_CurCounter) = m_CompData(m_CompIndex)
                    DRV_DeviceSetProperty m_DriverHandle, CFG_CntrCompareData, CompareData(0), ulSize
                    SendMessage HandleofForm1, WM_ADVMSGUPDATECOMPDATA, m_CompData(m_CompIndex), 0
                End If
                
            End If
            DRV_CounterEventRead m_DriverHandle, ptCounterEventRead
            SendMessage HandleofForm1, WM_ADVMSGUPDATE, ulCount, 0
        Else
            SendMessage HandleofForm1, WM_ADVMSGERR, m_ErrCde, 0
        End If
    Wend
    
End Sub

Public Function Hook(ByVal hwnd As Long) As Long
    Dim pOld As Long
      pOld = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
      SetWindowLong hwnd, GWL_USERDATA, pOld
      Hook = pOld
End Function

Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, _
      ByVal wParam As Long, ByVal lParam As Long) As Long
    If (m_bContinue = True) Then
        If (uMsg = WM_ADVMSGERR) Then
            ChkErr wParam
        ElseIf (uMsg = WM_ADVMSGUPDATE) Then
            If (wParam < 0) Then
                Form1.txtCntrCount.Text = 4294967296# + wParam
            Else
                Form1.txtCntrCount.Text = wParam
            End If
        ElseIf (uMsg = WM_ADVMSGUPDATECOMPDATA) Then
            If (wParam < 0) Then
                Form1.txtCompData.Text = 4294967296# + wParam
            Else
                Form1.txtCompData.Text = wParam
            End If
        End If
    End If
    Dim lpPrevWndProc As Long
      
    lpPrevWndProc = GetWindowLong(hw, GWL_USERDATA)
    WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
    
End Function

Public Function ChkErr(ByVal lErrCde As Long)
    Dim sErrMsg As String * 128
    Dim Response As Integer

  If (lErrCde <> 0) Then
      DRV_GetErrorMessage lErrCde, sErrMsg
      Response = MsgBox(sErrMsg, vbOKOnly, "Error!!")

  End If
End Function