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