Outlook - VBWEB

Senhores(as),

Estou postando este código e gostaria de saber se alguém consegue me ajudar a testar...

Obrigado.

***************************************************************

<%
Sub thisPage_onenter()

Dim bstrAT, oSession,oInbox,oMessages
Dim oRenderApp,oRenderer, myUser
Dim objSession
Dim objMessages
Dim objOneMessage
Dim objInfoStores
Dim objInfoStore
Dim objTopFolder
Dim objFolders
Dim objFolder
Dim objSubFolder
Dim objTargetFolder
Dim strProfileInfo
Dim i
Dim bstrPublicRootID
Dim FieldsCollection, myField,strSQL

On Error Resume Next 'Are going to test for errors

If(thisPage.MinEntered) Then
 'user logs on to IIS as IUSR_machine (if IIS anonymous login is enabled in IIS).
 'However because of Exchange Server’s security
 'reasons, this account will not be allowed to log onto Exchange Server. Therefore we
 'must add NT Challenge or Basic to the HTTP header to force the logon as the
 'NT Challenge/Response Or Basic in order for the Exchange Server login to work. This
 'code should be added to every routine on every ASP page that logs onto Exchange
 'sever in case the session times out.
 'NOTE 1: The only way I could get to logon to Exchange Server successfully was to make
 'the IIS 'logon be IIS Anonymous and Basic logon and to DISABLE
 'NT Challenge/Response (because of an Exchange Server bug)

 'Get the IIS Authorization type
 bstrAT = Request.ServerVariables("AUTH_TYPE")
 'Force BASIC authentication as Exchange Server Requires to successfully logon to it
 if InStr(1,"_BasicNTLM", bstrAT,vbTextCompare) < 2 Then
 Response.Buffer = TRUE 'buffer until page is complete

 'tell browser user is not authorized and for browser to challenge for the
 'user credentials (i.e., his NT account)
 Response.Status = ("401 Unauthorized")
 Response.AddHeader "WWW.Authenticate", "Basic"
 Response.End
 End If

 'The MAPI Session object is created and Exchange Server is logged onto.

  'Create the MAPI Session Object
  set objSession = Server.CreateObject("MAPI.Session")
  response.End()
  'Logon to Exchange server, specify which server and mailbox
  err.clear 'we are going to test for errors so clear 1st
  '
  'Create the logon string
  'strProfileInfo = "myExchangeServerName" & vbLF & "myValidExdhangeMailboxName"
  strProfileInfo = "myExchangeServerName" & vbLF & "fyamashi"

'Try to logon to Exchange Server
objSession.Logon "", "", False,True,0,True,strProfileInfo

'Verify login (still may not have correct permissions even if logon worked)
 myUser = objSession.CurrentUser
 'Response.Write(" DEBUG: Exchange Logon User = " & myUSer)

 'See if logon was successful
 if err.number = 0 And myUser <> "Unknown" Then
 '
 'The Exchange Server Public Folder Collection is then obtained. (See Reference 2.)
 '

 'Get the info stores collection
 Set objInfoStores = objSession.InfoStores

   'Get the Public Folders Info Store
   Dim myFoundPulic
   myFoundPublic = false

For i = 1 To objInfoStores.Count

 If objInfoStores.Item(i)= "Public Folders" Then
 Set objInfoStore=objInfoStores.Item(i)
 'Response.Write(" __DEBUG: Found 'Public Folders' InfoStore OK")
 myFoundPublic = true
 Exit For 'found it
 End If
 Next

 if myFoundPublic = true Then

 'Get the Folders Root
 'H66310102 is the value for Public Folders ID (see Technet)

 bstrPublicRootID = objInfoStore.Fields.Item( &H66310102 ).Value
 Set objTopFolder = objSession.GetFolder(bstrPublicRootID, objInfoStore.ID)

 'Get the Public Folders Collection
 Set objFolders = objTopFolder.Folders

'
 'The Contacts Folder within the Public Folders is then found (simply identified by its Contacts folder name).
 '

 'Find the Public Folder we’re looking for (Outlook Contacts)
 Set objFolder = objFolders.GetMin()

 Dim test,j
 test = objFolder.Name
 'Response.Write(" DEBUG: Public Folder Name = " & test)
 '
 'init
 j=0
 '
 Do Until test = "myPublicFolderNameConsistingOfContacts"
 Set objFolder=objFolders.GetNext()
 test = objFolder.Name
 'Response.Write(" DEBUG: Public Folder Name = " & test)
 j= j+1
 if j>100 then
 Exit Do 'Avoid infinite loop
 End if
 Loop
 '
 if test = "myPublicFolderNameConsistingOfContacts" Then
 '
 '
 'The individual contacts are then obtained and processed. The vendor names are stored temporarily into an SQL database for later sorting.
 '
 '
 'Get the Contacts Collection
 Set objMessages = objFolder.Messages
 'Response.Write("DEBUG:objMessages.Count = " _
 '& objMessages.Count & " ")

 'Fill the vendor list box with Exchange Server Public
 'Folder Contact Data. Since it
 'is not alphabetical when getting from Exchange server,
 'we will temporarily store it in an SQL db table and then retrieve with
 'ORDER BY ASC clause
 'store the contact data temporality in a SQL db table

 'delete the current Unalphabetical Contacts SQL db data
 Dim DeleteRecordset
 set DeleteRecordset=CreateObject("ADODB.Recordset")
 strSQL = "DELETE FROM tempContacts"
 DeleteRecordset.Open strSQL,"DSN=MyDSN;UID=sa"
 'Get ready to fill it with current unalphabetized Contact Data
 Dim InsertRecordset
 set InsertRecordset=CreateObject("ADODB.Recordset")
 Dim myContactCo,myProfession

     'Look at each Contact
     For Each objOneMessage in objMessages

      'Get the fields from this Contact
      Set FieldsCollection = objOneMessage.Fields

      'Get the Company name and profession for each contact
      'See cdo.hlp for &H codes
      myContactCo = FieldsCollection.Item(&H3A16001E)
      myProfession = FieldsCollection.Item(&H3A46001E)
      if myProfession = "Vendor" Then

       'Replace all with spaces for INSERT to work
       myContactCo = Replace(myContactCo,"'"," ")

       'put into temp SQL db
       strSQL = " INSERT INTO tempContacts" & _
          " VALUES ('" & myContactCo & "')"
       InsertRecordset.Open strSQL,"DSN=MyDSN;UID=sa"
      End if
      myProfession = "" 'reset
      myContactCo = ""
     Next

     '
     '
     'The vendor names are retrieved, sorted, and placed into the vendor name list box.
     '
     '
     'Now retrieve the data alphabetically and put into Drop list
     Dim ContactsRecordset
     '
     set ContactsRecordset=CreateObject("ADODB.Recordset")
     strSQL = "Select * from tempContacts ORDER BY CompanyName ASC"
     ContactsRecordset.Open strSQL,"DSN=MyDSN;UID=sa"
     ContactsRecordset.MoveMin

     lstVendors.clear 'clear current drop list
     lstVendors.addItem("") 'force a user selection
     Do While (NOT ContactsRecordset.EOF)
      'Get 1st and only field value of the field
      'COLLECTION in the DropList Table
      myField = ContactsRecordset.Fields("CompanyName")
      lstVendors.addItem(myField)
      ContactsRecordset.MoveNext
     Loop

     '
     'Cleanup is then performed.
     '

set ContactsRecordset = nothing
 set InsertRecordset = nothing
 set DeleteRecordset = nothing
 Else
 Response.Write(" ERROR getting " &_
 "myValidExdhangeMailboxName_ Folder From Public " &_
 "Folders On Exchange Server...Vendor Info_ will " &_
 "not be available ")
 End If
 Else
 Response.Write(" ERROR getting Public Folders OnExchangeServer ")
 End If
 Else
 Response.Write("ERROR logging onto Exchange Server...Vendor Info will not be available ")
 bstrHTTPUser = Request.ServerVariables("AUTH_USER")
 Response.Write(" AUTH_USER = " & bstrHTTPUser)
 bstrHTTPPaswrd = Request.ServerVariables("AUTH_PASSWORD")
 Response.Write(" AUTH_PASSWORD = " & bstrHTTPPaswrd)
 bstrAT = Request.ServerVariables("AUTH_TYPE")
 Response.Write(" AUTH_TYPE = " & bstrAT)
 End If
 objSession.Logoff
 Set objOneMessage = Nothing
 Set objMessages = Nothing
 Set objFolder = Nothing
 Set objTopFolder = Nothing
 Set objSession = Nothing
 End If
End Sub

'
'Once the vendor name list box is filled in, the user can select a vendor to get their address, phone number, etc., from the Outlook Contacts Folder. The preceding code is essentially duplicated in order to logon to the Exchange server again and get the data (in case of timeouts).
'
Sub lstVendors_onchange()
Dim bstrAT, oSession,oInbox,oMessages
Dim oRenderApp,oRenderer, myUser
Dim objSession
Dim objMessages
Dim objOneMessage
Dim objInfoStores
Dim objInfoStore
Dim objTopFolder
Dim objFolders
Dim objFolder
Dim objSubFolder
Dim objTargetFolder
Dim strProfileInfo
Dim i
Dim bstrPublicRootID
Dim FieldsCollection, myField,strSQL

On Error Resume Next

'Get selected list box value
mySelectedCo = lstVendors.getText()

'Find this co. in Contacts Db in order to get address, etc.

'Make sure Browser is authenticated, or else you can't log on to Exchange server
bstrAT = Request.ServerVariables("AUTH_TYPE")
if InStr(1,"_BasicNTLM", bstrAT,vbTextCompare) < 2 Then
 Response.Buffer = TRUE
 Response.Status = ("401 Unauthorized")
 Response.AddHeader "WWW.Authenticate", "NTLM"
 Response.End
End If
set objSession = Server.CreateObject("MAPI.Session")

On Error Resume Next

'Logon to Exchange server again (in case timed out), specify which server and mailbox
'strProfileInfo = "myExchangeServerName" & vbLF & myValidExdhangeMailboxName)
strProfileInfo = ("myExchangeServerName" & vbLF & "myValidExdhangeMailboxName")
err.clear

'try to logon
objSession.Logon "", "", False,True,0,True,strProfileInfo

'Verify login (still may not have correct permissions even if this works)
myUser = objSession.CurrentUser
'Response.Write(" DEBUG: Exchange Logon User = " & myUSer)

'See if successful
if err.number = 0 Then
  Set objInfoStores = objSession.InfoStores

  Dim myFoundPulic
  myFoundPublic = false
  For i = 1 To objInfoStores.Count
   If objInfoStores.Item(i)= "Public Folders" Then 'look at Public folders
    Set objInfoStore=objInfoStores.Item(i)
    myFoundPublic = true
    Exit For 'found it
   End If
  Next

if myFoundPublic = true Then

   'H66310102 is for Public Folders ID
   bstrPublicRootID = objInfoStore.Fields.Item( &H66310102 ).Value
   Set objTopFolder = objSession.GetFolder(bstrPublicRootID, _
      objInfoStore.ID)
   Set objFolders = objTopFolder.Folders
   Set objFolder = objFolders.GetMin()
   Dim test,j
   test = objFolder.Name
   j=0 'init
   Do Until test = " myPublicFolderNameConsistingOfContacts "
    Set objFolder=objFolders.GetNext()
    test = objFolder.Name
    j= j+1
    if j>100 then
     Exit Do 'avoid infinite loop
    End if
   Loop
   if test = " myPublicFolderNameConsistingOfContacts " Then

    Set objMessages = objFolder.Messages

    'Find the desired Co in the Exchange data
    Dim myContactCo, myFoundIt
    myFoundIt = false
    For Each objOneMessage in objMessages
     Set FieldsCollection = objOneMessage.Fields
     myContactCo = FieldsCollection.Item(&H3A16001E)
     myContactCo = Replace(myContactCo,"'"," ")
     if myContactCo = mySelectedCo Then
      myFoundIt = true
      Exit For
     End if
    Next

    If myFoundIt = true Then
     '
     'Individual Contact Addresses, etc., are then using the &H Property Tags from Reference 3.
     '
     'See cdo.hlp for &H codes

'Get the Street
myContactStr = FieldsCollection.Item(&H3A29001E)

'Get the city
myContactCity = FieldsCollection.Item(&H3A27001E)

'Get the state
myContactSt = FieldsCollection.Item(&H3A28001E)

'Get the zip code
myContactZip = FieldsCollection.Item(&H3A2A001E)

'Get the phone number
myContactPh = FieldsCollection.Item(&H3A08001E)

'Get the fax number
myContactFax = FieldsCollection.Item(&H3A24001E)

'Get out Customer Id
 myContactID = FieldsCollection.Item(&H3A4A001E)
 'NOTE: Can't find the E-mail addr in Exchange (MS bug!!??)
 'therefore get it from our own maintainable VendorEmail Table
 myContactEmail = "Unknown" 'init
 VendorEmailRecordset.close
 VendorEmailRecordset.open
 myRecordCount = VendorEmailRecordset.getCount()
 Count=myRecordCount
 If (VendorEmailRecordset.getCount() > 0) Then
 VendorEmailRecordset.moveMax
 Do While(VendorEmailRecordset.BOF <> true)
 if(VendorEmailRecordset.fields.getValue("CompanyName") = myContactCo) Then
 myContactEmail = VendorEmailRecordset.fields.getValue("EmailAddr")
 exit Do
 End If
 VendorEmailRecordset.movePrevious
 Count=Count-1
 Loop
 End If

'Fill in the Text Boxes with the data
 txtVendorName.value = myContactCo
 txtVendorStreet.value = myContactStr
 txtVendorCity.value = myContactCity
 txtVendorState.value = myContactSt
 txtVendorZip.value = myContactZip
 txtVendorPhone.value = myContactPh
 txtVendorFax.value = myContactFax
 Else
 Response.Write("Can't find selected " &_
 "company in Exchange_ " &_
 "Contacts Folder. Please manually fill in " &_
 "Vendor Address_ data.")
 End If
 Else
 Response.Write(" ERROR getting I.T.S Department " & _
 "Contacts Folder_ From Public Folders " & _
 " On Exchange Server...Vendor Info will not be " & _
 "available ")
 End If
 Else
 Response.Write(" ERROR getting Public Folders On Exchange Server...Vendor Info will not be available ")
 End If
Else
 Response.Write(" ERROR logging onto Exchange Server...Vendor Info will not be available ")
End If

objSession.Logoff
Set objOneMessage = Nothing
Set objMessages = Nothing
Set objFolder = Nothing
Set objTopFolder = Nothing
Set objSession = Nothing
End Sub
%>

****************************************************************