Email NDR to Public Folder

CONST strServer   = "SERVER"
  CONST strMailbox   = "MAILBOX"
  Dim objSession
  Dim objMessages
  Dim objOneMessage
  Dim objInfoStores
  Dim objInfoStore
  Dim objTopFolder
  Dim objFolders
  Dim objInbox
  Dim objSubFolder
  Dim objTargetFolder
  Dim strProfileInfo
  Dim bstrPublicRootID
  Dim i

  strProfileInfo = strServer & vblf & strMailbox
  Set objSession = CreateObject("MAPI.Session")
  objSession.Logon , , False, , , True, strProfileInfo
  Set objInfoStores = objSession.InfoStores
  For i = 1 To objInfoStores.Count
  	If objInfoStores.Item(i)= "Public Folders" Then
    		Set objInfoStore=objInfoStores.Item(i)
    		Exit For
  	End If
  Next
  bstrPublicRootID = objInfoStore.Fields.Item( &H66310102 ).Value
  Set objTopFolder = objSession.GetFolder(bstrPublicRootID, _
        objInfoStore.ID)
  Set objFolders = objTopFolder.Folders
  Set objFolder = objFolders.GetFirst()
  i = 0
  Do Until objFolder.Name = "Public Folder Name"
  	i = i + 1
  	If i > 100 Then 'kill the search
 		Exit Do
  	End If
  	Set objFolder=objFolders.GetNext()
  Loop
 
  For i = 1 to 3 '3 passes enough to grab everything
  	Set objInbox = objSession.Inbox
  	Set objMessages = objInbox.Messages
  	For Each objOneMessage in objMessages
   		If objOneMessage.Type = "REPORT.IPM.Note.NDR" Then
  			Set objCopyMsg = objOneMessage.MoveTo(objFolder.ID)
		End If
  	Next
  Next
  objSession.Logoff
  Set objOneMessage = Nothing
  Set objMessages = Nothing
  Set objFolder = Nothing
  Set objTopFolder = Nothing
  Set objSession = Nothing