Загрузка фотографий в 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]