How can i create a public folder with vb?

[Eric]

Hi,

I cant seem to find a code example of how to create a
public folder in VB.
Any help would be great.

Eric

[Tam Viet Pham [MSFT]]

Hi Eric,

Below is creating public folder on Exchange 2000 sample using VB with
CDOEX.DLL and CDOEXM.DLL libraries. I recommend referencing the Exchange
SDK after downloading it from
http://www.microsoft.com/downloads/details.aspx?FamilyId=7BD65D0D-A3A4-41F4-
9868-E643F4A030B1&displaylang=en

Hopefully, with some digging for references, and playing with the server -
you can get this working.

If you exhaust your research and needing help, then please call into
support line and seek soem assistance. Our team will walk you through the
code.

Tam Pham
Microsoft Developer Support - Messaging

This posting is provided "AS IS" with no warranties, and confers no rights.

*** code sample starts here ***

* You'll needs references in your project to:
- CDOEXM
- CDOEX

Sub CreateMailEnabledPF()
'Tasks:
'Get Parent PF
'Create subfolder PF
'Set MailEnabled property of new PF
'use Recipient Update Service (RUS) to flush update to system
'send message to new PF

'Get Parent PF
Dim cdoParentPF As New CDO.Folder
Dim cdoRecip As CDOEXM.IMailRecipient
Dim strURL As String

'URL format: "file://./<server>/<domain>/Public Folders/<folder name>"

'simple approach
'strURL = "file://./myxxx42k/myxxx4w2k.extest.microsoft.com/Public
Folders/Joe
Test1"

'alternate approach to create Folder URL
Dim oSysInfo As ActiveDs.ADSystemInfo
Dim strDomainName As String
Dim strFolderPath As String
Dim strSubFolderName As String

Set oSysInfo = New ActiveDs.ADSystemInfo
strDomainName = oSysInfo.DomainDNSName
strFolderPath = "Public Folders/Testing/JM5" '/Joe McGraw"

'strURL = "file://myxxx4w2k/" & strDomainName & "/" & strFolderPath
strURL = "file://./backofficestorage/" & strDomainName & "/" & strFolderPath

'get PF
cdoParentPF.DataSource.Open strURL, , adModeReadWrite, -1, adOpenSource
'adfailifnotexists
Debug.print "- Parent PF found"

'Create subfolder PF
Dim cdoNewPF As New CDO.Folder
Dim strChildURL As String
strSubFolderName = "SF7"
strChildURL = strURL & "/" & strSubFolderName

'GoTo xxx 'uncomment this to bypass subfolder creation
Set cdoNewPF = CreateObject("CDO.Folder")
With cdoNewPF
.Description = "new subfolder"
.ContentClass = "urn:content-classes:folder"

.Fields("http://schemas.microsoft.com/exchange/outlook/outlookfolderclass")
=
"IPF.Folder"
.Fields.Update
.DataSource.SaveTo strChildURL
End With
Debug.print "- new PF subfolder created at: " & Format(Now, "hhnnss")

'Set MailEnabled property of new PF
'show some properties
Debug.print "Got PF: " & cdoNewPF.DisplayName
Debug.print "EmailAddress: " & cdoNewPF.EmailAddress

'set MailEnabled property
Set cdoRecip = cdoNewPF
cdoRecip.MailEnable
cdoNewPF.DataSource.Save
Debug.print "PF MailEnabled"

'force RUS to fire, flush update to system, reduce time
' for successful message to new PF

'Code for RUS from SOX010125700062
'TODO: make generic instead of hardcoded values below
strDomainName = "myxxx42k"
strDomain = "dc=myxxx42k, dc=extest,dc=microsoft,dc=com"
strServer = "myxxx4w2k" '"stephap3"

'Kick off the Recipient Update Service
' >>>> ToDo: Make sure the following string is correct
' by finding the RUS for your domain via ADSIEdit.

strrus = "CN=Recipient Update Service (" & strDomainName & "),CN=Recipient
Update
Services," & _
"CN=Address Lists Container,CN=JeffOrg,CN=Microsoft
Exchange,CN=Services," & _
"CN=Configuration," & strDomain



Dim objRUS As Object
Set objRUS = GetObject("LDAP://" & strServer & "/" & strrus)
objRUS.Put "msExchReplicateNow", True
objRUS.SetInfo

Debug.print "RUS triggered to ReplicateNow"

'send message to new PF

'get mailbox to send mail from
Dim iPer As New CDO.Person
Dim iMbx As CDO.IMailbox
Dim strMailboxURL As String

iPer.DataSource.Open "LDAP://" & oSysInfo.UserName
Set iMbx = iPer
strMailboxURL = iMbx.BaseFolder

Dim iMsg As New CDO.Message
'Dim iBp As CDO.IBodyPart
Dim Flds As ADODB.Fields
Dim Conn As New ADODB.Connection
Dim Stm As ADODB.Stream

Conn.Provider = "ExOLEDB.DataSource"
Conn.Open strMailboxURL

Dim iConf As New CDO.Configuration
Set Flds = iConf.Fields

Flds(cdoSendUsingMethod) = cdoSendUsingExchange
Flds(cdoMailboxURL) = strMailboxURL
Flds(cdoActiveConnection) = Conn
Flds.Update

With iMsg
Set .Configuration = iConf
.To = strSubFolderName & "@myxxx42k.extest.microsoft.com"
.From = "Admini...@myxxx42k.extest.microsoft.com"
.Subject = "Test message to new PF at: " & Format(Now, "hhnnss")
.TextBody = "This is the Text!"

' Set iBp = .AddAttachment("c:\wordfile.doc") 'optional
Set Stm = .GetStream
Stm.SaveToFile "c:\newmessage.eml", adSaveCreateOverWrite
.Send
End With

Debug.print "- Message to new PF sent"

'use timer to send more messages
pstrSubFolderName = strSubFolderName
With Me.Timer1
.Interval = 5000
.Enabled = True
End With
Shape1.BackColor = vbGreen

Exit_CreateMailEnabledPF:

'explicitly release objects
Set cdoRecip = Nothing
Set cdoParentPF = Nothing
Set cdoNewPF = Nothing
Set oSysInfo = Nothing

Set iPer = Nothing
Set Stm = Nothing
Set iMsg = Nothing
Set iMbx = Nothing

Debug.print "Done"

End Sub