XCCC: How to Create an HTTP Virtual Directory on an Exchange 2000 Server for a Public Folder

' StrFolderName: The folder path that you want to publish as the virtual directory. Use the following format: "<TreeName>\<SubFolderName>"
' strComputerName: The computer name of your Exchange 2000 server where you set up this virtual directory.
Function CreateWeb(strFolderName as String, strComputerName as String)as Boolean

    Dim iServer         As New CDOEXM.ExchangeServer
    Dim strFHName       As String
    Dim NewWeb          As IADsContainer
    Dim ADCont          As IADsContainer

    Set iServer = CreateObject("CDOEXM.ExchangeServer")

    Result = True

    iServer.DataSource.Open strComputerName
    Set ADCont = GetObject("LDAP://" & iServer.DirectoryServer & "/CN=1,CN=HTTP,CN=Protocols,"_
    & Mid(iServer.DataSource.SourceURL, InStr(1, iServer.DataSource.SourceURL, "cn=")))

    Set NewWeb = ADCont.Create("msExchProtocolCfgHTTPVirtualDirectory", "cn=" & strFolderName)

    NewWeb.Put "hTTPPubGAL", CBool(0)
    NewWeb.Put "anonymousAccount", "IUSR_" & strComputerName
    NewWeb.Put "folderPathname", CStr(strFolderName)  
    ' "msExchAccessFlags" property: contains the virtual directory execute permission:
    '512 = Execute Permission=Script
    '516 = Execute Permission=Script&Execute
    '1=Read, 2=Write, 16=Script Access
    NewWeb.Put "msExchAccessFlags", CInt(535) 
    ' "msExchAuthenticationFlags" property: contains the virtual directory authentication settings:
    '1=Anonymous Access, 2=Basic, 4=NTLM
    NewWeb.Put "msExchAuthenticationFlags", CInt(7) 
    NewWeb.Put "msExchBasicAuthenticationDomain", CStr(strDomainName)
    NewWeb.Put "msExchDefaultLogonDomain", CStr(strDomainName)
    ' "msExchDirBrowseFlags" property: controls the Web directory browse permission of the virtual directory:
    '1073741854=No Dir Browse, -1073741794=Dir Browse
    NewWeb.Put "msExchDirBrowseFlags", -1073741794 

    'The property specifies the logon method for clear text logons 
    NewWeb.Put "msExchLogonMethod", CInt(3) 
    NewWeb.Put "msExchServerAutoStart", CBool(-1) 
    ' "msExchServerRole" property: This virtual directory resides on the front end or back end server:
    ' 1 = This is a front end server 
    ' 0 = This is a back end server
    NewWeb.Put "msExchServerRole", CInt(0)
    NewWeb.Put "name", CStr(strFolderName)
    'newweb.Put "showInAdvancedViewOnly", cbool(-1)

    On Error Resume Next
    Err.Clear
    NewWeb.SetInfo
    If Err <> 0 Then
       ' If user exists no need to raise an err
       If Err.Number <> &H80071392 Then 
          MsgBox CStr(Err.Number) + ") " + Err.Description, , Err.Source
          Result = False
        End If
    End If

    Set NewWeb = Nothing
    Set ADCont = Nothing
    Set iServer = Nothing

    CreateWeb = Result
End Function