1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
|
Private Sub Worksheet_Change(ByVal Target As Range)
Dim tVal As String
Dim sCount As Integer
Dim sVal
Dim c As New Collection
Dim r As Range
Dim PasteRow As Long
Dim rowAV As String
'Capitalizes first letter of all data entered
'******************
If Target.Count = 1 Then
Application.EnableEvents = False
Target.Value = MakeCaps(Target)
Application.EnableEvents = True
End If
'***************
Dim r3 As Range
'rRow2 is row where dupe was found
If Target.Count > 1 Then GoTo nxt
If Target.Column <> 17 Then GoTo nxt
'If the value entered already exists somewhere
If ChkDupes(Target.Value, Target) = True Then
Application.EnableEvents = False
'If target row is not blank
If n <> "" Then
Set r3 = Range("P" & Cells.Rows.Count).End(xlUp).Offset(1, 0)
Target.Value = n
Range("E" & Target.Row & ":" & "IV" & Target.Row).Copy Range("E" & r3.Row)
Range("E" & rRow2 & ":" & "IV" & rRow2).Copy Range("E" & Target.Row)
Range("E" & rRow2 & ":" & "AU" & rRow2).ClearContents
Range("AW" & rRow2 & ":" & "IV" & rRow2).ClearContents
Range("P" & rRow2).Value = "Free seat"
n = Target.Value
Else 'If target row is blank
Target.Value = n
Range("E" & rRow2 & ":" & "IV" & rRow2).Copy Range("E" & Target.Row)
Range("E" & rRow2 & ":" & "AU" & rRow2).ClearContents
Range("AW" & rRow2 & ":" & "IV" & rRow2).ClearContents
Range("P" & rRow2).Value = "Free seat"
n = Target.Value
End If
Application.EnableEvents = True
'If the value entered does not exist on this sheet
Else
If Target.Value <> "" Then
If Target.Value <> n Then 'if a cell was changed to a different value it already was
'rowAV = Cells(Target.Row, "AV")
MoveData Sheets("Stock"), Target, "Q", True
'Cells(Target.Row, "AV") = rowAV
End If
End If
End If
nxt:
arrAddress = Split(Mid(Target.Address, 2), "$")
strCol = arrAddress(0)
intRow = arrAddress(1)
' Avoid multiple cells being changed
If InStr(strCol, ":") = 0 And InStr(intRow, ":") = 0 Then
If intRow > 1 Then
strObjectType = "user"
strSearchField = Cells(1, strCol).Value
strObjectToGet = Cells(intRow, strCol).Value
strCommaDelimProps = ""
For intCount = 1 To Cells(1, 256).End(xlToLeft).Column
If Trim(Cells(1, intCount).Value) <> "" Then
If strCommaDelimProps = "" Then
strCommaDelimProps = Cells(1, intCount).Value
Else
strCommaDelimProps = strCommaDelimProps & "," & Cells(1, intCount).Value
End If
End If
Next
'MsgBox "Get_LDAP_User_Properties(" & strObjectType & "," & strSearchField & "," & strObjectToGet & "," & strCommaDelimProps & ")"
strDetails = Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)
arrDetails = Split(strDetails, "|")
'MsgBox strDetails
Application.EnableEvents = False
'Specify which column has your Name (full name) attribute. This
' is required to get the email address from the same Contact if it
' cannot be found in the user object
strFullNameColumn = "K"
For intCount = LBound(arrDetails) + 1 To UBound(arrDetails) + 1
For intCol = 1 To Cells(1, 256).End(xlToLeft).Column
If LCase(Cells(1, intCol).Value) = LCase(Split(arrDetails(intCount - 1), "^")(0)) Then
If LCase(Split(arrDetails(intCount - 1), "^")(0)) = "mail" Then
If Trim(Split(arrDetails(intCount - 1), "^")(1)) <> "" Then
Cells(intRow, intCol).Value = Split(arrDetails(intCount - 1), "^")(1)
Else
If LCase(strSearchField) <> "mail" Then
strObjectType = "contact"
strSearchField = "name"
strObjectToGet = Cells(intRow, strFullNameColumn).Value
strCommaDelimProps = "mail"
strContactMail = Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)
If UBound(Split(strContactMail, "^")) = 1 Then
Cells(intRow, intCol).Value = Split(strContactMail, "^")(1)
Else
Cells(intRow, intCol).Value = strContactMail
End If
End If
End If
ElseIf LCase(Split(arrDetails(intCount - 1), "^")(0)) = "manager" Then
If Trim(Split(arrDetails(intCount - 1), "^")(1)) <> "" Then
strManager = Split(arrDetails(intCount - 1), "^")(1)
strManager = Mid(strManager, 4)
strManager = Left(strManager, InStr(strManager, ",") - 1)
Cells(intRow, intCol).Value = strManager
End If
ElseIf LCase(Split(arrDetails(intCount - 1), "^")(0)) = "company" Then
If InStr(Split(arrDetails(intCount - 1), "^")(1), " ") > 0 Then
Cells(intRow, intCol).Value = Split(Split(arrDetails(intCount - 1), "^")(1), " ")(0)
Else
Cells(intRow, intCol).Value = Split(arrDetails(intCount - 1), "^")(1)
End If
Else
Cells(intRow, intCol).Value = Split(arrDetails(intCount - 1), "^")(1)
End If
End If
Next
Next
Application.EnableEvents = True
End If
End If
'
'
'Capitalizes first letter of all data entered
'******************
If Target.Count = 1 Then
Application.EnableEvents = False
Target.Value = MakeCaps(Target)
Application.EnableEvents = True
End If
'***************
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
n = Target.Value
End Sub
Function Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)
If InStr(strObjectToGet, "\") > 0 Then
arrGroupBits = Split(strObjectToGet, "\")
strDC = arrGroupBits(0)
strDNSDomain = strDC & "/" & "DC=" & Replace(Mid(strDC, InStr(strDC, ".") + 1), ".", ",DC=")
strObjectToGet = arrGroupBits(1)
Else
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("defaultNamingContext")
End If
strDetails = ""
strBase = ""
' Setup ADO objects.
Set adoCommand = CreateObject("ADODB.Command")
Set ADOConnection = CreateObject("ADODB.Connection")
ADOConnection.Provider = "ADsDSOObject"
ADOConnection.Open "Active Directory Provider"
adoCommand.ActiveConnection = ADOConnection
' Filter on user objects.
'strFilter = "(&(objectCategory=person)(objectClass=user))"
strFilter = "(&(objectClass=" & strObjectType & ")(" & strSearchField & "=" & strObjectToGet & "))"
' Comma delimited list of attribute values to retrieve.
strAttributes = strCommaDelimProps
arrProperties = Split(strCommaDelimProps, ",")
' Construct the LDAP syntax query.
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
adoCommand.CommandText = strQuery
adoCommand.Properties("Page Size") = 100
adoCommand.Properties("Timeout") = 30
adoCommand.Properties("Cache Results") = False
' Run the query.
Set adoRecordset = adoCommand.Execute
' Enumerate the resulting recordset.
Do Until adoRecordset.EOF
' Retrieve values and display.
For intCount = LBound(arrProperties) To UBound(arrProperties)
If strDetails = "" Then
If IsArray(adoRecordset.Fields(intCount)) = False Then
strDetails = adoRecordset.Fields(intCount).Name & "^" & adoRecordset.Fields(intCount).Value
Else
strDetails = adoRecordset.Fields(intCount).Name & "^" & Join(adoRecordset.Fields(intCount).Value)
End If
Else
If IsArray(adoRecordset.Fields(intCount)) = False Then
strDetails = strDetails & "|" & adoRecordset.Fields(intCount).Name & "^" & adoRecordset.Fields(intCount).Value
Else
strDetails = strDetails & "|" & adoRecordset.Fields(intCount).Name & "^" & Join(adoRecordset.Fields(intCount).Value)
End If
End If
Next
' Move to the next record in the recordset.
adoRecordset.MoveNext
Loop
' Clean up.
adoRecordset.Close
ADOConnection.Close
Get_LDAP_User_Properties = strDetails
End Function
|
