459 lines
15 KiB
Plaintext
459 lines
15 KiB
Plaintext
VERSION 5.00
|
|
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
|
|
Begin VB.Form Form1
|
|
Caption = "VBTrans"
|
|
ClientHeight = 2400
|
|
ClientLeft = 60
|
|
ClientTop = 345
|
|
ClientWidth = 9690
|
|
LinkTopic = "Form1"
|
|
ScaleHeight = 2400
|
|
ScaleWidth = 9690
|
|
StartUpPosition = 3 'Windows Default
|
|
Begin ComctlLib.TreeView TreeView1
|
|
Height = 2055
|
|
Left = 5760
|
|
TabIndex = 6
|
|
TabStop = 0 'False
|
|
Top = 120
|
|
Width = 3735
|
|
_ExtentX = 6588
|
|
_ExtentY = 3625
|
|
_Version = 327682
|
|
LabelEdit = 1
|
|
Style = 7
|
|
ImageList = "ImageList1"
|
|
BorderStyle = 1
|
|
Appearance = 1
|
|
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
|
|
Name = "MS Sans Serif"
|
|
Size = 8.25
|
|
Charset = 0
|
|
Weight = 400
|
|
Underline = 0 'False
|
|
Italic = 0 'False
|
|
Strikethrough = 0 'False
|
|
EndProperty
|
|
End
|
|
Begin VB.CommandButton Receive
|
|
Caption = "&Receive"
|
|
Enabled = 0 'False
|
|
Height = 375
|
|
Left = 3000
|
|
TabIndex = 4
|
|
Top = 1800
|
|
Width = 1335
|
|
End
|
|
Begin VB.CommandButton Exit
|
|
Caption = "&Exit"
|
|
Height = 375
|
|
Left = 4560
|
|
TabIndex = 5
|
|
Top = 1800
|
|
Width = 1095
|
|
End
|
|
Begin VB.CommandButton Send
|
|
Caption = "&Send"
|
|
Enabled = 0 'False
|
|
Height = 375
|
|
Left = 3000
|
|
TabIndex = 3
|
|
Top = 1200
|
|
Width = 1335
|
|
End
|
|
Begin VB.CommandButton OpenQ
|
|
Caption = "&Open"
|
|
Height = 375
|
|
Left = 4560
|
|
TabIndex = 1
|
|
Top = 240
|
|
Width = 1095
|
|
End
|
|
Begin VB.TextBox txtNoOfMessages
|
|
Height = 285
|
|
Left = 3000
|
|
TabIndex = 2
|
|
Top = 720
|
|
Width = 615
|
|
End
|
|
Begin VB.TextBox txtQueueName
|
|
Height = 285
|
|
Left = 1680
|
|
TabIndex = 0
|
|
Top = 240
|
|
Width = 2775
|
|
End
|
|
Begin VB.Label lblTransID
|
|
Height = 255
|
|
Left = 120
|
|
TabIndex = 12
|
|
Top = 2160
|
|
Width = 2895
|
|
End
|
|
Begin ComctlLib.ImageList ImageList1
|
|
Left = 5040
|
|
Top = 720
|
|
_ExtentX = 1005
|
|
_ExtentY = 1005
|
|
BackColor = -2147483643
|
|
ImageWidth = 16
|
|
ImageHeight = 16
|
|
MaskColor = 12632256
|
|
_Version = 327682
|
|
BeginProperty Images {0713E8C2-850A-101B-AFC0-4210102A8DA7}
|
|
NumListImages = 3
|
|
BeginProperty ListImage1 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
|
|
Picture = "Form1.frx":0000
|
|
Key = ""
|
|
EndProperty
|
|
BeginProperty ListImage2 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
|
|
Picture = "Form1.frx":01DA
|
|
Key = ""
|
|
EndProperty
|
|
BeginProperty ListImage3 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
|
|
Picture = "Form1.frx":03B4
|
|
Key = ""
|
|
EndProperty
|
|
EndProperty
|
|
End
|
|
Begin VB.Label lblReceiver
|
|
Height = 255
|
|
Left = 120
|
|
TabIndex = 11
|
|
Top = 1800
|
|
Width = 2775
|
|
End
|
|
Begin VB.Line Line1
|
|
X1 = 120
|
|
X2 = 4320
|
|
Y1 = 1680
|
|
Y2 = 1680
|
|
End
|
|
Begin VB.Label lblSender
|
|
Height = 255
|
|
Left = 120
|
|
TabIndex = 10
|
|
Top = 1200
|
|
Width = 2775
|
|
End
|
|
Begin VB.Label Label3
|
|
Caption = "Number of messages in transaction:"
|
|
Height = 255
|
|
Left = 120
|
|
TabIndex = 9
|
|
Top = 720
|
|
Width = 2655
|
|
End
|
|
Begin VB.Label lblDNS
|
|
Height = 495
|
|
Left = 120
|
|
TabIndex = 8
|
|
Top = 120
|
|
Visible = 0 'False
|
|
Width = 5415
|
|
End
|
|
Begin VB.Label Label1
|
|
Caption = "Queue name:"
|
|
Height = 255
|
|
Left = 600
|
|
TabIndex = 7
|
|
Top = 240
|
|
Width = 1095
|
|
End
|
|
End
|
|
Attribute VB_Name = "Form1"
|
|
Attribute VB_GlobalNameSpace = False
|
|
Attribute VB_Creatable = False
|
|
Attribute VB_PredeclaredId = True
|
|
Attribute VB_Exposed = False
|
|
' ------------------------------------------------------------------------
|
|
' Copyright (C) 1999 Microsoft Corporation
|
|
'
|
|
' You have a royalty-free right to use, modify, reproduce and distribute
|
|
' the Sample Application Files (and/or any modified version) in any way
|
|
' you find useful, provided that you agree that Microsoft has no warranty,
|
|
' obligations or liability for any Sample Application Files.
|
|
' ------------------------------------------------------------------------
|
|
'
|
|
|
|
|
|
Option Explicit
|
|
Dim qinfo As MSMQQueueInfo
|
|
Dim qSend As MSMQQueue ' An instance of the queue opened for send access
|
|
Dim qRec As MSMQQueue ' An instance of the queue opened for receive access
|
|
Dim xdispenser As New MSMQTransactionDispenser ' Used for internal transactions
|
|
Dim xact As MSMQTransaction
|
|
Dim dTransCounter As Integer
|
|
|
|
Private Sub Exit_Click()
|
|
'
|
|
' Close the queues.
|
|
'
|
|
If Not qSend Is Nothing Then qSend.Close
|
|
If Not qRec Is Nothing Then qRec.Close
|
|
End
|
|
End Sub
|
|
|
|
Private Sub Form_Load()
|
|
dTransCounter = 0 ' Initiallize the treeview transaction counter
|
|
End Sub
|
|
|
|
Private Sub txtNoOfMessages_Change()
|
|
If txtNoOfMessages = "" Or Left(txtNoOfMessages, 1) = "0" Then
|
|
Send.Enabled = False
|
|
Else
|
|
Send.Enabled = True
|
|
End If
|
|
End Sub
|
|
|
|
Private Sub txtNoOfMessages_KeyPress(KeyAscii As Integer)
|
|
KeyAscii = DigitsOnly(KeyAscii)
|
|
End Sub
|
|
|
|
Private Sub OpenQ_Click()
|
|
Dim lTempPointer As Long
|
|
|
|
Set qinfo = New MSMQQueueInfo
|
|
lTempPointer = MousePointer
|
|
MousePointer = ccHourglass
|
|
OpenQ.Enabled = False
|
|
txtQueueName.Enabled = False
|
|
If IsDsEnabled Then
|
|
'
|
|
' Local computer is DS enabled - queue will be public.
|
|
'
|
|
qinfo.PathName = ".\" & txtQueueName
|
|
Else
|
|
'
|
|
' Local computer is DS disabled - we can only open a private queue.
|
|
'
|
|
qinfo.PathName = ".\PRIVATE$\" & txtQueueName
|
|
End If
|
|
qinfo.Label = "VBTrans"
|
|
|
|
On Error GoTo CreateErrorHandler
|
|
qinfo.Create IsTransactional:=True
|
|
Opening:
|
|
On Error GoTo OpenErrorHandler
|
|
Set qSend = qinfo.Open(MQ_SEND_ACCESS, MQ_DENY_NONE)
|
|
OpenReceiveQ ' Open the queue for receive access as well.
|
|
lblSender = "Queue opened."
|
|
OpenQ.Visible = False
|
|
txtQueueName.Visible = False
|
|
lblDNS.Visible = True
|
|
'
|
|
' Show the DNS pathname of the queue.
|
|
'
|
|
lblDNS = "Queue DNS Pathname: " & qinfo.PathNameDNS
|
|
MousePointer = lTempPointer
|
|
Exit Sub
|
|
|
|
CreateErrorHandler:
|
|
Select Case Err.Number
|
|
Case Is = MQ_ERROR_QUEUE_EXISTS
|
|
' Queue exists so we will check whether it is a transactional queue.
|
|
If qinfo.IsTransactional = False Then
|
|
' It is not transactional, so ask the user to specify another queue name.
|
|
MsgBox "Queue exists and is not transactional." & Chr(13) & _
|
|
"Please enter another queue name.", _
|
|
vbOKOnly + vbInformation, "VBTrans"
|
|
OpenQ.Enabled = True
|
|
txtQueueName.Enabled = True
|
|
txtQueueName = ""
|
|
txtQueueName.SetFocus
|
|
MousePointer = lTempPointer
|
|
Exit Sub
|
|
Else
|
|
'
|
|
' Queue exists so update treeview with its existing transactions.
|
|
'
|
|
UpdateTreeView
|
|
End If
|
|
GoTo Opening
|
|
Case Else
|
|
MsgBox "Error creating queue" + Chr(13) + Chr(13) + _
|
|
"Error: " + Err.Description, , "VBTrans"
|
|
MousePointer = lTempPointer
|
|
OpenQ.Enabled = True
|
|
txtQueueName.Enabled = True
|
|
txtQueueName = ""
|
|
txtQueueName.SetFocus
|
|
End Select
|
|
Exit Sub
|
|
|
|
OpenErrorHandler:
|
|
MsgBox "Error opening queue" + Chr(13) + Chr(13) + _
|
|
"Error: " + Err.Description, , "VBTrans"
|
|
MousePointer = lTempPointer
|
|
End Sub
|
|
|
|
Private Sub Receive_Click()
|
|
Dim i As Integer
|
|
Dim msgRec As MSMQMessage
|
|
Dim str As String
|
|
Dim lTempPointer As Long
|
|
|
|
lTempPointer = MousePointer
|
|
MousePointer = ccHourglass
|
|
str = " was"
|
|
On Error GoTo ErrorHandler
|
|
Set msgRec = qRec.Receive(ReceiveTimeout:=1000)
|
|
|
|
If msgRec Is Nothing Then
|
|
lblReceiver = "There are no messages to receive."
|
|
Receive.Enabled = False
|
|
Else
|
|
'
|
|
' Remove the transaction from the treeview.
|
|
'
|
|
If Not TreeView1.Nodes.Count = 0 Then
|
|
TreeView1.Nodes.Remove 1
|
|
End If
|
|
'
|
|
' Update transaction ID label. The transaction identifier is a 20-byte
|
|
' identifier that includes the computer identifier of the sending machine
|
|
' (first 16 bits) followed by a transaction sequence number (4 bytes).
|
|
' We will display these last 4 only, as decimal numbers. The transaction
|
|
' ID is not guaranteed to be unique, MSMQ guarantees only that subsequent
|
|
' transactions will have different identifiers.
|
|
'
|
|
lblTransID = "Transaction ID: " & ByteArrayToStr(msgRec.TransactionId)
|
|
|
|
i = 1
|
|
While Not msgRec Is Nothing
|
|
'
|
|
' Receive messages until the last in transaction.
|
|
'
|
|
If msgRec.IsLastInTransaction = 1 Then
|
|
If TreeView1.Nodes.Count = 0 Then
|
|
' Queue is empty.
|
|
Receive.Enabled = False
|
|
End If
|
|
lblReceiver = i & " message" & str & " received."
|
|
MousePointer = lTempPointer
|
|
Exit Sub
|
|
End If
|
|
On Error GoTo ErrorHandler
|
|
Set msgRec = qRec.Receive(ReceiveTimeout:=1000)
|
|
str = "s were"
|
|
i = i + 1
|
|
Wend
|
|
End If
|
|
If TreeView1.Nodes.Count = 0 Then
|
|
Receive.Enabled = False
|
|
End If
|
|
MousePointer = lTempPointer
|
|
Exit Sub
|
|
|
|
ErrorHandler:
|
|
If TreeView1.Nodes.Count = 0 Then
|
|
Receive.Enabled = False
|
|
End If
|
|
MousePointer = lTempPointer
|
|
MsgBox "Error receiving messages: " + Err.Description
|
|
End
|
|
End Sub
|
|
|
|
Private Sub Send_Click()
|
|
Dim mSend As New MSMQMessage
|
|
Dim lTempPointer As Long
|
|
Dim i As Integer
|
|
|
|
lTempPointer = MousePointer
|
|
MousePointer = ccHourglass
|
|
Send.Enabled = False
|
|
txtNoOfMessages.Enabled = False
|
|
'
|
|
' Start internal transaction. From this point on, any errors
|
|
' will exit this function prematurely and the transaction will
|
|
' be aborted. Commits only occur if explicitly invoked.
|
|
'
|
|
Set xact = xdispenser.BeginTransaction
|
|
dTransCounter = dTransCounter + 1
|
|
TreeView1.Nodes.Add , , "t" & dTransCounter, "Transaction " & dTransCounter, 1
|
|
For i = 1 To txtNoOfMessages
|
|
mSend.Label = "Transaction " & dTransCounter & " message " & i
|
|
mSend.Body = "VBTrans message"
|
|
mSend.Priority = 3
|
|
mSend.Send qSend, xact
|
|
TreeView1.Nodes.Add "t" & dTransCounter, tvwChild, _
|
|
dTransCounter & "m" & i, mSend.Label, 3
|
|
Next
|
|
|
|
xact.Commit
|
|
|
|
MousePointer = lTempPointer
|
|
txtNoOfMessages.Enabled = True
|
|
Send.Enabled = True
|
|
Receive.Enabled = True
|
|
End Sub
|
|
|
|
Function DigitsOnly(KeyAscii As Integer) As Integer
|
|
If Not KeyAscii = 8 And KeyAscii < Asc("0") Or KeyAscii > Asc("9") Then
|
|
Beep
|
|
DigitsOnly = 0 'cancel the character
|
|
Else
|
|
DigitsOnly = KeyAscii
|
|
End If
|
|
End Function
|
|
Function OpenReceiveQ()
|
|
Dim lTempPointer As Long
|
|
|
|
On Error GoTo OpenErrorHandler
|
|
Set qRec = qinfo.Open(MQ_RECEIVE_ACCESS, MQ_DENY_NONE)
|
|
Exit Function
|
|
|
|
OpenErrorHandler:
|
|
MsgBox "Error opening queue" + Chr(13) + Chr(13) + _
|
|
"Error: " + Err.Description, , "VBTrans"
|
|
End Function
|
|
'
|
|
' Peek all queue messages, add a node in the treeview for each transaction
|
|
' "containing" all of its messages.
|
|
'
|
|
Function UpdateTreeView()
|
|
Dim qPeek As New MSMQQueue
|
|
Dim msgPeek As MSMQMessage
|
|
'Dim tidID As Long 'Transaction ID number
|
|
Dim i As Integer
|
|
|
|
Set msgPeek = New MSMQMessage
|
|
' Open queue for peek access.
|
|
Set qPeek = qinfo.Open(MQ_PEEK_ACCESS, MQ_DENY_NONE)
|
|
qPeek.Reset
|
|
Set msgPeek = qPeek.PeekCurrent(ReceiveTimeout:=0)
|
|
|
|
While Not msgPeek Is Nothing
|
|
If msgPeek.IsFirstInTransaction = 0 Then
|
|
'
|
|
' Message belongs to the same transaction.
|
|
'
|
|
If Not TreeView1.Nodes.Count = 0 Then
|
|
i = i + 1
|
|
TreeView1.Nodes.Add "t" & dTransCounter, tvwChild, _
|
|
dTransCounter & "m" & i, msgPeek.Label, 3
|
|
End If
|
|
Else
|
|
'
|
|
' Message belongs to a new transaction.
|
|
'
|
|
i = 1
|
|
dTransCounter = dTransCounter + 1
|
|
TreeView1.Nodes.Add , , "t" & dTransCounter, _
|
|
"Transaction " & dTransCounter, 1
|
|
TreeView1.Nodes.Add "t" & dTransCounter, tvwChild, _
|
|
dTransCounter & "m" & i, msgPeek.Label, 3
|
|
End If
|
|
On Error GoTo ending
|
|
Set msgPeek = qPeek.PeekNext(ReceiveTimeout:=0)
|
|
Wend
|
|
ending:
|
|
If Not TreeView1.Nodes.Count = 0 Then
|
|
Receive.Enabled = True
|
|
End If
|
|
End Function
|
|
|
|
Function ByteArrayToStr(ID() As Byte) As String
|
|
ByteArrayToStr = ID(19) & "-" & ID(18) & "-" & ID(17) & "-" & ID(16)
|
|
End Function
|