Задача: пользователь уйдет в отпуск с 01 января по 11 января и его почту надо в его отсутствие пересылать другому пользователю.
Ок, вот Вам код - запускайте каждый час с ключом /SCHEDULE. Если без ключа - получите форму для управления списком.
Проект написан на VB6.
Сохранить в новой форме и все.
[code]
VERSION 5.00
Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
Begin VB.Form Form1
AutoRedraw = -1 'True
BorderStyle = 3 'Fixed Dialog
Caption = "On-Vacation Replacement"
ClientHeight = 9105
ClientLeft = 45
ClientTop = 375
ClientWidth = 7950
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 9105
ScaleWidth = 7950
StartUpPosition = 3 'Windows Default
Begin VB.TextBox txtFilterField
Appearance = 0 'Flat
Height = 495
Left = 120
TabIndex = 1
Text = "Filter-field"
ToolTipText = "Поле для фильтрации"
Top = 5280
Width = 2895
End
Begin VB.CommandButton Command6
Caption = "Показать расписание"
Height = 495
Left = 2760
TabIndex = 8
Top = 5880
Width = 3015
End
Begin VB.TextBox txtcfgFile
Height = 2535
Left = 120
MultiLine = -1 'True
TabIndex = 9
Top = 6480
Width = 7695
End
Begin VB.CommandButton Command5
Caption = "Добавить переадресацию"
Height = 495
Left = 120
TabIndex = 7
Top = 5880
Width = 2535
End
Begin VB.TextBox txtDateTo
Appearance = 0 'Flat
Enabled = 0 'False
Height = 375
Left = 5760
TabIndex = 16
TabStop = 0 'False
Top = 5280
Width = 2055
End
Begin VB.CommandButton Command4
Caption = "По какое число"
Height = 375
Left = 5760
TabIndex = 6
Top = 4800
Width = 2055
End
Begin VB.CommandButton Command3
Caption = "С какого числа"
Height = 375
Left = 5760
TabIndex = 5
Top = 3720
Width = 2055
End
Begin VB.TextBox txtDateFrom
Appearance = 0 'Flat
Enabled = 0 'False
Height = 375
Left = 5760
TabIndex = 15
TabStop = 0 'False
Top = 4200
Width = 2055
End
Begin MSComCtl2.MonthView MonthView1
Height = 2310
Left = 3240
TabIndex = 4
Top = 3480
Width = 2415
_ExtentX = 4260
_ExtentY = 4075
_Version = 393216
ForeColor = -2147483630
BackColor = -2147483632
Appearance = 0
ShowWeekNumbers = -1 'True
StartOfWeek = 53149698
CurrentDate = 42284
End
Begin VB.TextBox txtVacationTo
Appearance = 0 'Flat
Enabled = 0 'False
Height = 375
Left = 3120
TabIndex = 14
TabStop = 0 'False
ToolTipText = "Этому пользователю будет перенаправлена почта пользователя уходящего в отпуск."
Top = 3000
Width = 4695
End
Begin VB.TextBox txtVacationFrom
Appearance = 0 'Flat
Enabled = 0 'False
Height = 375
Left = 3120
TabIndex = 13
TabStop = 0 'False
ToolTipText = "Этот пользователь в отпуске. Его почту необходимо перенаправлять в другой почтовый ящик"
Top = 1920
Width = 4695
End
Begin VB.CommandButton Command2
Appearance = 0 'Flat
Caption = "Этот пользователь замещает"
Height = 495
Left = 3120
TabIndex = 3
Top = 2400
Width = 4695
End
Begin VB.CommandButton Command1
Appearance = 0 'Flat
Caption = "Этот пользователь в отпуске"
Height = 495
Left = 3120
TabIndex = 2
Top = 1320
Width = 4695
End
Begin VB.ListBox List1
Appearance = 0 'Flat
Height = 4710
ItemData = "Form1.frx":0000
Left = 120
List = "Form1.frx":0002
Sorted = -1 'True
TabIndex = 0
ToolTipText = "Выберите пользователя"
Top = 480
Width = 2895
End
Begin VB.Label Label1
Caption = "Почта перенаправлена следующему пользователю:"
Height = 495
Left = 3360
TabIndex = 12
Top = 120
Width = 3255
End
Begin VB.Label lblAltRecipient
Height = 375
Left = 3360
TabIndex = 11
Top = 720
Width = 3375
End
Begin VB.Label lblDomain
Caption = "Label1"
Height = 255
Left = 120
TabIndex = 10
Top = 120
Width = 2895
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public strFile As String
Function ReadSchedules()
On Error Resume Next
Err.Clear
Open strFile For Input As #1
If Not Err.Number = 0 Then Exit Function
Do While Not EOF(1)
Line Input #1, strTemp
ReadSchedules = ReadSchedules & strTemp & vbCrLf
Loop
Close #1
End Function
Sub WriteNewSchedule(strString)
'
' After all checks in other prodecures we can finally write new schedule for our program
'
Open strFile For Append As #1
Print #1, strString
Close #1
End Sub
Function FindDuplicates(strString)
'
' Here we will check if we have already scheduled job with absolutely same parameters
' This means, that everything is equal: user-from;user-to;date-from;date-to
'
FindDuplicates = False
Open strFile For Input As #1
Do While Not EOF(1)
Line Input #1, strTemp
If LCase(strTemp) = LCase(strString) Then FindDuplicates = True: Exit Do
Loop
Close #1
End Function
Sub SetCfgFile()
strFile = App.Path
If Right(strFile, 1) = "\" Then strFile = Left(strFile, Len(strFile) - 1)
strFile = strFile & "\ovr.cfg"
End Sub
Private Sub Command1_Click()
'
' Users must not to be equal
'
txtVacationFrom.Text = List1.List(List1.ListIndex)
If LCase(txtVacationFrom.Text) = LCase(txtVacationTo.Text) Then
'
' Otherwise - blink
'
txtVacationTo.Text = ""
Blink_object_background txtVacationFrom
Exit Sub
End If
End Sub
Private Sub Command2_Click()
'
' Users must not be equal
'
txtVacationTo.Text = List1.List(List1.ListIndex)
If LCase(txtVacationFrom.Text) = LCase(txtVacationTo.Text) Then
'
' Otherwise - blink
'
txtVacationTo.Text = ""
Blink_object_background txtVacationFrom
Exit Sub
End If
End Sub
Private Sub Command3_Click()
'
' Check selected day-month-year
'
strDay = MonthView1.Day
strMonth = MonthView1.Month
strYear = MonthView1.Year
If strDay < 10 Then strDay = "0" & strDay
If strMonth < 10 Then strMonth = "0" & strMonth
strDateFrom = strDay & "-" & strMonth & "-" & strYear
txtDateFrom.Text = strDateFrom
'
' Date From must to lower than Date To
'
If txtDateFrom.Text = txtDateTo.Text Then
'
' Otherwise - blink
'
txtDateTo.Text = ""
Blink_object_background txtDateFrom
End If
If txtDateFrom.Text > txtDateTo.Text And txtDateTo.Text <> "" Then Blink_object_background txtDateFrom
End Sub
Private Sub Command4_Click()
'
' The same as Command3_Click() but working with other field
'
strDay = MonthView1.Day
strMonth = MonthView1.Month
strYear = MonthView1.Year
If strDay < 10 Then strDay = "0" & strDay
If strMonth < 10 Then strMonth = "0" & strMonth
strDateTo = strDay & "-" & strMonth & "-" & strYear
txtDateTo.Text = strDateTo
If txtDateFrom.Text = txtDateTo.Text Then
txtDateTo.Text = ""
Blink_object_background txtDateFrom
End If
If txtDateFrom.Text > txtDateTo.Text And txtDateTo.Text <> "" Then Blink_object_background txtDateFrom
End Sub
Private Sub Command5_Click()
On Error Resume Next
'
' Finally check all again
'
strUserFrom = txtVacationFrom.Text
strUserTo = txtVacationTo.Text
strDateFrom = txtDateFrom.Text
strDateTo = txtDateTo.Text
If strDateFrom >= strDateTo Then txtDateTo.Text = "": Blink_object_background Form1.txtDateTo: Exit Sub
If strDateFrom = "" Then Blink_object_background Form1.txtDateFrom: Exit Sub
If strDateTo = "" Then Blink_object_background Form1.txtDateTo: Exit Sub
If strUserFrom = "" Then Blink_object_background Form1.txtVacationFrom: Exit Sub
If strUserTo = "" Then Blink_object_background Form1.txtVacationTo: Exit Sub
If LCase(strUserFrom) = LCase(strUserTo) Then Blink_object_background Form1.txtVacationTo: txtVacationTo.Text = "": Exit Sub
strString = strUserFrom & ";" & strUserTo & ";" & strDateFrom & ";" & strDateTo
If FindDuplicates(strString) = True Then MsgBox ("Такая комбинация пользователь1;пользователь2;дата1;дата2 уже есть"): Exit Sub
'
' Passed
'
WriteNewSchedule (strString)
txtcfgFile.Text = ReadSchedules
End Sub
Private Sub Command6_Click()
'
' Read config file and show in text-box
' Even if user will change it - it doesn't matter. Enabled if this text-box set to True
' because in other case user will not be able to scroll text-box
'
SetCfgFile
txtcfgFile.Text = ReadSchedules
End Sub
Private Sub Form_Load()
On Error Resume Next
Const ADS_PROPERTY_CLEAR = 1
'
' Go check for some command-line arguments
'
strCmd = Command
'
' And if we got only one special command-line argument - go ahead, do your job.
'
If UCase(strCmd) = "/SCHEDULE" Then
'
' Get CFG File name and path
'
SetCfgFile
'
' Load everything from this file
'
a = ReadSchedules
'
' Split it and load into array
'
b = Split(a, vbCrLf)
'MsgBox ("Number of lines in file: " & UBound(b))
'
' Retrieve everyline and go into a cycle
'
i = 0
Do While i < UBound(b)
'If i >= UBound(b) Then MsgBox (i): Exit Do
'
' Now we need to parse CSV (Comma-Separated) File. Comma=";"
'
c = Split(b(i), ";")
'
' There is a cycle to easyly parse stupid checks below
'
For j = 1 To 1
user1 = LTrim(RTrim(c(0)))
user2 = LTrim(RTrim(c(1)))
datefrom = c(2)
dateto = c(3)
'
' Stupid checks but doing it
'
If CheckDate(datefrom) = False Then Exit For
If CheckDate(dateto) = False Then Exit For
If datefrom > dateto Then Exit For
If datefrom = dateto Then Exit For
If IsUserValid(user1) = False Then Exit For
If IsUserValid(user2) = False Then Exit For
If UCase(user1) = UCase(user2) Then Exit For
strUser1DN = GetLDAPValue("distinguishedName", "displayName='" & user1 & "'")
strUser2DN = GetLDAPValue("distinguishedName", "displayName='" & user2 & "'")
strDate = Date
dateto = CDate(dateto)
datefrom = CDate(datefrom)
If strDate = dateto Then
'
' Clear user1 AltRecipient field
'
Set objUser = GetObject("LDAP://" & strUser1DN)
objUser.PutEx ADS_PROPERTY_CLEAR, "altRecipient", 0
objUser.PutEx ADS_PROPERTY_CLEAR, "deliverAndRedirect", 0
objUser.SetInfo
ElseIf ((strDate >= datefrom) And (strDate < dateto)) Then
'
' Set user1 AltRecipient with user2 distinguishedName
'
Set objUser = GetObject("LDAP://" & strUser1DN)
objUser.Put "altRecipient", strUser2DN
objUser.Put "deliverAndRedirect", "TRUE"
objUser.SetInfo
End If
Next
i = i + 1
Loop
End
End If
'
' Auto-center form on load
'
Form1.Left = (Screen.Width - Form1.Width) \ 2
Form1.Top = (Screen.Height - Form1.Height) \ 2
'
' Read userlist from AD
'
Read_Users
'
' Set very important variable
'
SetCfgFile
End Sub
Sub Read_Users()
On Error Resume Next
'
' clear list
'
For i = 0 To Form1.List1.ListCount - 1
Form1.List1.RemoveItem (0)
Next
'
' Create network object
'
Set objNet = CreateObject("Wscript.Network")
'
' Get User's Domain
'
strDomain = objNet.UserDomain
'
' Connect to domain
'
Set objDomain = GetObject("WinNT://" & strDomain)
'
' Get object collection
'
For Each object In objDomain
'
' Filter only users
'
If LCase(object.Class) = "user" Then
'
' User's account must be enabled
'
If object.AccountDisabled = False Then
'
' Get user's email. That means that user must have email
'
strmail = GetLDAPValue("mail", "sAMAccountName='" & object.Name & "'")
'
' Filter only *@npcprom.ru users
'
If InStr(1, LCase(strmail), "@npcprom.ru") > 0 Then
'MsgBox (strMail)
'
' Check if user already have altRecipient
'
'strAlt = ""
'strAlt = GetLDAPValue("altRecipient", "sAMAccountName='" & object.Name & "'")
'If strAlt <> "" Then MsgBox (object.Name & vbCrLf & strAlt)
'
' If user have no altRecipient we can assign it
'
' Add to List1
'If strAlt = "" Then
Form1.List1.AddItem object.FullName
Counter = Counter + 1
Else
'
' not @npcprom.ru mailbox
'
End If
End If
End If
Next
'
' Show domain name and number of found users
'
Form1.lblDomain.Caption = UCase(objNet.UserDomain) & " (" & Counter & ")"
End Sub
Function GetLDAPDomain()
Set iAdRootDSE = GetObject("LDAP://RootDSE")
GetLDAPDomain = iAdRootDSE.Get("defaultNamingContext")
End Function
Function GetLDAPValue(strValue, strFilter)
Const ADS_SCOPE_SUBTREE = 2
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
strQuery = "SELECT " & strValue & " FROM 'LDAP://" & GetLDAPDomain & "' WHERE " & strFilter
objCommand.CommandText = strQuery
Set objRecordSet = objCommand.Execute
Do Until objRecordSet.EOF
strVar = strVar & objRecordSet.Fields(strValue).Value & "|"
objRecordSet.MoveNext
Loop
If Len(strVar) > 1 Then strVar = Left(strVar, Len(strVar) - 1)
If strVar = "|" Then strVar = ""
GetLDAPValue = strVar
End Function
Private Sub List1_Click()
'
' Change List's ToolTipText with default text
'
List1.ToolTipText = "Выберите пользователя"
'
' Clear some other values
'
lblAltRecipient.Caption = ""
lblAltRecipient.ToolTipText = ""
'
' Get user's displayName (in WinNT provider can be accessed via FullName)
'
strDisplayName = List1.List(List1.ListIndex)
'
' Get user's email
'
strmail = GetLDAPValue("mail", "displayName='" & strDisplayName & "'")
'
' If user's email is not empty - show it in list's tooltiptext where all users are shown
'
If strmail <> "" Then List1.ToolTipText = strmail
'
' Now check if user already have set altRecipient
'
strUserDN = GetLDAPValue("altRecipient", "displayName='" & strDisplayName & "'")
'
' If not - exit this sub
'
If strUserDN = "" Then Exit Sub
'
' If set - connect to this object in AD
' because altRecipient always set as some user distinguishedName if not empty
'
Set objUser = GetObject("LDAP://" & strUserDN)
'
' Let's show if we have altRecipient (get his displayName)
'
lblAltRecipient.Caption = objUser.DisplayName
'
' And show this user's email in ToolTipText
'
lblAltRecipient.ToolTipText = objUser.mail
'
' Show some black-to-red blinking
'
intdefcolor = lblAltRecipient.ForeColor
red = "&H000000FF"
lblAltRecipient.ForeColor = red
Sleep 500
lblAltRecipient.ForeColor = intdefcolor
Sleep 500
lblAltRecipient.ForeColor = red
Sleep 500
lblAltRecipient.ForeColor = intdefcolor
'lblAltRecipient.Caption = strDisplayName
End Sub
Sub Sleep(how_much)
'
' I do not remember internal Sleep function so I wrote it
' incoming parameter - miliseconds
'
x = Timer
Do
If Timer - x >= how_much / 1000 Then Exit Do
'
' Next line means - do not hangup while in cycle. Let other application do some work too
'
DoEvents
Loop
End Sub
Sub shake(object As Object, delta)
'
' 'Shake' an object means lift it left-right-up-down not much than delta
'
On Error Resume Next
xTop = object.Top
xLeft = object.Left
For i = 1 To 50
xDelta = (Rnd(Timer) * (delta \ 2)) - delta
yDelta = (Rnd(Timer) * (delta \ 2)) - delta
'
' Top and Left property of object cann't be lower than 0
'
If xTop + yDelta < 0 Then object.Top = 0 Else object.Top = xTop + yDelta
If xLeft + xDelta < 0 Then object.Left = 0 Else object.Left = xLeft + xDelta
'
' Get some sleep so user could see this shaking
'
Sleep 10
Next
'
' Turn back previously saved values
'
object.Top = xTop
object.Left = xLeft
End Sub
Private Sub txtFilterField_Change()
'
' Very cool search algorithm
'
If txtFilterField.Text <> "" And txtFilterField.Text <> "Filter-field" Then
'
' If anything is changed in search field - pass-through the list items and find first list item, which begins with searching text
' case-insensitive
'
strFilter = UCase(txtFilterField.Text)
For i = 0 To List1.ListCount - 1
If Len(List1.List(i)) >= Len(strFilter) Then
If UCase(Left(List1.List(i), Len(strFilter))) = strFilter Then List1.ListIndex = i: Exit Sub
End If
Next
End If
If txtFilterField.Text = "" Then List1.ListIndex = 0
End Sub
Private Sub txtFilterField_GotFocus()
'
'
'
If txtFilterField.Text = "Filter-field" Then txtFilterField.Text = ""
End Sub
Private Sub txtFilterField_LostFocus()
'
'
'
If txtFilterField.Text = "" Then txtFilterField.Text = "Filter-field"
End Sub
Sub Blink_object_background(obj As Object)
intOriginalColor = obj.BackColor
red = "&H000000FF"
For i = 1 To 3
obj.BackColor = red
Sleep 250
obj.BackColor = intOriginalColor
Sleep 250
Next
End Sub
Function CheckDate(strDate) As Boolean
'
' Checking date is valid
'
Dim days As String
Dim strDay As Integer
Dim strMonth As Integer
Dim strYear As Integer
CheckDate = False
days = "31;28;31;30;31;30;31;31;30;31;30;31"
arrDays = Split(days, ";")
arrDate = Split(strDate, "-")
If UBound(arrDate) < 2 Then Exit Function
strDay = arrDate(0)
strMonth = arrDate(1)
strYear = arrDate(2)
'Stop
If strYear Mod 4 = 0 Then arrDays(1) = 29
If strDay < 1 Or strDat > arrDays(strMonth - 1) Then Exit Function
If strMonth < 1 Or strMonth > 12 Then Exit Function
CheckDate = True
End Function
Function IsUserValid(strUser)
IsUserValid = False
strUserAcc = GetLDAPValue("sAMAccountName", "displayName='" & strUser & "'")
If strUserAcc = "" Or strUserAcc = "|" Then Exit Function
Set objNet = CreateObject("Wscript.Network")
strUserDomain = objNet.UserDomain
Set objUser = GetObject("WinNT://" & strUserDomain & "/" & strUserAcc)
IsUserValid = Not objUser.AccountDisabled
End Function
[/code]
Ок, вот Вам код - запускайте каждый час с ключом /SCHEDULE. Если без ключа - получите форму для управления списком.
Проект написан на VB6.
Сохранить в новой форме и все.
[code]
VERSION 5.00
Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
Begin VB.Form Form1
AutoRedraw = -1 'True
BorderStyle = 3 'Fixed Dialog
Caption = "On-Vacation Replacement"
ClientHeight = 9105
ClientLeft = 45
ClientTop = 375
ClientWidth = 7950
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 9105
ScaleWidth = 7950
StartUpPosition = 3 'Windows Default
Begin VB.TextBox txtFilterField
Appearance = 0 'Flat
Height = 495
Left = 120
TabIndex = 1
Text = "Filter-field"
ToolTipText = "Поле для фильтрации"
Top = 5280
Width = 2895
End
Begin VB.CommandButton Command6
Caption = "Показать расписание"
Height = 495
Left = 2760
TabIndex = 8
Top = 5880
Width = 3015
End
Begin VB.TextBox txtcfgFile
Height = 2535
Left = 120
MultiLine = -1 'True
TabIndex = 9
Top = 6480
Width = 7695
End
Begin VB.CommandButton Command5
Caption = "Добавить переадресацию"
Height = 495
Left = 120
TabIndex = 7
Top = 5880
Width = 2535
End
Begin VB.TextBox txtDateTo
Appearance = 0 'Flat
Enabled = 0 'False
Height = 375
Left = 5760
TabIndex = 16
TabStop = 0 'False
Top = 5280
Width = 2055
End
Begin VB.CommandButton Command4
Caption = "По какое число"
Height = 375
Left = 5760
TabIndex = 6
Top = 4800
Width = 2055
End
Begin VB.CommandButton Command3
Caption = "С какого числа"
Height = 375
Left = 5760
TabIndex = 5
Top = 3720
Width = 2055
End
Begin VB.TextBox txtDateFrom
Appearance = 0 'Flat
Enabled = 0 'False
Height = 375
Left = 5760
TabIndex = 15
TabStop = 0 'False
Top = 4200
Width = 2055
End
Begin MSComCtl2.MonthView MonthView1
Height = 2310
Left = 3240
TabIndex = 4
Top = 3480
Width = 2415
_ExtentX = 4260
_ExtentY = 4075
_Version = 393216
ForeColor = -2147483630
BackColor = -2147483632
Appearance = 0
ShowWeekNumbers = -1 'True
StartOfWeek = 53149698
CurrentDate = 42284
End
Begin VB.TextBox txtVacationTo
Appearance = 0 'Flat
Enabled = 0 'False
Height = 375
Left = 3120
TabIndex = 14
TabStop = 0 'False
ToolTipText = "Этому пользователю будет перенаправлена почта пользователя уходящего в отпуск."
Top = 3000
Width = 4695
End
Begin VB.TextBox txtVacationFrom
Appearance = 0 'Flat
Enabled = 0 'False
Height = 375
Left = 3120
TabIndex = 13
TabStop = 0 'False
ToolTipText = "Этот пользователь в отпуске. Его почту необходимо перенаправлять в другой почтовый ящик"
Top = 1920
Width = 4695
End
Begin VB.CommandButton Command2
Appearance = 0 'Flat
Caption = "Этот пользователь замещает"
Height = 495
Left = 3120
TabIndex = 3
Top = 2400
Width = 4695
End
Begin VB.CommandButton Command1
Appearance = 0 'Flat
Caption = "Этот пользователь в отпуске"
Height = 495
Left = 3120
TabIndex = 2
Top = 1320
Width = 4695
End
Begin VB.ListBox List1
Appearance = 0 'Flat
Height = 4710
ItemData = "Form1.frx":0000
Left = 120
List = "Form1.frx":0002
Sorted = -1 'True
TabIndex = 0
ToolTipText = "Выберите пользователя"
Top = 480
Width = 2895
End
Begin VB.Label Label1
Caption = "Почта перенаправлена следующему пользователю:"
Height = 495
Left = 3360
TabIndex = 12
Top = 120
Width = 3255
End
Begin VB.Label lblAltRecipient
Height = 375
Left = 3360
TabIndex = 11
Top = 720
Width = 3375
End
Begin VB.Label lblDomain
Caption = "Label1"
Height = 255
Left = 120
TabIndex = 10
Top = 120
Width = 2895
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public strFile As String
Function ReadSchedules()
On Error Resume Next
Err.Clear
Open strFile For Input As #1
If Not Err.Number = 0 Then Exit Function
Do While Not EOF(1)
Line Input #1, strTemp
ReadSchedules = ReadSchedules & strTemp & vbCrLf
Loop
Close #1
End Function
Sub WriteNewSchedule(strString)
'
' After all checks in other prodecures we can finally write new schedule for our program
'
Open strFile For Append As #1
Print #1, strString
Close #1
End Sub
Function FindDuplicates(strString)
'
' Here we will check if we have already scheduled job with absolutely same parameters
' This means, that everything is equal: user-from;user-to;date-from;date-to
'
FindDuplicates = False
Open strFile For Input As #1
Do While Not EOF(1)
Line Input #1, strTemp
If LCase(strTemp) = LCase(strString) Then FindDuplicates = True: Exit Do
Loop
Close #1
End Function
Sub SetCfgFile()
strFile = App.Path
If Right(strFile, 1) = "\" Then strFile = Left(strFile, Len(strFile) - 1)
strFile = strFile & "\ovr.cfg"
End Sub
Private Sub Command1_Click()
'
' Users must not to be equal
'
txtVacationFrom.Text = List1.List(List1.ListIndex)
If LCase(txtVacationFrom.Text) = LCase(txtVacationTo.Text) Then
'
' Otherwise - blink
'
txtVacationTo.Text = ""
Blink_object_background txtVacationFrom
Exit Sub
End If
End Sub
Private Sub Command2_Click()
'
' Users must not be equal
'
txtVacationTo.Text = List1.List(List1.ListIndex)
If LCase(txtVacationFrom.Text) = LCase(txtVacationTo.Text) Then
'
' Otherwise - blink
'
txtVacationTo.Text = ""
Blink_object_background txtVacationFrom
Exit Sub
End If
End Sub
Private Sub Command3_Click()
'
' Check selected day-month-year
'
strDay = MonthView1.Day
strMonth = MonthView1.Month
strYear = MonthView1.Year
If strDay < 10 Then strDay = "0" & strDay
If strMonth < 10 Then strMonth = "0" & strMonth
strDateFrom = strDay & "-" & strMonth & "-" & strYear
txtDateFrom.Text = strDateFrom
'
' Date From must to lower than Date To
'
If txtDateFrom.Text = txtDateTo.Text Then
'
' Otherwise - blink
'
txtDateTo.Text = ""
Blink_object_background txtDateFrom
End If
If txtDateFrom.Text > txtDateTo.Text And txtDateTo.Text <> "" Then Blink_object_background txtDateFrom
End Sub
Private Sub Command4_Click()
'
' The same as Command3_Click() but working with other field
'
strDay = MonthView1.Day
strMonth = MonthView1.Month
strYear = MonthView1.Year
If strDay < 10 Then strDay = "0" & strDay
If strMonth < 10 Then strMonth = "0" & strMonth
strDateTo = strDay & "-" & strMonth & "-" & strYear
txtDateTo.Text = strDateTo
If txtDateFrom.Text = txtDateTo.Text Then
txtDateTo.Text = ""
Blink_object_background txtDateFrom
End If
If txtDateFrom.Text > txtDateTo.Text And txtDateTo.Text <> "" Then Blink_object_background txtDateFrom
End Sub
Private Sub Command5_Click()
On Error Resume Next
'
' Finally check all again
'
strUserFrom = txtVacationFrom.Text
strUserTo = txtVacationTo.Text
strDateFrom = txtDateFrom.Text
strDateTo = txtDateTo.Text
If strDateFrom >= strDateTo Then txtDateTo.Text = "": Blink_object_background Form1.txtDateTo: Exit Sub
If strDateFrom = "" Then Blink_object_background Form1.txtDateFrom: Exit Sub
If strDateTo = "" Then Blink_object_background Form1.txtDateTo: Exit Sub
If strUserFrom = "" Then Blink_object_background Form1.txtVacationFrom: Exit Sub
If strUserTo = "" Then Blink_object_background Form1.txtVacationTo: Exit Sub
If LCase(strUserFrom) = LCase(strUserTo) Then Blink_object_background Form1.txtVacationTo: txtVacationTo.Text = "": Exit Sub
strString = strUserFrom & ";" & strUserTo & ";" & strDateFrom & ";" & strDateTo
If FindDuplicates(strString) = True Then MsgBox ("Такая комбинация пользователь1;пользователь2;дата1;дата2 уже есть"): Exit Sub
'
' Passed
'
WriteNewSchedule (strString)
txtcfgFile.Text = ReadSchedules
End Sub
Private Sub Command6_Click()
'
' Read config file and show in text-box
' Even if user will change it - it doesn't matter. Enabled if this text-box set to True
' because in other case user will not be able to scroll text-box
'
SetCfgFile
txtcfgFile.Text = ReadSchedules
End Sub
Private Sub Form_Load()
On Error Resume Next
Const ADS_PROPERTY_CLEAR = 1
'
' Go check for some command-line arguments
'
strCmd = Command
'
' And if we got only one special command-line argument - go ahead, do your job.
'
If UCase(strCmd) = "/SCHEDULE" Then
'
' Get CFG File name and path
'
SetCfgFile
'
' Load everything from this file
'
a = ReadSchedules
'
' Split it and load into array
'
b = Split(a, vbCrLf)
'MsgBox ("Number of lines in file: " & UBound(b))
'
' Retrieve everyline and go into a cycle
'
i = 0
Do While i < UBound(b)
'If i >= UBound(b) Then MsgBox (i): Exit Do
'
' Now we need to parse CSV (Comma-Separated) File. Comma=";"
'
c = Split(b(i), ";")
'
' There is a cycle to easyly parse stupid checks below
'
For j = 1 To 1
user1 = LTrim(RTrim(c(0)))
user2 = LTrim(RTrim(c(1)))
datefrom = c(2)
dateto = c(3)
'
' Stupid checks but doing it
'
If CheckDate(datefrom) = False Then Exit For
If CheckDate(dateto) = False Then Exit For
If datefrom > dateto Then Exit For
If datefrom = dateto Then Exit For
If IsUserValid(user1) = False Then Exit For
If IsUserValid(user2) = False Then Exit For
If UCase(user1) = UCase(user2) Then Exit For
strUser1DN = GetLDAPValue("distinguishedName", "displayName='" & user1 & "'")
strUser2DN = GetLDAPValue("distinguishedName", "displayName='" & user2 & "'")
strDate = Date
dateto = CDate(dateto)
datefrom = CDate(datefrom)
If strDate = dateto Then
'
' Clear user1 AltRecipient field
'
Set objUser = GetObject("LDAP://" & strUser1DN)
objUser.PutEx ADS_PROPERTY_CLEAR, "altRecipient", 0
objUser.PutEx ADS_PROPERTY_CLEAR, "deliverAndRedirect", 0
objUser.SetInfo
ElseIf ((strDate >= datefrom) And (strDate < dateto)) Then
'
' Set user1 AltRecipient with user2 distinguishedName
'
Set objUser = GetObject("LDAP://" & strUser1DN)
objUser.Put "altRecipient", strUser2DN
objUser.Put "deliverAndRedirect", "TRUE"
objUser.SetInfo
End If
Next
i = i + 1
Loop
End
End If
'
' Auto-center form on load
'
Form1.Left = (Screen.Width - Form1.Width) \ 2
Form1.Top = (Screen.Height - Form1.Height) \ 2
'
' Read userlist from AD
'
Read_Users
'
' Set very important variable
'
SetCfgFile
End Sub
Sub Read_Users()
On Error Resume Next
'
' clear list
'
For i = 0 To Form1.List1.ListCount - 1
Form1.List1.RemoveItem (0)
Next
'
' Create network object
'
Set objNet = CreateObject("Wscript.Network")
'
' Get User's Domain
'
strDomain = objNet.UserDomain
'
' Connect to domain
'
Set objDomain = GetObject("WinNT://" & strDomain)
'
' Get object collection
'
For Each object In objDomain
'
' Filter only users
'
If LCase(object.Class) = "user" Then
'
' User's account must be enabled
'
If object.AccountDisabled = False Then
'
' Get user's email. That means that user must have email
'
strmail = GetLDAPValue("mail", "sAMAccountName='" & object.Name & "'")
'
' Filter only *@npcprom.ru users
'
If InStr(1, LCase(strmail), "@npcprom.ru") > 0 Then
'MsgBox (strMail)
'
' Check if user already have altRecipient
'
'strAlt = ""
'strAlt = GetLDAPValue("altRecipient", "sAMAccountName='" & object.Name & "'")
'If strAlt <> "" Then MsgBox (object.Name & vbCrLf & strAlt)
'
' If user have no altRecipient we can assign it
'
' Add to List1
'If strAlt = "" Then
Form1.List1.AddItem object.FullName
Counter = Counter + 1
Else
'
' not @npcprom.ru mailbox
'
End If
End If
End If
Next
'
' Show domain name and number of found users
'
Form1.lblDomain.Caption = UCase(objNet.UserDomain) & " (" & Counter & ")"
End Sub
Function GetLDAPDomain()
Set iAdRootDSE = GetObject("LDAP://RootDSE")
GetLDAPDomain = iAdRootDSE.Get("defaultNamingContext")
End Function
Function GetLDAPValue(strValue, strFilter)
Const ADS_SCOPE_SUBTREE = 2
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
strQuery = "SELECT " & strValue & " FROM 'LDAP://" & GetLDAPDomain & "' WHERE " & strFilter
objCommand.CommandText = strQuery
Set objRecordSet = objCommand.Execute
Do Until objRecordSet.EOF
strVar = strVar & objRecordSet.Fields(strValue).Value & "|"
objRecordSet.MoveNext
Loop
If Len(strVar) > 1 Then strVar = Left(strVar, Len(strVar) - 1)
If strVar = "|" Then strVar = ""
GetLDAPValue = strVar
End Function
Private Sub List1_Click()
'
' Change List's ToolTipText with default text
'
List1.ToolTipText = "Выберите пользователя"
'
' Clear some other values
'
lblAltRecipient.Caption = ""
lblAltRecipient.ToolTipText = ""
'
' Get user's displayName (in WinNT provider can be accessed via FullName)
'
strDisplayName = List1.List(List1.ListIndex)
'
' Get user's email
'
strmail = GetLDAPValue("mail", "displayName='" & strDisplayName & "'")
'
' If user's email is not empty - show it in list's tooltiptext where all users are shown
'
If strmail <> "" Then List1.ToolTipText = strmail
'
' Now check if user already have set altRecipient
'
strUserDN = GetLDAPValue("altRecipient", "displayName='" & strDisplayName & "'")
'
' If not - exit this sub
'
If strUserDN = "" Then Exit Sub
'
' If set - connect to this object in AD
' because altRecipient always set as some user distinguishedName if not empty
'
Set objUser = GetObject("LDAP://" & strUserDN)
'
' Let's show if we have altRecipient (get his displayName)
'
lblAltRecipient.Caption = objUser.DisplayName
'
' And show this user's email in ToolTipText
'
lblAltRecipient.ToolTipText = objUser.mail
'
' Show some black-to-red blinking
'
intdefcolor = lblAltRecipient.ForeColor
red = "&H000000FF"
lblAltRecipient.ForeColor = red
Sleep 500
lblAltRecipient.ForeColor = intdefcolor
Sleep 500
lblAltRecipient.ForeColor = red
Sleep 500
lblAltRecipient.ForeColor = intdefcolor
'lblAltRecipient.Caption = strDisplayName
End Sub
Sub Sleep(how_much)
'
' I do not remember internal Sleep function so I wrote it
' incoming parameter - miliseconds
'
x = Timer
Do
If Timer - x >= how_much / 1000 Then Exit Do
'
' Next line means - do not hangup while in cycle. Let other application do some work too
'
DoEvents
Loop
End Sub
Sub shake(object As Object, delta)
'
' 'Shake' an object means lift it left-right-up-down not much than delta
'
On Error Resume Next
xTop = object.Top
xLeft = object.Left
For i = 1 To 50
xDelta = (Rnd(Timer) * (delta \ 2)) - delta
yDelta = (Rnd(Timer) * (delta \ 2)) - delta
'
' Top and Left property of object cann't be lower than 0
'
If xTop + yDelta < 0 Then object.Top = 0 Else object.Top = xTop + yDelta
If xLeft + xDelta < 0 Then object.Left = 0 Else object.Left = xLeft + xDelta
'
' Get some sleep so user could see this shaking
'
Sleep 10
Next
'
' Turn back previously saved values
'
object.Top = xTop
object.Left = xLeft
End Sub
Private Sub txtFilterField_Change()
'
' Very cool search algorithm
'
If txtFilterField.Text <> "" And txtFilterField.Text <> "Filter-field" Then
'
' If anything is changed in search field - pass-through the list items and find first list item, which begins with searching text
' case-insensitive
'
strFilter = UCase(txtFilterField.Text)
For i = 0 To List1.ListCount - 1
If Len(List1.List(i)) >= Len(strFilter) Then
If UCase(Left(List1.List(i), Len(strFilter))) = strFilter Then List1.ListIndex = i: Exit Sub
End If
Next
End If
If txtFilterField.Text = "" Then List1.ListIndex = 0
End Sub
Private Sub txtFilterField_GotFocus()
'
'
'
If txtFilterField.Text = "Filter-field" Then txtFilterField.Text = ""
End Sub
Private Sub txtFilterField_LostFocus()
'
'
'
If txtFilterField.Text = "" Then txtFilterField.Text = "Filter-field"
End Sub
Sub Blink_object_background(obj As Object)
intOriginalColor = obj.BackColor
red = "&H000000FF"
For i = 1 To 3
obj.BackColor = red
Sleep 250
obj.BackColor = intOriginalColor
Sleep 250
Next
End Sub
Function CheckDate(strDate) As Boolean
'
' Checking date is valid
'
Dim days As String
Dim strDay As Integer
Dim strMonth As Integer
Dim strYear As Integer
CheckDate = False
days = "31;28;31;30;31;30;31;31;30;31;30;31"
arrDays = Split(days, ";")
arrDate = Split(strDate, "-")
If UBound(arrDate) < 2 Then Exit Function
strDay = arrDate(0)
strMonth = arrDate(1)
strYear = arrDate(2)
'Stop
If strYear Mod 4 = 0 Then arrDays(1) = 29
If strDay < 1 Or strDat > arrDays(strMonth - 1) Then Exit Function
If strMonth < 1 Or strMonth > 12 Then Exit Function
CheckDate = True
End Function
Function IsUserValid(strUser)
IsUserValid = False
strUserAcc = GetLDAPValue("sAMAccountName", "displayName='" & strUser & "'")
If strUserAcc = "" Or strUserAcc = "|" Then Exit Function
Set objNet = CreateObject("Wscript.Network")
strUserDomain = objNet.UserDomain
Set objUser = GetObject("WinNT://" & strUserDomain & "/" & strUserAcc)
IsUserValid = Not objUser.AccountDisabled
End Function
[/code]
Комментариев нет:
Отправить комментарий