Cocus class

Option Explicit

Private Type COMSTAT
        fCtsHold As Long
        fDsrHold As Long
        fRlsdHold As Long
        fXoffHold As Long
        fXoffSent As Long
        fEof As Long
        fTxim As Long
        fReserved As Long
        cbInQue As Long
        cbOutQue As Long
End Type

Private Type COMMTIMEOUTS
        ReadIntervalTimeout As Long
        ReadTotalTimeoutMultiplier As Long
        ReadTotalTimeoutConstant As Long
        WriteTotalTimeoutMultiplier As Long
        WriteTotalTimeoutConstant As Long
End Type

Private Type DCB
        DCBlength As Long
        BaudRate As Long
        fBinary As Long
        fParity As Long
        fOutxCtsFlow As Long
        fOutxDsrFlow As Long
        fDtrControl As Long
        fDsrSensitivity As Long
        fTXContinueOnXoff As Long
        fOutX As Long
        fInX As Long
        fErrorChar As Long
        fNull As Long
        fRtsControl As Long
        fAbortOnError As Long
        fDummy2 As Long
        wReserved As Integer
        XonLim As Integer
        XoffLim As Integer
        ByteSize As Byte
        Parity As Byte
        StopBits As Byte
        XonChar As Byte
        XoffChar As Byte
        ErrorChar As Byte
        EofChar As Byte
        EvtChar As Byte
End Type

Private Type OVERLAPPED
        Internal As Long
        InternalHigh As Long
        offset As Long
        OffsetHigh As Long
        hEvent As Long
End Type

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

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Long) As Long
Private Declare Function SetCommTimeouts Lib "kernel32" (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As Long
Private Declare Function GetCommTimeouts Lib "kernel32" (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As Long
Private Declare Function BuildCommDCB Lib "kernel32" Alias "BuildCommDCBA" (ByVal lpDef As String, lpDCB As DCB) As Long
Private Declare Function SetCommState Lib "kernel32" (ByVal hCommDev As Long, lpDCB As DCB) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function FlushFileBuffers Lib "kernel32" (ByVal hFile As Long) As Long

Private Declare Sub RtlMoveMemory Lib "kernel32" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As Long) As Long
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long

Private c_strComSettings As String
Private c_lngComPort As Long
Private c_lngHandle As Long
Private c_lngTimerDelay As Long
Private c_blnTimerRunning As Boolean
Private c_lMem As Long
Private c_lvThunk() As Long
Private c_lhWnd As Long

Public Event DataReceived(ByVal strData As String)


Public Property Let ComPort(ByVal lngNewComPort As Long)
    If Not (c_lngHandle = -1) Then
        Call KillCom
        c_lngComPort = lngNewComPort
        Call InitCom
    Else
        c_lngComPort = lngNewComPort
    End If
End Property

Public Property Get ComPort() As Long
    ComPort = c_lngComPort
End Property

Public Property Let ComSettings(ByVal strNewComSettings As String)
    If Not (c_lngHandle = -1) Then
        Call KillCom
        c_strComSettings = LCase$(strNewComSettings)
        Call InitCom
    Else
        c_strComSettings = LCase$(strNewComSettings)
    End If
End Property

Public Property Get ComSettings() As String
    ComSettings = c_strComSettings
End Property

Public Property Let TimerDelay(ByVal lngNewTimerDelay As Long)
    If Not (c_lngHandle = -1) Then
        If c_blnTimerRunning Then
            Call StopTimer
            c_lngTimerDelay = lngNewTimerDelay
            Call StartTimer
        Else
            c_lngTimerDelay = lngNewTimerDelay
        End If
    Else
        c_lngTimerDelay = lngNewTimerDelay
    End If
End Property

Public Property Get TimerDelay() As Long
    TimerDelay = c_lngTimerDelay
End Property

Public Property Let TimerEnabled(ByVal blnNewTimerEnabled As Boolean)
    If Not (c_lngHandle = -1) Then
        If c_blnTimerRunning And Not (blnNewTimerEnabled) Then
            Call StopTimer
        ElseIf Not (c_blnTimerRunning) And blnNewTimerEnabled Then
            Call StartTimer
        End If
    End If
End Property

Public Property Get TimerEnabled() As Boolean
    TimerEnabled = c_blnTimerRunning
End Property


Public Function InitCom() As Boolean
    Dim strCom As String
    Dim coTimeouts As COMMTIMEOUTS
    Dim dcbCom As DCB

    strCom = "COM" & CStr(c_lngComPort) & ":"

    c_lngHandle = CreateFile(strCom, &HC0000000, 0, 0&, &H3, 0, 0)

    If c_lngHandle = -1 Then
        Exit Function
    End If

    With coTimeouts
        .ReadIntervalTimeout = 20
        .ReadTotalTimeoutConstant = 1
        .ReadTotalTimeoutMultiplier = 1
        .WriteTotalTimeoutConstant = 10
        .WriteTotalTimeoutMultiplier = 1
    End With

    If SetCommTimeouts(c_lngHandle, coTimeouts) = -1 Then
        Call CloseHandle(c_lngHandle)
        Exit Function
    End If

    If BuildCommDCB(c_strComSettings, dcbCom) = -1 Then
        Call CloseHandle(c_lngHandle)
        Exit Function
    End If

    If SetCommState(c_lngHandle, dcbCom) = -1 Then
        Call CloseHandle(c_lngHandle)
        Exit Function
    End If

    Me.TimerEnabled = True
    InitCom = True
End Function

Public Function KillCom() As Boolean
    If Not (c_lngHandle = -1) Then
        Call CloseHandle(c_lngHandle)
        If c_blnTimerRunning Then
            Call StopTimer
        End If
        c_lngHandle = -1
        KillCom = True
    End If
End Function

Public Function ReadCom() As String
    Dim bvRead() As Byte
    Dim lngBytesReaded As Long

    If Not (c_lngHandle = -1) Then
        ReDim bvRead(255)

        Call ReadFile(c_lngHandle, bvRead(0), 255, lngBytesReaded, ByVal 0)

        If lngBytesReaded > 0 Then
            ReDim Preserve bvRead(lngBytesReaded - 1)
            ReadCom = StrConv(bvRead, vbUnicode)

            Call FlushFileBuffers(c_lngHandle)
        End If
    End If
End Function

Public Function WriteCom(ByVal strWrite As String) As Boolean
    Dim bvWrite() As Byte
    Dim strWriteTemp As String
    Dim lngBytesTotal As Long
    Dim lngBytesWrited As Long
    Dim lngBytesTotalWrited As Long

    If Not (c_lngHandle = -1) Then
        lngBytesTotal = Len(strWrite)
        Do
            If Len(strWrite) > 255 Then
                strWriteTemp = Left$(strWrite, 255)
                strWrite = Mid$(strWrite, 255)
            Else
                strWriteTemp = strWrite
                strWrite = ""
            End If

            ReDim bvWrite(Len(strWriteTemp) - 1)
            bvWrite = StrConv(strWriteTemp & vbNullChar, vbFromUnicode)

            Call WriteFile(c_lngHandle, bvWrite(0), Len(strWriteTemp), lngBytesWrited, ByVal 0)

            lngBytesTotalWrited = lngBytesTotalWrited + lngBytesWrited

            If Len(strWrite) = 0 Then Exit Do
        Loop

        WriteCom = (lngBytesTotalWrited = lngBytesTotal)
    End If
End Function

Private Sub Class_Initialize()
    c_strComSettings = "9600,n,8,1"
    c_lngComPort = 1
    c_lngHandle = -1
    c_lngTimerDelay = 1000

    c_lhWnd = CreateWindowEx(0, "static", vbNullString, _
       0, 0, 0, 0, 0, 0, 0, App.hInstance, 0)
End Sub

Private Sub Class_Terminate()
    If Not (c_lngHandle = -1) Then
        Call KillCom
    End If

    Call StopTimer
    Call VirtualFree(c_lMem, 0, &H8000&)
    Call DestroyWindow(c_lhWnd)
End Sub

Private Function StartTimer() As Boolean
    Call StopTimer
    StartTimer = Not (SetTimer(c_lhWnd, ObjPtr(Me), c_lngTimerDelay, Timer_AddressOf) = 0)
    c_blnTimerRunning = StartTimer
End Function

Private Function StopTimer() As Boolean
    StopTimer = Not (KillTimer(c_lhWnd, ObjPtr(Me)) = 0)
    c_blnTimerRunning = Not StopTimer
End Function

Private Function Timer_AddressOf() As Long
    Dim nAddr       As Long
    Dim nThunkNo    As Long

    nAddr = zAddressOf
    If c_lMem = 0 Then
        ReDim c_lvThunk(0 To 21) As Long
        c_lMem = VirtualAlloc(c_lMem, 88, &H1000&, &H40&)
    End If
    If c_lvThunk(0) = 0 Then
        c_lvThunk(3) = GetProcAddress(GetModuleHandleA("kernel32"), "IsBadCodePtr")
        c_lvThunk(4) = &HBB60E089
        c_lvThunk(5) = VarPtr(c_lvThunk(0))
        c_lvThunk(6) = &H73FFC589: c_lvThunk(7) = &HC53FF04: c_lvThunk(8) = &H7B831F75: c_lvThunk(9) = &H20750008: c_lvThunk(10) = &HE883E889: c_lvThunk(11) = &HB9905004: c_lvThunk(13) = &H74FF06E3: c_lvThunk(14) = &HFAE2008D: c_lvThunk(15) = &H53FF33FF: c_lvThunk(16) = &HC2906104: c_lvThunk(18) = &H830853FF: c_lvThunk(19) = &HD87401F8: c_lvThunk(20) = &H4589C031: c_lvThunk(21) = &HEAEBFC
    End If
    c_lvThunk(0) = ObjPtr(Me)
    c_lvThunk(1) = nAddr
    c_lvThunk(2) = GetProcAddress(GetModuleHandleA("vba6"), "EbMode")
    c_lvThunk(12) = 4
    c_lvThunk(17) = 16
    nAddr = c_lMem + (0 * 88)
    RtlMoveMemory nAddr, VarPtr(c_lvThunk(0)), 88
    Timer_AddressOf = nAddr + 16
End Function

Private Function zAddressOf() As Long
    Dim bSub  As Byte
    Dim bVal  As Byte
    Dim nAddr As Long
    Dim i     As Long
    Dim J     As Long

    RtlMoveMemory VarPtr(nAddr), ObjPtr(Me), 4
    If zProbe(nAddr + &H1C, i, bSub) Then
        i = i + 4: J = i + 1024
        Do While i < J
            RtlMoveMemory VarPtr(nAddr), i, 4
            If IsBadCodePtr(nAddr) Then
                RtlMoveMemory VarPtr(zAddressOf), i - (1 * 4), 4
                Exit Do
            End If
            RtlMoveMemory VarPtr(bVal), nAddr, 1
            If bVal <> bSub Then
                RtlMoveMemory VarPtr(zAddressOf), i - (1 * 4), 4
                Exit Do
            End If
            i = i + 4
        Loop
    End If
End Function

Private Function zProbe(ByVal nStart As Long, ByRef nMethod As Long, ByRef bSub As Byte) As Boolean
    Dim bVal    As Byte
    Dim nAddr   As Long
    Dim nLimit  As Long
    Dim nEntry  As Long

    nAddr = nStart
    nLimit = nAddr + 32
    Do While nAddr < nLimit
        RtlMoveMemory VarPtr(nEntry), nAddr, 4
        If nEntry <> 0 Then
            RtlMoveMemory VarPtr(bVal), nEntry, 1
            If bVal = &H33 Or bVal = &HE9 Then
                nMethod = nAddr:    bSub = bVal
                zProbe = True:      Exit Function
            End If
        End If
        nAddr = nAddr + 4
    Loop
End Function

Private Function TimerProc(ByVal lv1 As Long, ByVal lv2 As Long, ByVal lv3 As Long, ByVal lv4 As Long) As Long
    Dim strRead As String

    strRead = ReadCom
    If Len(strRead) > 0 Then
        RaiseEvent DataReceived(strRead)
    End If
End Function