Получение списка адресов электронной почты из Active Directory в Delphi 7

Под этим способом подразумевается получение списка адресов электронной почты из Active Directory с использованием скрипта VBScript и передача этого списка в Delphi программу для дальнейшей обработки.

Теперь приступим к реализации этого способа.

Нам необходимо разработать VBScript для получения списка адресов электронной почты из Active Directory. Назовём этот скрипт main.vbs.

Ниже показан код скрипта main.vbs:

function GetADMailString()

On Error Resume Next

Dim adoCommand, adoConnection, strBase, strFilter, strAttributes
Dim objRootDSE, strDNSDomain, strQuery, adoRecordset, strMail
Dim strResult

' Setup ADO objects.
Set adoCommand = CreateObject("ADODB.Command")
Set adoConnection = CreateObject("ADODB.Connection")
adoConnection.Provider = "ADsDSOObject"
adoConnection.Open "Active Directory Provider"
Set adoCommand.ActiveConnection = adoConnection

' Search entire Active Directory domain.
Set objRootDSE = GetObject("LDAP://RootDSE")

If Err.Number <> 0 Then
 GetADMailString = ""
Else
 
 strDNSDomain = objRootDSE.Get("defaultNamingContext")
 strBase = "<LDAP://" & strDNSDomain & ">"

 ' Filter on user objects.
 strFilter = "(&(objectCategory=person)(objectClass=user) (mail=*))"

 ' Comma delimited list of attribute values to retrieve.
 strAttributes = "mail"

 ' 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.
  strMail = adoRecordset.Fields("mail").Value
  
  If strMail <> "" Then
   strResult = strResult & strMail & vbCrLf
  End if
  ' Move to the next record in the recordset.
  adoRecordset.MoveNext
 Loop
 ' Clean up.
 adoRecordset.Close
 adoConnection.Close
 
 GetADMailString = strResult
end if

end function

Теперь пройдемся вкратце по коду скрипта main.vbs и функции GetADMailString

1. Объявляем необходимые переменные для работы скрипта, смотрите часть кода ниже:

On Error Resume Next

Dim adoCommand, adoConnection, strBase, strFilter, strAttributes
Dim objRootDSE, strDNSDomain, strQuery, adoRecordset, strMail
Dim strResult

2. Осуществляем подключение к Active Directory

' Setup ADO objects.
Set adoCommand = CreateObject("ADODB.Command")
Set adoConnection = CreateObject("ADODB.Connection")
adoConnection.Provider = "ADsDSOObject"
adoConnection.Open "Active Directory Provider"
Set adoCommand.ActiveConnection = adoConnection

3. Получаем домен по умолчанию

' Search entire Active Directory domain.
Set objRootDSE = GetObject("LDAP://RootDSE")

If Err.Number <> 0 Then
    GetADMailString = ""
Else
   
    strDNSDomain = objRootDSE.Get("defaultNamingContext")
    strBase = "<LDAP://" & strDNSDomain & ">"

4. Формируем запрос и выполняем его для получения строки со всеми почтовыми адресами из Active Directory

' Filter on user objects.
    strFilter = "(&(objectCategory=person)(objectClass=user) (mail=*))"

    ' Comma delimited list of attribute values to retrieve.
    strAttributes = "mail"

    ' 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   

5. Формируем строку из всех почтовых адресов

' Enumerate the resulting recordset.
    Do Until adoRecordset.EOF
        ' Retrieve values and display.
        strMail = adoRecordset.Fields("mail").Value
       
        If strMail <> "" Then
            strResult = strResult & strMail & vbCrLf
        End if
        ' Move to the next record in the recordset.
        adoRecordset.MoveNext
    Loop

6. Закрываем соединение с Active Directory и возвращаем результат выполнения скрипта main.vbs

    ' Clean up.
    adoRecordset.Close
    adoConnection.Close
   
    GetADMailString = strResult
end if

end function

Так со скриптом main.vbs мы разобрались. Теперь нам необходимо передать результат выполнения скрипта в нашу программу и сохранить все почтовые адреса в текстовый файл.

Создайте проект на в среде Delphi 7 и сохраните его под именем p22.dpr. Основной модуль программы сохраните под именем p22_unit1.pas. Файл скрипта main.vbs должен лежать в той же директории, что и файл проекта, и исполняемый файл программы.

На форму с именем Form1 необходимо перетащить компонент ScriptControl. Я уже писал, как установить данный компонент и задействовать его в проекте (Смотрите статью http://notidealrunner.blogspot.com/2019/05/vbscripts-delphi.html).  Вкратце опишу основные моменты работы программы.

1. В обработчике показа формы мы проверяем существует ли скрипт main.vbs, открываем его на чтение, считываем его построчно.

procedure TForm1.FormShow(Sender: TObject);
var
    ScriptFile: TextFile;
    Script, LineScript: String;
    SA : TSafeArrayBound;
    pPar:PSafeArray;
    res:Variant;
begin
    AssignFile(ScriptFile,'main.vbs');
    Reset(ScriptFile);
    if IOResult <> 0 then
    begin
      MessageBox(0,'File access error.','Error',0);
      exit;
    end;

    while not EOF(ScriptFile) do
    begin
      readln(ScriptFile, LineScript);
      Script := Script + LineScript+#13+#10;
    end;
    CloseFile(ScriptFile);

2. Далее выполняем скрипт mian.vbs и функцию GetADMailString. Получаем результат выполнения скрипта и сохраняем в строковую переменную strTemp.   

    try
      ScriptControl1.Language := 'VBScript';
      ScriptControl1.AddCode(Script);
      SA.cElements := 0;
      pPar := SafeArrayCreate(varVariant, 1, SA);
      res:=ScriptControl1.Run('GetADMailString',pPar);
      strTemp := VarToStr(res);
    except
      on E: Exception do
        MessageDlg(PWideChar(E.Message), mtError, [mbOK], 0);
    end;

3. Далее передаем строковую переменную strTemp в процедуру сохранения в текстовый файл.

StrToFile('Mail.txt', strTemp); 

Ниже код процедуры сохранения строки в файл (Код процедуры взят с сайта https://stackoverflow.com/questions/7752273/how-to-save-a-string-to-a-txt-file-in-delphi).

procedure StrToFile(const FileName, SourceString : string);
var
  Stream : TFileStream;
begin
  Stream:= TFileStream.Create(FileName, fmCreate);
  try
    Stream.WriteBuffer(Pointer(SourceString)^, Length(SourceString));
  finally
    Stream.Free;
  end;
end;

Вот и все. Список всех электронных почтовых адресов будет сохранен в файл Mail.txt в директории проекта. Ниже показан код проекта полностью.

unit p22_unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, OleCtrls, MSScriptControl_TLB, ActiveX;

type
  TForm1 = class(TForm)
    ScriptControl1: TScriptControl;
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure StrToFile(const FileName, SourceString : string);
var
  Stream : TFileStream;
begin
  Stream:= TFileStream.Create(FileName, fmCreate);
  try
    Stream.WriteBuffer(Pointer(SourceString)^, Length(SourceString));
  finally
    Stream.Free;
  end;
end;

var
  strTemp: String;

procedure TForm1.FormShow(Sender: TObject);
var
    ScriptFile: TextFile;
    Script, LineScript: String;
    SA : TSafeArrayBound;
    pPar:PSafeArray;
    res:Variant;
begin
    AssignFile(ScriptFile,'main.vbs');
    Reset(ScriptFile);
    if IOResult <> 0 then
    begin
      MessageBox(0,'File access error.','Error',0);
      exit;
    end;

    while not EOF(ScriptFile) do
    begin
      readln(ScriptFile, LineScript);
      Script := Script + LineScript+#13+#10;
    end;
    CloseFile(ScriptFile);

    try
      ScriptControl1.Language := 'VBScript';
      ScriptControl1.AddCode(Script);
      SA.cElements := 0;
      pPar := SafeArrayCreate(varVariant, 1, SA);
      res:=ScriptControl1.Run('GetADMailString',pPar);
      strTemp := VarToStr(res);
    except
      on E: Exception do
        MessageDlg(PWideChar(E.Message), mtError, [mbOK], 0);
    end;

    StrToFile('Mail.txt', strTemp);
end;

end.