Content Supported by Sourcelens Consulting
Attribute VB_Name = "modQueueSupportHelper"
Option Explicit
'--------------------------------------------------
' Contains HELPER functions useful for message queue access. These functions
' are NOT intended to be called from applications (they don't do anything) that
' useful. They are largely intended to support the main functions
'
' [11/10/97, IvoSa] Created
'--------------------------------------------------
Const LEN_GUID_WITH_BRACKETS = 38
Const LEN_GUID_WITHOUT_BRACKETS = LEN_GUID_WITH_BRACKETS - 2
'------------------------------------------------------------------
'Called when the correct QUEUE GUID was not found in the system registry (either it is missing or incorrect)
' [in] strQueueName : Name of queue we need to look up
' [retval] : GUID of QUEUE
'
' [11/10/97, IvoSa] Created
'------------------------------------------------------------------
Function LookupGUIDAndPersistToRegisty(ByVal strQueueName As String) As String
Dim strQueueGUID As String
'Look for the queue
strQueueGUID = getGUIDOfMessageQueue(strQueueName)
'Do some validity checking on the GUID returned
If (Not (IsGUID(strQueueGUID))) Then
Err.Raise qeBOGUS_GUID, "LookupGUIDAndPersistToRegisty", "Invalid MSMQ ID GUID: " & qeBOGUS_GUID
End If
'Register the GUID w/the queue name
SaveSetting regAPPLICATION_NAME, strQueueName, regKEY_NAME, strQueueGUID
'GUID of QUEUE...
LookupGUIDAndPersistToRegisty = strQueueGUID
End Function
'--------------------------------------------------
'Checks the validity of a 'guid' string
' [in] strQueueGUID : Name of queue we want to open
'
' [11/10/97, IvoSa] Created
'--------------------------------------------------
Function IsGUID(ByVal strQueueGUID As String) As Boolean
strQueueGUID = Trim(strQueueGUID)
Dim lngStrLen As Long
lngStrLen = Len(strQueueGUID)
Select Case lngStrLen
Case LEN_GUID_WITH_BRACKETS
Case LEN_GUID_WITHOUT_BRACKETS
Case Else
IsGUID = False: Exit Function
End Select
'Proably want some additional tests
IsGUID = True
End Function
'--------------------------------------------------
'Display warning to the application user
' [11/10/97, IvoSa] Created
'--------------------------------------------------
Sub Queue_Warning(strWarning As String)
#If Not SUPPRESS_WARNINGS Then
MsgBox strWarning, , "Queue access warning"
#End If
End Sub
'-----------------------------------------------------------
'Makes sure a GUID is in a form w/o {}'s
' [in] strGuid : GUID w/ or w/o {}'s
'
' [11/12/97, IvoSa] Created
'-----------------------------------------------------------
Function getGUIDWithoutBrackets(strGuid As String) As String
Dim lngStrLen As Long
lngStrLen = Len(strGuid)
Select Case lngStrLen
Case LEN_GUID_WITH_BRACKETS
getGUIDWithoutBrackets = Mid(strGuid, 2, LEN_GUID_WITHOUT_BRACKETS)
Case LEN_GUID_WITHOUT_BRACKETS
getGUIDWithoutBrackets = strGuid
Case Else
Err.Raise qeBOGUS_GUID, "getGUIDWithoutBrackets", strGuid & " not a GUID 0 bogus length."
End Select
End Function
'-----------------------------------------------------------
'Makes sure a GUID is in a form w/o {}'s
' [in] strGuid : GUID w/ or w/o {}'s
'
' [11/12/97, IvoSa] Created
'-----------------------------------------------------------
Function getGUIDWithBrackets(strGuid As String) As String
Dim lngStrLen As Long
lngStrLen = Len(strGuid)
Select Case lngStrLen
Case LEN_GUID_WITH_BRACKETS
getGUIDWithBrackets = strGuid
Case LEN_GUID_WITHOUT_BRACKETS
getGUIDWithBrackets = "{" & strGuid & "}"
Case Else
Err.Raise qeBOGUS_GUID, "getGUIDWithBrackets", strGuid & " not a GUID 0 bogus length."
End Select
End Function
'--------------------------------------------------
'Queue information needed to create a queue
'
' [in] strPath : path to queue
' [in] strLabel : label of queue
' [retval] QueueInfo we need to create the object
'
' NOTES: The purpose of this function is to combine the creation/initialtion
' of this object into 1 atomic unit.
'
' [11/12/97, IvoSa] Created
'--------------------------------------------------
Function getQueueInfoForCreation(strPath As String, strLabel As String) As MSMQQueueInfo
Dim objQInfo As MSMQQueueInfo
'UNDONE: Should add code to check if a Queue of this name already exists.
Set objQInfo = New MSMQQueueInfo
objQInfo.PathName = strPath
objQInfo.Label = strLabel
Set getQueueInfoForCreation = objQInfo
End Function
'--------------------------------------------------
'Queue information needed to open a queue by GUID name
'
' [in] strGUIDForQueue : GUID of queue
' [retval] QueueInfo we need to create the object
'
' NOTES: The purpose of this function is to combine the creation/initialtion
' of this object into 1 atomic unit.
'
' [11/12/97, IvoSa] Created
'--------------------------------------------------
Function getQueueInfoForLogon(strGUIDForQueue As String) As MSMQQueueInfo
Dim objQI As MSMQQueueInfo
Set objQI = New MSMQQueueInfo
objQI.FormatName = "PUBLIC=" & getGUIDWithoutBrackets(strGUIDForQueue)
Set getQueueInfoForLogon = objQI
End Function
'--------------------------------------------------
'Queue information needed to delete a queue by Label
'
' [in] strLabelForQueue : Label of queue
' [retval] QueueInfo we need to delete the object
'
' NOTES: The purpose of this function is to combine the creation/initialtion
' of this object into 1 atomic unit.
'
' [11/12/97, IvoSa] Created
'--------------------------------------------------
Function getQueueInfoForDeletion(strLabelForQueue As String) As MSMQQueueInfo
Dim objQuery As MSMQQuery
Set objQuery = New MSMQQuery
Dim objQI As MSMQQueueInfo
Dim objQIs As MSMQQueueInfos
Set objQIs = objQuery.LookupQueue(Label:=strLabelForQueue)
objQIs.Reset
'UNDONE: May want to check if there is more than 1
Set getQueueInfoForDeletion = objQIs.Next
End Function
'--------------------------------------------------
'Returns the GUID that identifies a message queue
' [in] strQueueName : Name of queue we want to open
'
' ASSUMPTION: We are 'hooked up to the net' when this is called (we may hang otherwise)
'
' [11/10/97, IvoSa] Created
'--------------------------------------------------
Function getGUIDOfMessageQueue(ByVal strQueueName As String) As String
Dim objQuery As MSMQQuery
Dim objQInfos As MSMQQueueInfos
Dim objQInfo As MSMQQueueInfo
Dim objQinfoTemp As MSMQQueueInfo
'New query to look for message queues
Set objQuery = New MSMQQuery
'Execute the query, will return a set of queries
Set objQInfos = objQuery.LookupQueue(Label:=strQueueName)
'Go back to the beginning (Is this necessary?)
objQInfos.Reset
'Itterate through all the message queues & look for ours
Dim lngCount As Long
Set objQinfoTemp = objQInfos.Next
While Not (objQinfoTemp Is Nothing)
Set objQInfo = objQinfoTemp
lngCount = lngCount + 1
'Advance to the next item
Set objQinfoTemp = objQInfos.Next
Wend
'Should only have been one queue with out specified ID
If (lngCount > 1) Then
Queue_Warning "Queue count not one (" & CStr(lngCount) & "). More than one queue has the same label, either: 1) the query for the queue should be more specific or 2) all but one of the queues with this label on the enterprise should be deleted. Defaulting to the first queue we found."
End If
getGUIDOfMessageQueue = objQInfo.QueueGuid
End Function