Const HTTPTType_File = 1

Const ADMIN_PROTOCOL_TYPE_FILE = 1
Const HTTP = 3

Const RECVSVC_NAMESPACE = "MicrosoftBizTalkServer_ReceiveFunction"
Const SERVER_NAMESPACE = "MicrosoftBizTalkServer_SERVER"

Const wbemChangeFlagCreateOnly = 2

Dim strServerName, strGroupName
Dim g_objService, l_bAdminUtilInitialized
Dim sPath, BT
Dim org, doc, env, port, chan, dl

Function GetEnvVar(strName)

    On Error Resume Next

    Dim wshShell, wshSysEnv

    Set wshShell = WScript.CreateObject ("WScript.Shell")
    Set wshSysEnv = wshShell.Environment("PROCESS")

    GetEnvVar = wshSysEnv(strName)

End Function

Function InitAdminUtil()
    If (l_bAdminUtilInitialized = 1) Then  Exit Function

    Set g_objLocator = CreateObject("WbemScripting.SWbemLocator")
    Set g_objService = g_objLocator.ConnectServer(".", _
            "rootMicrosoftBiztalkServer")
    l_bAdminUtilInitialized = 1
End Function

Function CleanupAdminUtil()
    If (l_bAdminUtilInitialized = 0) Then  Exit Function

    Set g_objService = Nothing
    Set g_objLocator = Nothing

    l_bAdminUtilInitialized = 0	
End Function

Function GetServerByName(inServerName)
    Set GetServerByName = Nothing
    Set GetServerByName = g_objService.Get(SERVER_NAMESPACE & ".NAME=""" & _
        inServerName & """")
End Function

Function GetBTSGroupName(strServer)
    Dim objServer, bOnTheFly

    If (l_bAdminUtilInitialized = 0) Then
        InitAdminUtil
        bOnTheFly = True
    End If

    Set objServer = GetServerByName(strServer)
    GetBTSGroupName = objServer.GroupName

    Set objServer = Nothing

    If (bOnTheFly) Then
        CleanupAdminUtil
    End If
End Function

Sub CreateVirtualDirectory(directoryName, _
            directoryPath)
    On Error Resume Next
    Dim webObj
    Dim root
    Dim virtualDir

    Set webObj = GetObject("IIS://localhost/w3svc/1")
    Set root = webObj.GetObject("IIsWebVirtualDir", "Root")

    'If virtual directory exist, then delete it.

    Call root.Delete("IIsWebVirtualDir", directoryName)

    Err.Clear

    Set virtualDir = root.Create("IIsWebVirtualDir", _
            directoryName)
    virtualDir.AccessRead = True
    virtualDir.AccessWrite = True
    virtualDir.AccessExecute = True
    virtualDir.AccessScript = True
    virtualDir.Path = directoryPath
    virtualDir.AppIsolated = 0
    virtualDir.EnableDirBrowsing = True
    virtualDir.SetInfo
    Err.Clear
    Set webObj = Nothing
End Sub

Sub CreateWebApplication(directoryName)
    On Error Resume Next
    Dim webObj
    Dim INPROC
    Dim OUTPROC

    Const POOLED = 2

    INPROC = True
    OUTPROC = False

    Set webObj = GetObject("IIS://localhost/w3svc/1/ROOT/" & directoryName)
    'Create an application out-of-process.
    webObj.AppCreate OUTPROC
    Set webObj = Nothing

End Sub

Public Sub SetIsolation(directoryName)
    On Error Resume Next
    Dim webObj
    Dim virtualDir

    Set webObj = GetObject("IIS://localhost/w3svc/1/Root/" & directoryName)
    webObj.AppIsolated = 0
    webObj.SetInfo
    Set webObj = Nothing
End Sub

Function CreateReceiveFunction(strRecvSvcName, _
            strGroupName, _
            strProcessingServer, _
            strFileMask, _
            fProtocolType, _
            strPollingLoc, _
            strPassword, _
            strUsername, _
            strDocumentName, _
            strSourceID, _
            strSourceQualifier, _
            strDestinationID, _
            strDestinationQualifier, _
            lOpenness, _
            lPassthrough, _
            strChannelName, _
            fDisabled, _
            strEnvelopeName, _
            strPreProcessor, _
            fHttpTransportType, _
            strTransportURL, _
            bReturnToken, _
            strReturnContentType)


    Dim objBTSRecvSvc 'As SWbemObject
    Dim objBTSRecvSvcInstance 'As SWbemObject

    On Error Resume Next
    CreateReceiveFunction = True
    Set g_objLocator = CreateObject ("WbemScripting.SWbemLocator")
    Set g_objService = g_objLocator.ConnectServer(".", _
           "rootMicrosoftBiztalkServer")
    Set objBTSRecvSvc = g_objService.Get(RECVSVC_NAMESPACE)
    Set objBTSRecvSvcInstance = objBTSRecvSvc.SpawnInstance_
    objBTSRecvSvcInstance.Name = strRecvSvcName
    objBTSRecvSvcInstance.groupName = strGroupName
    objBTSRecvSvcInstance.FilenameMask = strFileMask
    objBTSRecvSvcInstance.ProcessingServer = strProcessingServer
    objBTSRecvSvcInstance.ProtocolType = fProtocolType
    objBTSRecvSvcInstance.PollingLocation = strPollingLoc
    objBTSRecvSvcInstance.password = strPassword
    objBTSRecvSvcInstance.UserName = strUsername
    objBTSRecvSvcInstance.DocumentName = strDocumentName
    objBTSRecvSvcInstance.SourceID = strSourceID
    objBTSRecvSvcInstance.SourceQualifier = strSourceQualifier
    objBTSRecvSvcInstance.DestinationID = strDestinationID
    objBTSRecvSvcInstance.DestinationQualifier = strDestinationQualifier
    objBTSRecvSvcInstance.envelopeName = strEnvelopeName
    objBTSRecvSvcInstance.DisableReceiveFunction = fDisabled
    objBTSRecvSvcInstance.PreProcessor = strPreProcessor
    If fProtocolType = http Then
        objBTSRecvSvcInstance.HttpReturnCorrelationToken = bReturnToken
        objBTSRecvSvcInstance.HttpReturnContentType = strReturnContentType
        objBTSRecvSvcInstance.HttpTransportType = fHttpTransportType
        objBTSRecvSvcInstance.TransportURL = strTransportURL
    End If
    If lOpenness <> 0 Then
        objBTSRecvSvcInstance.OpennessFlag = lOpenness
    End If

    If lPassthrough <> 0 Then
        objBTSRecvSvcInstance.IsPassThrough = lPassthrough
    End If

    If strChannelName <> "" Then
       objBTSRecvSvcInstance.channelName = strChannelName
    End If

    objBTSRecvSvcInstance.Put_ (wbemChangeFlagCreateOnly)
    If err <> 0 Then
        CreateReceiveFunction = False
    End If
End Function

Function CreateCustomCounter(strName, _
            strDescription, _
            strCaption, _            strSrcOrgName, _
            strSrcOrgQualifier, _
            strSrcOrgQualifierValue, _
            strDestOrgName, _
            strDestOrgQualifier, _
            strDestOrgQualifierValue, _
            strDocType, _
            intInterval, _
            inGroupName, _
            strSettingID)

    Set CCFact = GetObject("Winmgmts:{impersonationlevel=impersonate}"& _
            "!root/MicrosoftBizTalkServer").Get("MSBTS_CustomCounterSetting")
    Set CustCountSetting = CCFact.SpawnInstance_

    CreateCustomCounter = True

    CustCountSetting.Name = strName
    CustCountSetting.Description = strDescription
    CustCountSetting.Caption = strCaption
    CustCountSetting.SrcOrgName = strSrcOrgName
    CustCountSetting.DestOrgName = strDestOrgName
    CustCountSetting.DocType = strDocType
    CustCountSetting.TimeInterval = intInterval ' In seconds
    CustCountSetting.GroupName = inGroupName
    CustCountSetting.SettingID = strSettingID

    If ("" = CustCountSetting.GroupName) Then
        Exit Function
    End If

    Set objObjectPath = CustCountSetting.Put_(wbemChangeFlagCreateOnly)

    If (IsEmpty(objObjectPath)) Then
        CreateCustomCounter = False
    End If
End Function
Function GetAliasID(ByVal strOrgName, _
            ByVal strAliasName, _
            ByVal strAliasQual, _
            strAliasValue)

Dim config, Organization, RS

    On Error Resume Next

    Set config = CreateObject("BizTalk.BizTalkConfig")
    Set Organization = config.CreateOrganization

    Call Organization.LoadByName(strOrgName)

    Set RS = Organization.Aliases

    While Not RS.EOF
        If RS("Name") = strAliasName And RS("qualifier") = strAliasQual And _
            RS("value") = strAliasValue Then
            GetAliasID = RS("id")
        End If
        RS.MoveNext
    Wend

    Set Organization = Nothing
    Set config = Nothing

End Function

Sub CreateBizTalkConfig()

'Create BizTalk Configuration
Set BT = CreateObject("BizTalk.BizTalkConfig")

' Create Orgs

Set org = BT.CreateOrganization

org.clear
org.name = "Dest_Org"
Org110001 = org.Create
Alias120001 = GetAliasID ("Dest_Org", "Organization", "OrganizationName", _
    "Dest_Org")


org.clear
org.name = "Source_Org"
Org110002 = org.Create
Alias120002 = GetAliasID ("Source_Org", "Organization", "OrganizationName", _
    "Source_Org")

Set org = nothing

' Create Docs

set doc = BT.CreateDocument

doc.clear
doc.name = "Common_PO"
Set doc.PropertySet = CreateObject("Commerce.Dictionary")
doc.reference = "http://"&strServerName& _
    "/biztalkserverrepository/docspecs/Microsoft/CommonPO.xml"
Doc140001 = doc.create

doc.clear
doc.name = "Common_Invoice"
Set doc.PropertySet = CreateObject("Commerce.Dictionary")
doc.reference = "http://"&strServerName& _
    "/biztalkserverrepository/docspecs/Microsoft/CommonInvoice.xml"
Doc140002 = doc.create

Set doc = nothing

' Create Ports

set port = BT.CreatePort

port.clear
port.name = "Port_To_Org_1"
port.DestinationEndpoint.Alias = Alias120001
port.DestinationEndpoint.Application = App0
port.DestinationEndpoint.Openness = 1
port.DestinationEndpoint.Organization = Org110001
port.EncodingType = 1
port.PrimaryTransport.Address = "file://C:Port_To_Org_1-%tracking_id%.xml"
port.PrimaryTransport.Parameter = ""
port.PrimaryTransport.Type = 256
port.SecondaryTransport.Address = ""
port.SecondaryTransport.Parameter = ""
port.SecondaryTransport.Type = 1
Port160001 = port.create

port.clear
port.name = "Port_To_Org_2"
port.DestinationEndpoint.Alias = Alias120002
port.DestinationEndpoint.Application = App0
port.DestinationEndpoint.Openness = 1
port.DestinationEndpoint.Organization = Org110002
port.EncodingType = 1
port.PrimaryTransport.Address = "file://C:Port_To_Org_2-%tracking_id%.edi"
port.PrimaryTransport.Parameter = ""
port.PrimaryTransport.Type = 256
port.SecondaryTransport.Address = ""
port.SecondaryTransport.Parameter = ""
port.SecondaryTransport.Type = 1
Port160002 = port.create

set port = nothing

' Create Channels

set chan = BT.CreateChannel

chan.clear
chan.Name = "Channel_From_Org_1"
chan.InputDocument = Doc140001
chan.IsReceiptChannel = False
chan.LoggingInfo.LogNativeInputDocument = True
chan.LoggingInfo.LogNativeOutputDocument = False
chan.LoggingInfo.LogXMLInputDocument = True
chan.LoggingInfo.LogXMLOutputDocument = False
chan.OutputDocument = Doc140001
chan.port = Port160001
chan.ReceiptChannel = Chan0
chan.RetryCount = 3
chan.RetryInterval = 5
chan.SourceEndpoint.Alias = Alias120001
chan.SourceEndpoint.Openness = 1
chan.SourceEndpoint.Organization = Org110001
Chan180001 = chan.Create

chan.clear
chan.Name = "Channel_From_Org_2"
chan.InputDocument = Doc140002
chan.IsReceiptChannel = False
chan.LoggingInfo.LogNativeInputDocument = True
chan.LoggingInfo.LogNativeOutputDocument = False
chan.LoggingInfo.LogXMLInputDocument = False
chan.LoggingInfo.LogXMLOutputDocument = False
chan.OutputDocument = Doc140002
chan.port = Port160002
chan.ReceiptChannel = Chan0
chan.RetryCount = 3
chan.RetryInterval = 5
chan.SourceEndpoint.Alias = Alias120002
chan.SourceEndpoint.Openness = 1
chan.SourceEndpoint.Organization = Org110002
Chan180002 = chan.Create

set chan = nothing

Set BT = nothing

End Sub

'Get variable values
strServerName = GetEnvVar("COMPUTERNAME")
strGroupName = GetBTSGroupName(strServerName)
sPath = GetEnvVar("ProgramFiles")  & "Microsoft BizTalk ServerHTTP Receive"

'Create Virtual Directory
Call CreateVirtualDirectory("BizTalk_Virtual_Directory", sPath)
Call CreateWebApplication("BizTalk_Virtual_Directory")
Call SetIsolation("BizTalk_Virtual_Directory")

'Create Receive Functions
Call CreateReceiveFunction("Receive_Function_1", strGroupName, strServerName, _
     "*.edi", ADMIN_PROTOCOL_TYPE_FILE, "C:", "", "",  "",  "", "", "", "", _
     0, 0, "Channel_From_Org_1", false, "", "", "", "", "", "")
Call CreateReceiveFunction("Receive_Function_2", strGroupName, strServerName, _
     "*.x12", ADMIN_PROTOCOL_TYPE_FILE, "C:", "", "", "",  "", "", "", "", 0, _
     0, "Channel_From_Org_2", false, "", "", "", "", "", "")
Call CreateReceiveFunction("HTTP_Receive_File", strGroupName, strServerName, _
     "*.*", HTTP, "/BizTalk_Virtual_Directory/BizTalkHTTPReceive.dll?file1", _
     "", "", "", "", "", "", "", 0, 0, "", false, "", "", HTTPTType_File, _
     "\Sample\%guid%.xml", True, "")

'Create Custom Counter
Call CreateCustomCounter("Custom_Counter", "Description", "Caption", _
     "Source Org", "", "", "Dest Org", "", "", "Testing", 10000, strGroupName, _
     "SettingID")

Set g_objService = nothing

'Create BizTalk Configuration
Call CreateBizTalkConfig

MsgBox "Done"