Subscriber: BizTalk.cls

This code sample shows BizTalk subscription:

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

'**********************************************************
'***** ExecuteTutorial
'*****
'***** Purpose:  This component is used to exercise
'*****           the XLANG schedule portion of tutorial accompanying
'*****           BizTalk Server (this is the Module 1 Tutorial).
'*****           The component launches the specified schedule
'*****           file and passes the data file specified
'*****           to it using MSMQ.
'*****
'*****           NOTE: the source code in this component is a direct
'*****           adoption of the code found in the Module 1 
'*****           Tutorial in the BizTalk Server 2000 documentation.
'*****           The default location for the original version of this
'*****           source is found in: C:\Program Files\Microsoft 
'*****           BizTalk Server\Tutorial\Schedule\Solution\
'*****           ExecuteTutorial.vbp
'*****
'***** Inputs:
'*****          Schedule File - Contains the Moniker used to
'*****                          launch the schedule
'*****          Data File - Contains the location of the
'*****                      XML document to be passed to
'*****                      the schedule for processing.
'*****
'***** Outputs:
'*****          Data File - Data file is passed to MSMQ
'*****                      for later retrieval by the schedule.

Private g_MSMTxDisp As MSMQ.MSMQTransactionDispenser
Private g_MSMQQueue As MSMQ.MSMQQueue
Private g_MSMQInfo As MSMQ.MSMQQueueInfo
Private g_CurSkedDir As String
Private g_CurDataDir As String

Private Sub Class_Initialize()
    Set g_MSMQInfo = CreateObject("MSMQ.MSMQQueueInfo")
    Set g_MSMTxDisp = CreateObject("MSMQ.MSMQTransactionDispenser")
End Sub

Public Sub RunSchedule(ByVal strScheduleFile As String, ByVal 
strData As String)
  Dim objfs As New FileSystemObject
  On Error GoTo cmdRunSked_Click_err
  
  'Connect To MSMQ and Remove Any Existing Messages
  PurgeMSMQ "DIRECT=OS:.\private$\ReceivePoReq"
  
 'Send Selected message to MSMQ
  ExecuteMSMQ "DIRECT=OS:.\private$\ReceivePoReq", strData
  
  'Start Schedule which reads message from MSMQ
  ExecuteSchedule strScheduleFile
  
  Exit Sub

cmdRunSked_Click_err:
    MsgBox Err.Description & vbCrLf & "Error: " & Err.Number & " 
(0x" & Hex(Err.Number) & ")", vbCritical, "Error " & Err.Source
    Err.Clear

End Sub

Private Sub PurgeMSMQ(ByVal strQueuePath As String)
    Dim l_MSMQMsg As MSMQMessage
    
    On Error GoTo Err_ConnectMSMQ
    g_MSMQInfo.FormatName = strQueuePath
    Set g_MSMQQueue = g_MSMQInfo.Open(MQ_RECEIVE_ACCESS, MQ_DENY_NONE)
    
    On Error GoTo Err_PurgeMSMQ
    Do
        Set l_MSMQMsg = g_MSMQQueue.Receive(, , , 1)
    Loop While Not l_MSMQMsg Is Nothing
    Exit Sub
    
Err_ConnectMSMQ:
    Err.Raise Err.Number, "Connecting To MSMQ", "Could Not Open the 
MSMQ Queue """ & strQueuePath & """." & vbCrLf & vbCrLf & 
Err.Description

    Exit Sub
Err_PurgeMSMQ:
    Err.Raise Err.Number, "Cleaning MSMQ", "Could Not Remove 
Existing Messages from MSMQ Queue """ & strQueuePath & """." & 
vbCrLf & vbCrLf & Err.Description
    Exit Sub
End Sub

Private Sub ExecuteMSMQ(ByVal strQueuePath As String, DataToQueue 
As  String)
    Dim QueueMsg As New MSMQMessage

    Dim strData As String
    Dim fSend As Boolean
    Dim txt As TextStream
    Dim mybyte() As Byte

    On Error GoTo Err_SendMSMQ
    g_MSMQInfo.FormatName = strQueuePath
    Set g_MSMQQueue = g_MSMQInfo.Open(MQ_SEND_ACCESS, MQ_DENY_NONE)
    mybyte = StrConv(DataToQueue, vbFromUnicode)
    QueueMsg.Body = DataToQueue

    Dim MSMQTx As Object
    Set MSMQTx = g_MSMTxDisp.BeginTransaction
    QueueMsg.Send g_MSMQQueue, MSMQTx
    MSMQTx.Commit
    
    Set QueueMsg = Nothing
    Set MSMQTx = Nothing
    Exit Sub
    
Err_SendMSMQ:
    Err.Raise Err.Number, "Sending Message To MSMQ", "Could Not 
Send Message To MSMQ Queue """ & strQueuePath & """." & vbCrLf & 
vbCrLf & Err.Description
    Exit Sub
End Sub

Private Sub ExecuteSchedule(ByVal strSchedule)
    Dim SendPAQ As Object
    On Error GoTo Err_ExecSched
    
    Set SendPAQ = GetObject(strSchedule)
    If SendPAQ Is Nothing Then
        Err.Raise vbObjectError + 1, , "Invalid Schedule Handle 
Returned."
    End If
    Set SendPAQ = Nothing
    Exit Sub
    
Err_ExecSched:
    Err.Raise Err.Number, "Starting Schedule", "Could Not Launch 
the XLANG Schedule" & vbCrLf & "Please verify the path to the SKX 
file and the path to the data are correct. Also make sure the private 
queues have been created." & vbCrLf & vbCrLf & Err.Description
    Exit Sub
End Sub