Перенаправление почты в Exchange 2003 по расписанию

Задача: пользователь уйдет в отпуск с 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]

Загрузка фотографий в Active Directory (автоматически)

Проект написан на VB6.
Запускать от лица админа или от лица, которому разрешено исправлять thumbnailPhoto аттрибут у других пользователей.
Также нужны права на запись в папку, где хранятся фотки для создания временных файлов.
Можете допилить создание временных файлов в любом удобно для Вас месте.

[code]
Attribute VB_Name = "Модуль1"
Private Function ResizeImage(ByVal Original As WIA.ImageFile, ByVal WidthPixels As Long, ByVal HeightPixels As Long) As WIA.ImageFile
    On Error Resume Next
    With New WIA.ImageProcess
        .Filters.Add .FilterInfos!Scale.FilterID
        With .Filters(1).Properties
            !MaximumWidth = WidthPixels
            !MaximumHeight = HeightPixels
        End With
        Set ResizeImage = .Apply(Original)
    End With
End Function

Sub UpdateMe(strUserDN As String, strFile As String)
    On Error Resume Next
    Dim adoStreamRead As Object
    Dim objUser As Object
    Dim bytesRead As String
 
    Const adTypeBinary = 1
    Set objUsr = GetObject("LDAP://" & strUserDN)
    Set adoStreamRead = CreateObject("ADODB.Stream")
    Err.Clear
    adoStreamRead.Type = adTypeBinary
    adoStreamRead.Open
 
    If Err.Number = 0 Then
        adoStreamRead.LoadFromFile strFile
        objUsr.Put "thumbnailPhoto", adoStreamRead.read()
    Else
        objUsr.PutEx ADS_PROPERTY_CLEAR, "thumbnailPhoto", 0
    End If
    objUsr.SetInfo
    adoStreamRead.Close
    Set objUsr = Nothing
    Set adoStreamRead = Nothing
 
End Sub

'
' Some LDAP functions
'
Function GetUserDN(strUser As String) As String
    GetUserDN = GetLDAPValue("distinguishedName", "sAMAccountName ='" & strUser & "'")
End Function
Function GetLDAPValue(strValue As String, strFilter As String)
    On Error Resume Next
    Dim objConnection As Object
    Dim objCommand As Object
    Dim objRecordSet As Object
    Dim strQuery As String
    Dim strVar As String
    Const ADS_SCOPE_SUBTREE = 2
    GetLDAPValue = ""
    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)
    GetLDAPValue = strVar
    Set objRecordSet = Nothing
    Set objCommand = Nothing
    Set objConnection = Nothing
End Function

Function GetLDAPDomain() As String
    On Error Resume Next
    Dim iAdRootDSE As Object
    Set iAdRootDSE = GetObject("LDAP://RootDSE")
    GetLDAPDomain = iAdRootDSE.Get("defaultNamingContext")
    Set iAdRootDSE = Nothing
End Function

Sub Resize_and_Save(strFile As String)
    On Error Resume Next
    Dim imgPhoto As Object
    Set imgPhoto = New WIA.ImageFile
    imgPhoto.LoadFile strFile
    Set imgPhoto = ResizeImage(imgPhoto, 100, 100)
    imgPhoto.SaveFile strFile & "_min"
    Set imgPhoto = Nothing
End Sub
Sub Main()
    Dim objFSO As Object
    Dim strFolder As String
    Dim objFolder As Object
    Dim objFiles As Object
    Dim objFile As Object
    Dim strExt As String
    Dim strUser As String
    Dim strUserDN As String

    Set objFSO = CreateObject("Scripting.Filesystemobject")
' Next UNC MUST be enabled for writing!!!
    strFolder = "\\SERVER\FOTO_FOLDER"
    Set objFolder = objFSO.GetFolder(strFolder)
    Set objFiles = objFolder.Files
 
    For Each objFile In objFiles
        DoEvents
        a = Split(objFile.Name, ".")
        strExt = UCase(a(UBound(a)))
        If strExt = "JPG" And Len(objFile.Name) > 4 Then
            strUser = a(0)
            strUserDN = GetLDAPValue("distinguishedName", "displayName='" & strUser & "'")
            If objFSO.FileExists(strFolder & "\" & objFile.Name & "_min") = True Then objFSO.DeleteFile strFolder & "\" & objFile.Name & "_min"
            If objFile.Size > 0 Then
                Resize_and_Save strFolder & "\" & objFile.Name
                UpdateMe strUserDN, strFolder & "\" & objFile.Name & "_min"
                objFSO.DeleteFile strFolder & "\" & objFile.Name & "_min"
            End If
        End If
    Next
    Set objFile = Nothing
    Set objFiles = Nothing
    Set objFolder = Nothing
    Set objFSO = Nothing
    End
End Sub
[/code]