用WINSOCK API实现同步非阻塞方式的网络通讯

Option Base 0
Option Explicit

'* ************************************************** *
'* 
模块名称：Winsocket.cls
'*  模块功能：基于API方式的socket同步非阻塞通讯类
'*  编码：lyserver
'* 
联系方式：http://blog.csdn.net/lyserver
'*
************************************************** *

'----------------------------------------------------
' Winsock
API相关声明
'----------------------------------------------------
Private
Const SOCKET_ERROR = -1
Private Const INVALID_SOCKET = -1
Private Const
WSA_WAIT_FAILED = -1
Private Const WAIT_OBJECT_0 = 0
Private Const
WSA_WAIT_EVENT_0 = 0
Private Const WSA_WAIT_TIMEOUT = &H102

Private Const WSAEWOULDBLOCK = 10035
Private Const WSAECONNABORTED =
10053

Public Enum ProtocolConstants
    IPPROTO_TCP = 6
    IPPROTO_UDP =
17
End Enum

Private Const INADDR_ANY = &H0
Private Const INADDR_NONE = -1

Private Const SOCK_STREAM = 1
Private Const SOCK_DGRAM = 2

Private Const AF_INET = 2

Private Const O_NONBLOCK = &H4

Private Const FD_NONE = &H0
Private Const FD_READ = &H1
Private
Const FD_WRITE = &H2
Private Const FD_ACCEPT = &H8
Private Const
FD_CONNECT = &H10
Private Const FD_CLOSE = &H20

Private Type HostEnt
    hName As Long
    hAliases As Long
   
hAddrType As Integer
    hLength As Integer
    hAddrList As Long
End
Type
Private Const MAX_WSADescription = 256
Private Const MAX_WSASYSStatus
= 128
Private Type WSAData
    wVersion As Integer
    wHighVersion As
Integer
    szDescription(MAX_WSADescription - 1) As Byte
   
szSystemStatus(MAX_WSASYSStatus - 1) As Byte
    wMaxSockets As Long
   
wMaxUDPDG As Long
    dwVendorInfo As Long
End Type
Private Type
sockaddr
    sin_family As Integer
    sin_port As Integer
    sin_addr
As Long
    sin_zero(7) As Byte
End Type
Private Const FD_MAX_EVENTS =
10
Private Type WSANETWORKEVENTS
    lNetworkEvents As Long
   
iErrorCode(FD_MAX_EVENTS - 1) As Long
End Type
Private Declare Function
WSAStartup Lib "ws2_32.dll" (ByVal wVersion As Long, lpWSAD As WSAData) As
Long
Private Declare Function WSACleanup Lib "ws2_32.dll" () As
Long
Private Type WSAOVERLAPPED
    Internal As Long
    InternalHigh
As Long
    Offset As Long
    OffsetHigh As Long
    hEvent As
Long
End Type
Private Type WSABUF
    Length As Long
    pszBuf As
Long
End Type
Private Declare Function WSASend Lib "ws2_32.dll" (ByVal s
As Long, ByRef lpBuffers As WSABUF, ByVal dwBufferCount As Long, ByRef
lpNumberOfBytesSent As Long, ByVal dwFlags As Long, lpOverlapped As
WSAOVERLAPPED, ByVal lpCompletionRoutine As Long) As Long
Private Const
WSA_IO_PENDING = 997
Private Declare Function WSARecv Lib "ws2_32.dll" (ByVal
hSocket As Long, ByRef lpBuffers As WSABUF, ByVal dwBufferCount As Long, ByRef
lpNumberOfBytesRecvd As Long, ByRef lpFlags As Long, ByRef lpOverlapped As
WSAOVERLAPPED, ByVal lpCompletionRoutine As Long) As Long
Private Declare
Function WSAGetOverlappedResult Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef
lpOverlapped As WSAOVERLAPPED, ByVal lpcbTransfer As Long, ByVal fWait As Long,
ByRef lpdwFlags As Long) As Long
Private Const FD_SETSIZE = 64
Private
Type fd_set
    fd_count As Long
    fd_array(63) As Long
End
Type
Private Type timeval
    tv_sec As Long
    tv_usec As Long
End
Type
Private Declare Function WSAEventSelect Lib "ws2_32.dll" (ByVal s As
Long, ByVal hEventObject As Long, ByVal lNetworkEvents As Long) As
Long
Private Declare Function WSACreateEvent Lib "ws2_32.dll" () As
Long
Private Declare Function WSAResetEvent Lib "ws2_32.dll" (ByVal hEvent As
Long) As Long
Private Declare Function WSASetEvent Lib "ws2_32.dll" (ByVal
hEvent As Long) As Long
Private Declare Function WSACloseEvent Lib
"ws2_32.dll" (ByVal hEvent As Long) As Long
Private Declare Function
WSAGetLastError Lib "ws2_32" () As Long
Private Declare Function
WSAEnumNetworkEvents Lib "ws2_32.dll" (ByVal s As Long, ByVal hEventOjbect As
Long, lpNetWorkEvents As WSANETWORKEVENTS) As Long
Private Declare Function
WSAWaitForMultipleEvents Lib "ws2_32.dll" (ByVal cEvents As Long, ByRef
lphEvents As Long, ByVal fWaitAll As Boolean, ByVal dwTimeout As Long, ByVal
fAlertable As Boolean) As Long
Private Declare Function WSAIsBlocking Lib
"ws2_32.dll" () As Long
Private Declare Function WSACancelBlockingCall Lib
"ws2_32.dll" () As Long
Private Declare Function socket Lib "ws2_32.dll"
(ByVal af As Long, ByVal s_type As Long, ByVal protocal As Long) As
Long
Private Declare Function selectAPI Lib "ws2_32" Alias "select" (ByVal
nfds As Long, ByVal readfds As Long, ByVal wrITefds As Long, ByVal exceptfds As
Long, timeout As timeval) As Long
Private Declare Function bindAPI Lib
"ws2_32.dll" Alias "bind" (ByVal s As Long, addr As sockaddr, ByVal namelen As
Long) As Long
Private Declare Function listenAPI Lib "ws2_32.dll" Alias
"listen" (ByVal s As Long, ByVal backlog As Long) As Integer
Private Declare
Function acceptAPI Lib "ws2_32.dll" Alias "accept" (ByVal s As Long, ByRef addr
As sockaddr, ByRef namelen As Long) As Long
Private Declare Function
closesocket Lib "ws2_32.dll" (ByVal s As Integer) As Integer
Private Declare
Function connectAPI Lib "ws2_32.dll" Alias "connect" (ByVal s As Long, ByRef
Name As sockaddr, ByVal namelen As Long) As Long
Private Declare Function
recv Lib "ws2_32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal
flags As Long) As Long
Private Declare Function Send Lib "ws2_32.dll" Alias
"send" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal flags As Long)
As Long
Private Declare Function htons Lib "ws2_32.dll" (ByVal hostshort As
Long) As Integer
Private Const TCP_NODELAY = &H1&
Private Const
SO_LINGER = &H80&
Private Type LINGER_STRUCT
    l_onoff As
Integer
    l_linger As Integer
End Type
Private Const SO_MAX_MSG_SIZE
As Long = &H2003
Private Const SOL_SOCKET = 65535
Private Const
SO_SNDBUF = &H1001                 '   Send   buffer   size.
Private
Const SO_RCVBUF = &H1002
Private Const SO_SNDTIMEO =
&H1005
Private Const SO_RCVTIMEO = &H1006
Private Declare Function
setsockopt Lib "ws2_32.dll" (ByVal s As Long, ByVal level As Long, ByVal optname
As Long, optval As Any, ByVal optlen As Long) As Long
Private Declare
Function getsockopt Lib "ws2_32.dll" (ByVal s As Long, ByVal level As Long,
ByVal optname As Long, optval As Any, optlen As Long) As Long
Private Const
FIONBIO = &H8004667E
Private Const FIOASYNC = &H8004667D
Private
Declare Function ioctlsocket Lib "ws2_32.dll" (ByVal s As Long, ByVal cmd As
Long, argp As Long) As Long
Private Declare Function inet_addr Lib
"ws2_32.dll" (ByVal cp As String) As Long
Private Declare Function inet_ntoa
Lib "wsock32.dll" (ByVal addr As Long) As Long
Private Declare Function
gethostname Lib "ws2_32.dll" (ByVal szHost As String, ByVal dwHostLen As Long)
As Long
Private Declare Function gethostbyname Lib "ws2_32.dll" (ByVal
hostname As String) As Long

'----------------------------------------------------
'
ICMP协议API相关声明
'----------------------------------------------------
Private
Type ICMP_ECHO_REPLY
    Address As Long
    Status As Long
   
RoundTripTime As Long
    DataSize As Long
    Reserved As Integer
   
ptrData As Long
    Options(7) As Byte
    Data As String * 250
End
Type
Private Const ICMP_SUCCESS = 0
Private Declare Function
IcmpCreateFile Lib "icmp.dll" () As Long
Private Declare Function
IcmpSendEcho Lib "icmp.dll" (ByVal IcmpHandle As Long, ByVal DestinationAddress
As Long, ByVal RequestData As String, ByVal RequestSize As Long, ByVal
RequestOptions As Long, ReplyBuffer As ICMP_ECHO_REPLY, ByVal ReplySize As Long,
ByVal timeout As Long) As Long
Private Declare Function IcmpCloseHandle Lib
"icmp.dll" (ByVal IcmpHandle As Long) As Long

'----------------------------------------------------
'
辅助API声明
'----------------------------------------------------
Private
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any,
Source As Any, ByVal Length As Long)
Private Const QS_HOTKEY =
&H80
Private Const QS_KEY = &H1
Private Const QS_MOUSEBUTTON =
&H4
Private Const QS_MOUSEMOVE = &H2
Private Const QS_PAINT =
&H20
Private Const QS_POSTMESSAGE = &H8
Private Const
QS_SENDMESSAGE = &H40
Private Const QS_TIMER = &H10
Private Const
QS_ALLINPUT = (QS_SENDMESSAGE Or QS_PAINT Or QS_TIMER Or QS_POSTMESSAGE Or
QS_MOUSEBUTTON Or QS_MOUSEMOVE Or QS_HOTKEY Or QS_KEY)
Private Const QS_MOUSE
= (QS_MOUSEMOVE Or QS_MOUSEBUTTON)
Private Const QS_INPUT = (QS_MOUSE Or
QS_KEY)
Private Const QS_ALLEVENTS = (QS_INPUT Or QS_POSTMESSAGE Or QS_TIMER
Or QS_PAINT Or QS_HOTKEY)
Private Declare Function GetQueueStatus Lib
"user32" (ByVal qsFlags As Long) As Long
Private Declare Function
SafeArrayGetDim Lib "oleaut32.dll" (ByRef saArray() As Any) As Long
Private
Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare
Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal
dwMilliseconds As Long) As Long
Private Declare Sub Sleep Lib "kernel32"
(ByVal dwMilliseconds As Long)

'----------------------------------------------------
'
类错误常量声明
'----------------------------------------------------
Public Enum
skcErrorConstants
    sckInvalidAddress = 1001
    skcConnectTimeout =
1002
    sckSendTimeout = 1003
    sckRecvTimeout = 1004
   
sckDisconnect = 1005
End Enum

'----------------------------------------------------
'
类事件声明
'----------------------------------------------------
Public Event
OnSending(ByVal TotalBytes As Long, ByVal SentBytes As Long, ByRef Cancel As
Boolean)
Public Event OnError(ByVal lngErrorCode As skcErrorConstants, ByVal
strDescription As String)

'----------------------------------------------------
'
类属性变量声明
'----------------------------------------------------
Dim
m_lngProtocol As ProtocolConstants

'----------------------------------------------------
'
用户自定义模块变量
'----------------------------------------------------
Dim
m_blnCancel As Boolean '是否中止标志
Dim m_blnBusy As Boolean '套接字是否处于Busy状态
Dim
m_blnInitial As Boolean 'Winsock函数库初始化标志
Dim m_hSocket As Long '套接字句柄
Dim
m_hEvent As Long '套接字事件监听对象句柄
Dim m_lngEvents As Long '套接字事件代码
Dim
SEND_BUFFER_SIZE As Long '套接字发送缓冲区大小
Dim RECV_BUFFER_SIZE As Long
'套接字接收缓冲区大小

'----------------------------------------------------
'
函数功能：类初始化
'----------------------------------------------------
Private
Sub Class_Initialize()
    Dim WSAD As WSAData
    Dim lngVersionRequested
As Long
   
    '初始化SOCKET函数库
    lngVersionRequested =
&H202
    WSAStartup lngVersionRequested, WSAD
    m_blnInitial =
(WSAD.wVersion = lngVersionRequested)
   
    '初始化默认通讯协议
   
m_lngProtocol = IPPROTO_TCP
   
    '设置套接字默认值
    m_hSocket =
INVALID_SOCKET
End Sub

'----------------------------------------------------
'
函数功能：类被销毁
'----------------------------------------------------
Private
Sub Class_Terminate()
    Disconnect
    WSACleanup
End Sub

'----------------------------------------------------
'
属性功能：获得和设置通讯协议
'
参数说明：无
'----------------------------------------------------
Public
Property Get Protocol() As ProtocolConstants
    Protocol =
m_lngProtocol
End Property
Public Property Let Protocol(ByVal New_Value As
ProtocolConstants)
    m_lngProtocol = New_Value
End Property

'----------------------------------------------------
'
属性功能：获得和设置发送缓冲区大小
'
参数说明：无
'----------------------------------------------------
Public
Property Get SendBufferSize() As Long
    SendBufferSize =
SEND_BUFFER_SIZE
End Property
Public Property Let SendBufferSize(ByVal
New_Value As Long)
    If New_Value < 512 Or New_Value > 65536 Then
Exit Property
   
    SEND_BUFFER_SIZE = New_Value
    setsockopt
m_hSocket, SOL_SOCKET, SO_SNDBUF, SEND_BUFFER_SIZE, Len(SEND_BUFFER_SIZE)
End
Property

'----------------------------------------------------
'
属性功能：获得和设置接收缓冲区大小
'
参数说明：无
'----------------------------------------------------
Public
Property Get RecvBufferSize() As Long
    RecvBufferSize =
RECV_BUFFER_SIZE
End Property
Public Property Let RecvBufferSize(ByVal
New_Value As Long)
    If New_Value < 512 Or New_Value > 65536 Then
Exit Property
   
    RECV_BUFFER_SIZE = New_Value
    setsockopt
m_hSocket, SOL_SOCKET, SO_RCVBUF, RECV_BUFFER_SIZE, Len(RECV_BUFFER_SIZE)
End
Property

'----------------------------------------------------
'
函数功能：建立网络连接(仅用于客户端)
' 参数说明：strRemoteHost服务器IP或域名，intRemotePort服务器端口
' 返 回
值：返回数据接收套接字索引，-1为失败
'----------------------------------------------------
Public
Function Connect(ByVal strRemoteHost As String, ByVal intRemotePort As Integer)
As Boolean
    Dim s_addr As sockaddr
   
    If Not m_blnInitial Then
Exit Function '如果未成功初始化Winsock库则退出
    If m_hSocket <> INVALID_SOCKET
Or m_blnBusy Then Exit Function '如果套接字已创建或处于Busy状态则退出
    If
Len(strRemoteHost) = 0 Then Exit Function '如果没有指定远程服务器地址则退出
   
   
'填充s_addr
    s_addr.sin_family = AF_INET
    s_addr.sin_addr =
DomainToIp(strRemoteHost)
    If s_addr.sin_addr = INADDR_NONE Then
'如果地址错误，则抛出错误事件并退出连接
        RaiseEvent OnError(sckInvalidAddress,
"非法的IP地址或通讯端口!")
        Exit Function
    End If
    s_addr.sin_port =
htons(intRemotePort)
   
    '创建套接字
    m_blnBusy = True
   
m_hSocket = socket(AF_INET, SOCK_STREAM, m_lngProtocol)
   
   
'创建事件监听对象，并绑定到套接字上
    m_hEvent = WSACreateEvent()
    WSAEventSelect
m_hSocket, m_hEvent, FD_CONNECT Or FD_READ Or FD_WRITE Or FD_CLOSE
   

    connectAPI m_hSocket, s_addr, Len(s_addr)
   
    If
CheckStatus(FD_CONNECT) Then '如果连接成功
        getsockopt m_hSocket,
SOL_SOCKET, SO_SNDBUF, SEND_BUFFER_SIZE, Len(SEND_BUFFER_SIZE)
'获得发送缓冲区大小
        getsockopt m_hSocket, SOL_SOCKET, SO_RCVBUF,
RECV_BUFFER_SIZE, Len(RECV_BUFFER_SIZE) '获得接收缓冲区大小
        Connect = True
'设置连接成功标志
    Else
        RaiseEvent OnError(skcConnectTimeout,
"网络连接超时!")
        Disconnect
    End If
    m_blnBusy = False
End
Function

'----------------------------------------------------
' 函数功能：断开网络连接。
'
参数说明：无
' 返 回
值：True成功断开，False失败
'----------------------------------------------------
Public
Function Disconnect() As Boolean
    If m_hSocket <> INVALID_SOCKET And
(Not m_blnBusy) Then
        m_lngEvents = 0
        m_blnCancel =
False
        WSAEventSelect m_hSocket, 0, 0
        closesocket m_hSocket
'关闭连接
        WSACloseEvent m_hEvent '关闭监听对象
        m_hSocket =
INVALID_SOCKET '设置套接字默认值
        Disconnect = True
    End If
End
Function

'----------------------------------------------------
' 函数功能：读取接收到的数据
'
参数说明：varData数据接收缓冲区，可为字节串或字节数组
' 返 回
值：True表示成功，False表示失败
'----------------------------------------------------
Public
Function GetData(ByRef varData As Variant, Optional ByVal lngTimeout As Long =
10000) As Boolean
    Dim i As Long
    Dim lngRet As Long
    Dim
bytData() As Byte
   
    If m_hSocket = INVALID_SOCKET Or m_blnBusy Then
Exit Function '如果套接字无效或处于忙状态则退出
   
    '读取数据
    If Not
CheckStatus(FD_READ, lngTimeout) Then Exit Function '如果套接字不可读则退出循环
   

    ReDim bytData(RECV_BUFFER_SIZE - 1) '初始化接收缓冲区
    lngRet =
recv(m_hSocket, bytData(0), RECV_BUFFER_SIZE, 0) '读取数据
    If lngRet > 0
Then
        ReDim Preserve bytData(lngRet - 1)
        If
VarType(varData) = vbString Then
            varData = StrConv(bytData,
vbUnicode)
        Else
            varData = bytData
        End
If
        GetData = True
    Else
        Erase bytData
    End
If
End Function

'----------------------------------------------------
' 函数功能：发送数据。
'
参数说明：Data需要发送的数据，可为字符串或字节数组
' 返 回
值：True表示成功，False表示失败
'----------------------------------------------------
Public
Function SendData(ByRef varData As Variant, Optional ByVal lngTimeout As Long =
10000) As Boolean
    Dim bytData() As Byte
    Dim lngRet As Long
   
Dim lngDataSize As Long
    Dim lngBlockSize As Long
    Dim i As
Long
   
    If m_hSocket = INVALID_SOCKET Or m_blnBusy Then Exit
Function '如果套接字无效或处于忙状态则退出
   
    '将需要发送的数据转换为字节数组
    Select Case
VarType(varData)
        Case vbString
            bytData =
StrConv(varData, vbFromUnicode)
        Case (vbByte Or
vbArray)
            bytData = varData
        Case Else
           
Exit Function
    End Select
      
    '数据为空时无需发送
    If
SafeArrayGetDim(bytData) = 0 Then Exit Function
   
    m_blnBusy =
True

'数据分块发送
    lngDataSize = UBound(bytData) + 1 '需要发送的数据总数量
    For i
= 0 To lngDataSize - 1 Step SEND_BUFFER_SIZE
        '如果用户中断发送则退出
       
If m_blnCancel Then Exit For
        '计算分块后待发数据的数量
        lngBlockSize =
lngDataSize - i
        If lngBlockSize > SEND_BUFFER_SIZE Then
lngBlockSize = SEND_BUFFER_SIZE
        '检查网络是否可写
        CheckStatus
FD_WRITE, 60000
        '如果用户中断发送则退出
        If m_blnCancel Then Exit
For

'发送数据
        lngRet = Send(m_hSocket, bytData(i), lngBlockSize,
0)
       
        If lngRet = SOCKET_ERROR Then '出错重发
            If
WSAGetLastError() = WSAEWOULDBLOCK Then
                If Not
CheckStatus(FD_WRITE, 60000) Then Exit For '套接字不可写则退出数据发送
               
lngRet = Send(m_hSocket, bytData(i), lngBlockSize, 0) '发送数据
            End
If
        ElseIf lngRet = lngBlockSize Then '数据发送成功
           
RaiseEvent OnSending(lngDataSize, i + lngBlockSize, m_blnCancel)
'抛出数据发送事件
            If lngBlockSize = lngDataSize - i
Then
                m_lngEvents = (m_lngEvents Or
FD_WRITE)
                Exit For
            End If
        Else
'数据发送失败
            Debug.Print WSAIsBlocking()
            RaiseEvent
OnError(sckSendTimeout, "数据发送超时!")
            Exit Function
        End
If
        If GetQueueStatus(QS_MOUSE Or QS_KEY Or QS_PAINT) Then DoEvents
'转让控制权
    Next
    SendData = ((lngRet = lngBlockSize) And (m_blnCancel =
False))
    m_blnCancel = False '重置中止状态
    m_blnBusy = False
'设置状态为空闲
End Function

'----------------------------------------------------
' 函数功能：中止网络操作
'
参数说明：无
' 返 回
值：无
'----------------------------------------------------
Public Sub
Cancel()
    m_blnCancel = True '设置中止状态
End
Sub
'----------------------------------------------------
'
函数功能：辅助函数，将或名转换为IP
' 参数说明：strHost服务器名称或IP地址，如果为空表示本地计算机。
' 返 回
值：32位的IP值，如果域名有多个IP，只返回第一个
'----------------------------------------------------
Private
Function DomainToIp(Optional ByVal strHost As String) As Long
    Dim
lpHostent As Long, lpIpList As Long, lngIp As Long
    Dim udtHostent As
HostEnt
   
    If Not m_blnInitial Then Exit Function
'如果未成功初始化Winsock库则退出
    lngIp = INADDR_NONE
    strHost =
Trim(strHost)
    If Len(strHost) = 0 Then
        strHost = String(100,
vbNullChar)
        gethostname strHost, Len(strHost) '获得本地计算机名称
       
strHost = Left(strHost, InStr(strHost, vbNullChar) - 1)
    Else
       
lngIp = inet_addr(strHost)
        If lngIp <> INADDR_NONE Then
'strHost参数值为IP地址
            DomainToIp = lngIp
            Exit
Function
        End If
    End If
    lpHostent =
gethostbyname(strHost & vbNullChar) '根据域名获得IP
    If lpHostent <> 0
Then
        CopyMemory udtHostent, ByVal lpHostent,
LenB(udtHostent)
        CopyMemory lpIpList, ByVal udtHostent.hAddrList,
4
        CopyMemory lngIp, ByVal lpIpList, 4 '当域名有多个IP地址时，只取第一个IP
       
DomainToIp = lngIp
    End If
End Function

'----------------------------------------------------
'
函数功能：辅助函数，检查套接字指定的状态是否准备就绪
' 参数说明：lMask需检测的状态掩码，lngTimeout超时(单位为毫秒)
' 返 回
值：True表示就绪，False表示未就绪
'----------------------------------------------------
Private
Function CheckStatus(ByRef lMask As Long, Optional ByRef lngTimeout As Long =
10000) As Boolean
    Dim lngRet As Long
    Dim lngStartTime As
Long
    Dim udtEvent As WSANETWORKEVENTS
   
    If (m_lngEvents And
lMask) = 0 Then
        lngStartTime = GetTickCount()
       
Do
            lngRet = WSAWaitForMultipleEvents(1, m_hEvent, False, 100,
False)
            If lngRet = 0 Then
                WSAEnumNetworkEvents
m_hSocket, m_hEvent, udtEvent
                m_lngEvents = (m_lngEvents Or
udtEvent.lNetworkEvents)
                Exit Do
            End
If
            DoEvents '转让控制权
        Loop Until m_blnCancel Or
GetTickCount() - lngStartTime > lngTimeout
    End If
   
   
m_blnCancel = False '重置中止状态
   
    If (m_lngEvents And lMask) = lMask
Then
        m_lngEvents = (m_lngEvents Xor lMask)
        CheckStatus =
True
    End If
End Function