home *** CD-ROM | disk | FTP | other *** search
/ io Programmo 27 / IOPROG_27.ISO / SOFT / ADSDK.ZIP / Samples / Internet / adsiwab.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1999-01-27  |  10.6 KB  |  313 lines
  1. VERSION 5.00
  2. Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
  3. Begin VB.Form frmQuery 
  4.    Caption         =   "ADSI Windows Address Book"
  5.    ClientHeight    =   6585
  6.    ClientLeft      =   60
  7.    ClientTop       =   345
  8.    ClientWidth     =   7050
  9.    LinkTopic       =   "Form1"
  10.    ScaleHeight     =   6585
  11.    ScaleWidth      =   7050
  12.    StartUpPosition =   3  'Windows Default
  13.    Begin MSComctlLib.ListView lstResult 
  14.       Height          =   3255
  15.       Left            =   360
  16.       TabIndex        =   8
  17.       Top             =   2160
  18.       Width           =   6255
  19.       _ExtentX        =   11033
  20.       _ExtentY        =   5741
  21.       LabelWrap       =   -1  'True
  22.       HideSelection   =   -1  'True
  23.       _Version        =   393217
  24.       ForeColor       =   -2147483640
  25.       BackColor       =   -2147483643
  26.       BorderStyle     =   1
  27.       Appearance      =   1
  28.       NumItems        =   0
  29.    End
  30.    Begin VB.CommandButton cmdClear 
  31.       Caption         =   "Clear All"
  32.       Height          =   375
  33.       Left            =   5640
  34.       TabIndex        =   7
  35.       Top             =   960
  36.       Width           =   1215
  37.    End
  38.    Begin VB.CommandButton cmdFindNow 
  39.       Caption         =   "Find Now"
  40.       Height          =   375
  41.       Left            =   5640
  42.       TabIndex        =   6
  43.       Top             =   360
  44.       Width           =   1215
  45.    End
  46.    Begin VB.TextBox txtEmail 
  47.       Height          =   315
  48.       Left            =   1320
  49.       TabIndex        =   5
  50.       Top             =   1320
  51.       Width           =   4095
  52.    End
  53.    Begin VB.TextBox txtName 
  54.       Height          =   315
  55.       Left            =   1320
  56.       TabIndex        =   3
  57.       Top             =   840
  58.       Width           =   4095
  59.    End
  60.    Begin VB.ComboBox cbAddress 
  61.       Height          =   315
  62.       Left            =   1320
  63.       Style           =   2  'Dropdown List
  64.       TabIndex        =   1
  65.       Top             =   360
  66.       Width           =   4095
  67.    End
  68.    Begin VB.Label lblStatus 
  69.       Height          =   615
  70.       Left            =   1080
  71.       TabIndex        =   12
  72.       Top             =   5880
  73.       Width           =   5775
  74.    End
  75.    Begin VB.Label Label5 
  76.       Caption         =   "Status:"
  77.       Height          =   255
  78.       Left            =   480
  79.       TabIndex        =   11
  80.       Top             =   5880
  81.       Width           =   615
  82.    End
  83.    Begin VB.Label Label4 
  84.       Caption         =   "Record(s) Found"
  85.       Height          =   255
  86.       Left            =   1080
  87.       TabIndex        =   10
  88.       Top             =   5520
  89.       Width           =   2415
  90.    End
  91.    Begin VB.Label lblCount 
  92.       Alignment       =   1  'Right Justify
  93.       Height          =   255
  94.       Left            =   360
  95.       TabIndex        =   9
  96.       Top             =   5520
  97.       Width           =   495
  98.    End
  99.    Begin VB.Label Label3 
  100.       Caption         =   "E-mail:"
  101.       Height          =   255
  102.       Left            =   240
  103.       TabIndex        =   4
  104.       Top             =   1320
  105.       Width           =   855
  106.    End
  107.    Begin VB.Label Label2 
  108.       Caption         =   "Name:"
  109.       Height          =   255
  110.       Left            =   240
  111.       TabIndex        =   2
  112.       Top             =   840
  113.       Width           =   735
  114.    End
  115.    Begin VB.Label Label1 
  116.       Caption         =   "Look in:"
  117.       Height          =   255
  118.       Left            =   240
  119.       TabIndex        =   0
  120.       Top             =   360
  121.       Width           =   735
  122.    End
  123. Attribute VB_Name = "frmQuery"
  124. Attribute VB_GlobalNameSpace = False
  125. Attribute VB_Creatable = False
  126. Attribute VB_PredeclaredId = True
  127. Attribute VB_Exposed = False
  128. Const ACTIVEDIR_SELECTED = 1
  129. Dim con As New Connection
  130. Private Sub cmdClear_Click()
  131.   txtEmail = ""
  132.   txtName = ""
  133.   lstResult.ListItems.Clear ' Clear the user interface
  134.   lblCount = 0
  135.   lblStatus = ""
  136. End Sub
  137. Private Sub cmdFindNow_Click()
  138.     Dim rs As New Recordset
  139.     Dim Com As New Command
  140.     On Error GoTo bailout
  141.     sName = txtName
  142.     sEmail = txtEmail
  143.     If (sEmail = "" And sName = "") Then
  144.        MsgBox "Please enter some information to look for"
  145.        Exit Sub
  146.     End If
  147.     '-- Reset the Result User Interface ----
  148.     lstResult.ListItems.Clear
  149.     lblCount = "..."
  150.     lblStatus = "Searching..."
  151.     frmQuery.Refresh
  152.     frmQuery.MousePointer = vbHourglass
  153.     '--------------------------------------------------
  154.     '--- SETUP THE CONNECTION
  155.     '----------------------------------------------------
  156.     If (cbAddress.ListIndex = ACTIVEDIR_SELECTED) Then
  157.       con.Properties("User ID") = vbNullString
  158.       con.Properties("Password") = vbNullString
  159.       con.Properties("Encrypt Password") = True
  160.     Else
  161.       con.Properties("User ID") = ""
  162.       con.Properties("Password") = ""
  163.       con.Properties("Encrypt Password") = False
  164.     End If
  165.     con.Open "Active Directory Provider"
  166.     '-----------------------------------------------------------
  167.     '--- BUILDING ADsPath FOR BASE QUERY ---------------------
  168.     '-----------------------------------------------------------
  169.     sInternet = GetInternetAddress(cbAddress.ListIndex)
  170.     If (sInternet = "") Then   'Default to Active Directory
  171.       Set gc = GetObject("GC:")
  172.       For Each gcPath In gc 'Only one child in the GC: name space
  173.          sPath = gcPath.ADsPath
  174.       Next
  175.     Else
  176.       sPath = "GC://"
  177.       sPath = sPath + sInternet
  178.       sPath = sPath + ":389"
  179.     End If
  180.     '------- NAME AND E-MAIL ADDRESS ------------------
  181.     If (sEmail <> "") Then
  182.        sFilter = "(mail="
  183.        sFilter = sFilter + sEmail + "*)"
  184.     Else
  185.        sFilter = "(|(|(|(cn="
  186.        sFilter = sFilter + sName
  187.        sFilter = sFilter + "*))(sn="
  188.        sFilter = sFilter + sName
  189.        sFilter = sFilter + "*))(givenName="
  190.        sFilter = sFilter + sName
  191.        sFilter = sFilter + "*))"
  192.     End If
  193.     '---- BUILDING THE QUERY------------------------------------
  194.     sQuery = "<" + sPath
  195.     sQuery = sQuery + ">;"
  196.     sQuery = sQuery + sFilter
  197.     sQuery = sQuery + ";cn,mail,givenName,sn,st,c,homePhone;subtree"
  198.     ' Create a command object on this connection
  199.     Set Com.ActiveConnection = con
  200.     Com.CommandText = sQuery
  201.     '-----------------------------------------
  202.     'Set the preferences for Search
  203.     '--------------------------------------
  204.     Com.Properties("Timeout") = 600 'seconds
  205.     Com.Properties("Cache Results") = False ' do not cache the result, it results in less memory requirements
  206.     Com.Properties("Size Limit") = 200 ' limit the result set returned
  207.     '--------------------------------------------
  208.     'Execute the query
  209.     '--------------------------------------------
  210.     Set rs = Com.Execute
  211.     '--------------------------------------
  212.     ' Navigate the record set
  213.     '----------------------------------------
  214.     'rs.MoveFirst
  215.     lstResult.ListItems.Clear ' Clear the user interface
  216.     Counter = 0
  217.     lblCount = Counter
  218.     While Not rs.EOF
  219.                 
  220.                 Set newLine = lstResult.ListItems.Add(, , rs.Fields(0).Value(0))
  221.                 
  222.                 For i = 1 To rs.Fields.Count - 1
  223.                   If rs.Fields(i).Type = adVariant And Not (IsNull(rs.Fields(i).Value)) Then
  224.                      s = ""
  225.                      For j = LBound(rs.Fields(i).Value) To UBound(rs.Fields(i).Value)
  226.                         If (s <> "") Then
  227.                            s = s + ", "
  228.                         End If
  229.                         s = s + rs.Fields(i).Value(j)
  230.                      Next
  231.                         newLine.SubItems(i) = s
  232.                                       
  233.                 Else
  234.                     If (Not (IsNull(rs.Fields(i).Value))) Then
  235.                        newLine.SubItems(i) = rs.Fields(i).Value
  236.                     End If
  237.                   End If
  238.                 Next
  239.                 
  240.                 Counter = Counter + 1
  241.         
  242.         rs.MoveNext
  243.     Wend
  244.          
  245.      '------- CLEAN UP------------------
  246.      lblCount = Counter
  247.      frmQuery.MousePointer = 0
  248.      con.Close
  249.      lblStatus = "Success"
  250.      
  251.      Exit Sub
  252.      
  253. bailout:
  254.              lblStatus = "Error (" & Hex(Err.Number) & ") - " & Error(Err.Number)
  255.              frmQuery.MousePointer = 0
  256.              con.Close
  257.              Exit Sub
  258. End Sub
  259. Private Sub Form_Load()
  260.     On Error GoTo bailout
  261.     '----------------------------------------------------
  262.     '-------- DIRECTORY INTERNET ------------------------
  263.     '----------------------------------------------------
  264.     cbAddress.AddItem "Yahoo! People Search"
  265.     cbAddress.AddItem "Active Directory"
  266.     cbAddress.AddItem "BigFoot Internet Directory Service"
  267.     cbAddress.AddItem "InfoSpace Business Directory Service"
  268.     cbAddress.AddItem "InfoSpace Internet Directory Service"
  269.     cbAddress.AddItem "Switchboard Internet Directory Service"
  270.     cbAddress.AddItem "VeriSign Internet Directory Service"
  271.     cbAddress.AddItem "WhoWhere Internet Directory Service"
  272.     cbAddress.ListIndex = 0
  273.     '----------------------------------------------------
  274.     '-------- COLUMN HEADERS ----------------------------
  275.     '----------------------------------------------------
  276.     lstResult.ColumnHeaders.Add , , "Name"
  277.     lstResult.ColumnHeaders.Add , , "E-Mail"
  278.     lstResult.ColumnHeaders.Add , , "First Name"
  279.     lstResult.ColumnHeaders.Add , , "Last Name"
  280.     lstResult.ColumnHeaders.Add , , "Address"
  281.     lstResult.ColumnHeaders.Add , , "Country"
  282.     lstResult.ColumnHeaders.Add , , "Home Phone"
  283.     '--- Set to Report View ---------------
  284.     lstResult.View = 3
  285.     '---SET UP THE ADO/OLEDB PROVIDER ------------------
  286.     con.Provider = "ADsDSOObject"
  287.     Exit Sub
  288. bailout:     Debug.Print "Error", Hex(Err.Number), " :", Error(Err.Number)
  289.              Exit Sub
  290. End Sub
  291. Function GetInternetAddress(index As Integer) As String
  292. Select Case index
  293. Case 0
  294.   GetInternetAddress = "ldap.yahoo.com"
  295. Case 1
  296.   GetInternetAddress = "" 'Active Directory
  297. Case 2
  298.   GetInternetAddress = "ldap.bigfoot.com"
  299. Case 3
  300.   GetInternetAddress = "ldap.infospace.com"
  301. Case 4
  302.   GetInternetAddress = "ldapbiz.infospace.com"
  303. Case 5
  304.   GetInternetAddress = "ldap.switchboard.com"
  305. Case 6
  306.   GetInternetAddress = "directory.verisign.com"
  307. Case 7
  308.   GetInternetAddress = "ldap.whowhere.com"
  309. Case Else
  310.   GetInternetAddress = ""
  311. End Select
  312. End Function
  313.