Option Public
' -----------------------------------------------------------------------------------
' Реализация класса по работе с очередью сообщений
' -----------------------------------------------------------------------------------
' Константы
' -----------------------------------------------------------------------------------
Private Const MQ_MAX_MSGSIZE = &HF0 '(MAXONESEGSIZE - 0x40)
Private Const NOPRIORITY = &HFFFF ' MAXWORD
'Private Const ERR_MQ_POOLFULL = 1024 + 94 '"Insufficient memory - Message Queue pool is full."
'Private Const ERR_MQ_TIMEOUT = 1024 + 95 '"Timeout occurred waiting for message.")
'Private Const ERR_MQSCAN_ABORT = 1024 + 96 'Message Queue scan was aborted.")
Private Const ERR_DUPLICATE_MQ = 1024 + 97 '"Message Queue name already in use.")
'Private Const ERR_NO_SUCH_MQ = 1024 + 98 '"No Message Queue with that name.")
'Private Const ERR_MQ_EXCEEDED_QUOTA = 1024 + 99 '"Message Queue is full.")
Private Const ERR_MQ_EMPTY = 1024 + 100 '"Message Queue is empty.")
'Private Const ERR_MQ_BFR_TOO_SMALL = 1024 + 101 '"Message is larger than the buffer provided.")
Private Const ERR_MQ_QUITTING = 1024 + 102 '"Quit is pending on the Message Queue")
' -----------------------------------------------------------------------------------
' api - функции
' -----------------------------------------------------------------------------------
Declare Function apiMQCreate Lib "nnotes.dll" Alias "MQCreate" (Byval QueueName As String, Byval Quota As Integer, Byval Options As Long) As Integer
Declare Function apiMQOpen Lib "nnotes.dll" Alias "MQOpen" (Byval QueueName As String, Byval Options As Long, RetQueue As Long) As Integer
Declare Function apiMQClose Lib "nnotes.dll" Alias "MQClose" (Byval Queue As Long, Byval Options As Long) As Integer
Declare Function apiMQPut Lib "nnotes.dll" Alias "MQPut" (Byval Queue As Long, Byval Priority As Integer, Byval Buffer As Lmbcs String, Byval Length As Integer, Byval Options As Long) As Integer
Declare Function apiMQGet Lib "nnotes.dll" Alias "MQGet" (Byval Queue As Long, Byval Buffer As Lmbcs String, Byval BufLength As Integer, Byval Options As Long, Byval timeout As Long, retMsgLength As Integer) As Integer
'Private Declare Function apiMQPutQuitMsg Lib "nnotes.dll" Alias "MQPutQuitMsg" (ByVal Queue As Long)
'Private Declare Function apiMQIsQuitPending Lib "nnotes.dll" Alias "MQIsQuitPending" (ByVal Queue As Long) As Integer
Declare Function apiMQGetCount Lib "nnotes.dll" Alias "MQGetCount" (Byval Queue As Long) As Integer'
Declare Function apiOSLoadString Lib "nnotes.dll" Alias "OSLoadString" (Byval hModule As Long, Byval StringCode As Integer, Byval retBuffer As Lmbcs String, Byval BufferLength As Integer) As Integer'NotesMessageQueue
' -----------------------------------------------------------------------------------
' NotesMessageQueue - класс для создания очереди сообщений
' -----------------------------------------------------------------------------------
Public Class NotesMessageQueue
Private hMQ As Long
Private mName As String
Private misOwner As Integer
Private mAutoClose As Integer
Public Property Get QueueName As String 'название очереди
QueueName = mName
End Property
Public Property Get isOwner As Integer 'Флаг что очередб создана этим объектом
isOwner = misOwner
End Property
Public Property Get AutoClose As Integer 'очередь закрывает владелец в деструкторе
AutoClose = mAutoClose
End Property
Public Property Set AutoClose As Integer
mAutoClose = AutoClose
End Property
Public Property Get Messages As Integer 'число сообщений в очереди
If hMQ<>0 Then Messages=apiMQGetCount(hMQ)
End Property
Public Property Get Message As String 'чтение сообщений из очереди
Dim msg As String
Dim ret As Integer
Dim status As Integer
msg = Space(MQ_MAX_MSGSIZE-1) + Chr(0)
apiCall "MQGet:"+mName, apiMQGet(hMQ, msg, MQ_MAX_MSGSIZE, 0, 0, ret)
Message=Left(msg,ret)
End Property
Public Property Set Message As String
If Message<>"" Then apiCall "MQPut:"+mName, apiMQPut(hMQ, NOPRIORITY, Message, Lenb(Message), 0 )
End Property
Sub New(MQName As String)
Dim status As Integer
misOwner=True
mAutoClose=True
mName=Trim( mqName)
If Len(mName)>0 Then
status= apiMQCreate(mName,NOPRIORITY,0)
If status=ERR_DUPLICATE_MQ Then misOwner=False
apiCall "MQOpen", apiMQOpen(mName,0,hMQ)
Else
Error 1024+110,"MessageQueue name is empty string…"
End If
End Sub
Sub Delete
If misOwner And mAutoClose And hMQ<>0 Then Call apiMQClose(hMQ,0)
End Sub
End Class
' -----------------------------------------------------------------------------------
' NotesUIMessageQueue - базовый класс для UI
' -----------------------------------------------------------------------------------
Public Class NotesUIMessageQueue As NotesMessageQueue
Private nTimer As NotesTimer
Private mList List As String
Private mListCount As Integer
Public Property Get Message As String
Dim msg As String
msg=NotesMessageQueue..Message
If msg<>"" Then
mList(Cstr(mListCount))=msg
mListCount=mListCount+1
End If
Message=msg
End Property
Public Property Get MessageList As Variant
MessageList=mList
End Property
Public Property Get MessageListCount As Integer
MessageListCount=mListCount
End Property
' Method for overloading
Public Sub OnMessageAction
Print mName+":", Me.Message
End Sub
Sub New(MQName As String, checkInterval As Integer) , NotesMessageQueue(MQName)
Set nTimer = New NotesTimer(checkInterval)
On Event Alarm From nTimer Call nAlarm
End Sub
Private Sub nAlarm(pTimer As NotesTimer)
pTimer.Enabled=False
If NotesMessageQueue..Messages>0 Then Call Me.OnMessageAction
' While NotesMessageQueue..Messages>0
' mList(Cstr(mListCount))=NotesMessageQueue..Message
' mListCount=mListCount+1
' Wend
pTimer.Enabled=True
End Sub
End Class 'NotesUIMessageQueue
Private Sub apiCall(apiCallName As String, Status As Integer)
' функция обработки ошибок CAPI, содрана и переделана у D. Katz
'This function takes the 16-bit status value (set by returning from most api function calls), and returns the "english" version of the error.
Dim Err_Mask As Integer
Dim errorStr As String
If Status = 0 Then Exit Sub
'Strip the two highest-order bits from status (remember, status is only 16 bits total). Those two bits show location of the error (local or remote server, etc.)
'They should be stripped so that the reference number of the error can be looked up appropriately.
Err_Mask = &H3FFF
Status = Status And Err_Mask
'We need to pass the C function a string it can overwrite (so that the memory for the string is already allocated when the OSLoadString is called)
errorStr =String(255,Clng(0))
Status = apiOSLoadString(0, Status, errorStr, Len(errorStr) - 1)
'Error Status, apiCallName + "::"+errorStr
End Sub 'apiCall
