Projects

Winpopup Plus

November 23, 2002 by Java

Browsing cMailBox.cls (7.24 KB)

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cMailBox"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

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

Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const GENERIC_EXECUTE = &H20000000
Private Const GENERIC_ALL = &H10000000
Private Const INVALID_HANDLE_VALUE = -1
Private Const MAILSLOT_WAIT_FOREVER = -1
Private Const OPEN_EXISTING = 3

Private Declare Function CloseHandle Lib "kernel32" (ByVal hHandle As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwAccess As Long, ByVal dwShare As Long, ByVal lpSecurityAttrib As Long, ByVal dwCreationDisp As Long, ByVal dwAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CreateMailslot Lib "kernel32" Alias "CreateMailslotA" (ByVal lpName As String, ByVal nMaxMessageSize As Long, ByVal lReadTimeout As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
Private Declare Function GetMailslotInfo Lib "kernel32" (ByVal hMailslot As Long, lpMaxMessageSize As Long, lpNextSize As Long, lpMessageCount As Long, lpReadTimeout As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Any) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFileName As Long, ByVal lpBuff As Any, ByVal nNrBytesToWrite As Long, lpNrOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long

Dim MailBoxHandle As Long

Dim MsgTextCollection As New Collection
Dim MsgRecipientCollection As New Collection
Dim MsgSenderCollection As New Collection
Dim MsgTimeDateCollection As New Collection
Dim MsgStateArray() As Integer

Public Property Get MessageState(Index As Long) As Integer
    MessageState = MsgStateArray(Index)
End Property

Public Property Get MessageTimeDate(Index As Long) As String
    MsgStateArray(Index) = 0
    MessageTimeDate = MsgTimeDateCollection(Index)
End Property

Public Property Get MessageRecipient(Index As Long) As String
    MsgStateArray(Index) = 0
    MessageRecipient = MsgRecipientCollection(Index)
End Property

Public Sub ClearMessage(Index As Long)
Dim i As Long
    MsgTextCollection.Remove Index
    MsgSenderCollection.Remove Index
    MsgRecipientCollection.Remove Index
    MsgTimeDateCollection.Remove Index
    For i = Index + 1 To UBound(MsgStateArray)
        MsgStateArray(i - 1) = MsgStateArray(i)
    Next i
    ReDim Preserve MsgStateArray(UBound(MsgStateArray) - 1)
End Sub


Public Property Get MessageSender(Index As Long) As String
    MsgStateArray(Index) = 0
    MessageSender = MsgSenderCollection(Index)
End Property

Public Sub CloseMailBox()
    CloseHandle MailBoxHandle
End Sub


Public Property Get Count() As Long
    Count = MsgTextCollection.Count
End Property

Public Function GetNewMessages() As Long
Dim NextSize As Long
Dim MsgCount As Long
Dim Buffer() As Byte
Dim ReadSize As Long
Dim i As Long
Dim MsgBlock As Integer
Dim MsgBuffer As String
Dim TempsWaiting As Long
TempsWaiting = MAILSLOT_WAIT_FOREVER

    GetMailslotInfo MailBoxHandle, 10, NextSize, MsgCount, MAILSLOT_WAIT_FOREVER
    If MsgCount <> 0 Then
        ReDim Buffer(NextSize)
        ReadFile MailBoxHandle, Buffer(1), NextSize, ReadSize, ByVal 0&
        MsgBlock = 1
        For i = 1 To UBound(Buffer)
            If Buffer(i) <> 0 Then
                MsgBuffer = MsgBuffer & Chr(Buffer(i))
            Else
                Select Case MsgBlock
                    Case 1
                        MsgSenderCollection.Add MsgBuffer
                        MsgBlock = 2
                    Case 2
                        MsgRecipientCollection.Add MsgBuffer
                        MsgBlock = 3
                    Case 3
                        MsgTextCollection.Add MsgBuffer
                End Select
                MsgBuffer = ""
            End If
        Next i
        MsgTimeDateCollection.Add Str(Date) + " " + Str(Time)
        ReDim Preserve MsgStateArray(UBound(MsgStateArray) + 1)
        MsgStateArray(UBound(MsgStateArray)) = 1
        If MsgSenderCollection.Count > 1 And _
            MsgRecipientCollection.Count > 1 And _
            MsgTextCollection.Count > 1 Then
            If (MsgSenderCollection(MsgSenderCollection.Count) = MsgSenderCollection(MsgSenderCollection.Count - 1) And _
            MsgRecipientCollection(MsgRecipientCollection.Count) = MsgRecipientCollection(MsgRecipientCollection.Count - 1) And _
            MsgTextCollection(MsgTextCollection.Count) = MsgTextCollection(MsgTextCollection.Count - 1)) Then
                MsgSenderCollection.Remove MsgSenderCollection.Count
                MsgRecipientCollection.Remove MsgRecipientCollection.Count
                MsgTextCollection.Remove MsgTextCollection.Count
                MsgTimeDateCollection.Remove MsgTimeDateCollection.Count
                ReDim Preserve MsgStateArray(UBound(MsgStateArray) - 1)
                MsgCount = MsgCount - 1
            End If
        End If
    End If
    GetNewMessages = MsgCount
End Function

Public Function InitMailBox() As Boolean
Dim SA As SECURITY_ATTRIBUTES
    SA.nLength = Len(SA)
    SA.bInheritHandle = False
    MailBoxHandle = CreateMailslot("\\.\mailslot\messngr", 0&, MAILSLOT_WAIT_FOREVER, SA)
    ReDim MsgStateArray(0)
    If MailBoxHandle = INVALID_HANDLE_VALUE Then
        InitMailBox = False
    Else
        InitMailBox = True
    End If
End Function


Public Property Get MessageText(Index As Long) As String
    MsgStateArray(Index) = 0
    MessageText = MsgTextCollection(Index)
End Property

Public Sub SendNewMessage(Sender As String, Recipient As String, Message As String, Optional ByVal RecipientAlias As String)
Dim FileHandle As Long
Dim MsgBuffer As String
Dim BytesWritten As Long
Dim MailSlot As String
    If RecipientAlias = "" Then RecipientAlias = Recipient
    MailSlot = "\\" + Recipient + "\mailslot\messngr"
    MsgBuffer = Sender + Chr(0) + RecipientAlias + Chr(0) + Message + Chr(0)
    FileHandle = CreateFile(MailSlot, GENERIC_WRITE, FILE_SHARE_READ, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, -1)
    WriteFile FileHandle, MsgBuffer, Len(MsgBuffer), BytesWritten, 0
    CloseHandle FileHandle
End Sub

Public Sub SendMessageSpike(Recipient As String)
Dim FileHandle As Long
Dim MsgBuffer As String
Dim BytesWritten As Long
Dim MailSlot As String
    MailSlot = "\\" + Recipient + "\mailslot\messngr"
    MsgBuffer = " " + Chr(0)
    FileHandle = CreateFile(MailSlot, GENERIC_WRITE, FILE_SHARE_READ, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, -1)
    WriteFile FileHandle, MsgBuffer, Len(MsgBuffer), BytesWritten, 0
    CloseHandle FileHandle
End Sub

Download cMailBox.cls

Back to file list

---

Back to project page