I'm trying to get the e-mail address of a user by using sAMAccountName from Active Directory but I'm getting this error message:
The directory property cannot be found in the cache.
I can get fullname, department and discretion, but why am I getting this error for e-mail ?
uses
ActiveDs_TLB, adshlp;
procedure TMainForm.btnFillInfoClick(Sender: TObject);
var
Usr: IAdsUser;
lStr: HRESULT;
xStrg: string;
ChkPRN: string;
RemoveDot: string;
begin
//connect to AD and try exrtact the info /
lStr := ADsGetObject('WinNT://10.120.200.16/'+edtPRN.Text, IADsUser, usr); // edtPRN.Text >> sAMAccountName
if Succeeded(lStr) then
begin
Usr.GetInfo;
EmpFullName := Usr.FullName;
RemoveDot := StringReplace(EmpFullName, '.', '',[rfReplaceAll, rfIgnoreCase]);
xStrg := Usr.FullName;
edtLastName.Text := GetLastWord(xStrg);
xStrg := StringReplace(RemoveDot, edtLastName.Text, '',[rfReplaceAll, rfIgnoreCase]);
EdtMidName.Text := GetLastWord(xStrg);
xStrg := StringReplace(RemoveDot, EdtMidName.Text, '',[rfReplaceAll, rfIgnoreCase]);
xStrg := StringReplace(xStrg, edtLastName.Text, '',[rfReplaceAll, rfIgnoreCase]);
edtFirstName.Text := GetLastWord(xStrg);
edtEmail.Text := Usr.EmailAddress; // <<<<< this is the error
end;
end;
The email address attribute is not available using WinNT:// provider, you need to use LDAP:// provider. The name of the attribute is 'mail' not 'emailaddress'. Here is a link to ASDI and Delphi. ASDI examples.
Related
A program running on computer "A" wants to download a file "F" in map "M" from computer "B".
I use the following preparaions:
dlgSelectImportFile.InitialDir := '\\192.168.1.59';
dlgSelectImportFile.Options :=[ofOldStyleDialog];
As computer "B" wants authorization I get the Windows-Security-dialog.
I want to avoid this by giving the correct username and password automatically.
I guess there is something in the API of this dialog that could help here but I have not found anything.
You can store the credentials in the Credential Vault, here is some sample code (uses Jedi Apilib):
procedure StoreCredentials(const Server: String; const Username: String; const Password: String);
var
CredTargetInfo: CREDENTIAL_TARGET_INFORMATION;
Creds: CREDENTIAL;
CredType: DWORD;
bRes: Boolean;
LastError: DWORD;
begin
CredType := CRED_TYPE_DOMAIN_PASSWORD;
ZeroMemory(#CredTargetInfo, sizeof(CredTargetInfo));
CredTargetInfo.TargetName := PChar(Server);
CredTargetInfo.CredTypeCount := 1;
CredTargetInfo.CredTypes := #CredType;
ZeroMemory(#Creds, sizeof(Creds));
Creds.TargetName := PChar(Server);
Creds.Type_ := CRED_TYPE_DOMAIN_PASSWORD;
Creds.CredentialBlobSize := ByteLength(Password);
Creds.CredentialBlob := PByte(PChar(Password));
Creds.UserName := PChar(Username);
Creds.Persist := CRED_PERSIST_ENTERPRISE;
bRes := CredWriteDomainCredentials(#CredTargetInfo,#Creds, 0);
if bRes then
begin
DbgOut('Successfully stored %s Credentials for %s', [Username, Server]);
end
else begin
LastError := GetLastError;
DbgOut('CredWriteDomainCredentials failed with %d (%s)', [LastError, SysErrorMessage(LastError)]);
end;
end;
Here's an example how to delete stored credentials:
procedure DeleteCredentials;
var
Count: DWORD;
Creds: PPCredentialArray;
i: Cardinal;
bRes: Boolean;
begin
DbgOut('Deleting Old Credentials');
if not CredEnumerate(nil, 0, Count, PCREDENTIAL(Creds)) then
Exit;
DbgOut('Found %d old credentials', [Count]);
try
for i := Count-1 downto 0 do
begin
bRes := CredDelete(Creds^[i]^.TargetName, Creds^[i]^.Type_, 0);
DbgOut('Deleting credential %d (%s to %s) returned %s', [i, Creds^[i]^.UserName, Creds^[i]^.TargetName, BoolToStr(bRes, True)]);
end;
finally
CredFree(Creds);
end;
end;
Note: the sample code is copy/pasted off an old project so things like DbgOut can simply be removed. The sample code was for a case where an Active Directory domain was used, it might need some changes for non domain situation.
I am trying to get a list of all outlook contacts using delphi.
I found a couple of examples, all seemed to be outdated or flawed.
Currently I have the following code, but when I excecute the command at runtime I get the below error:
Code:
procedure Tinvite_friends.BitBtn2Click(Sender: TObject);
const
olFolderContacts = $0000000A;
var
outlook, NameSpace, Contacts, Contact: OleVariant;
i: Integer;
begin
Try
outlook:=GetActiveOleObject('Outlook.Application');
Except
outlook:=CreateOleObject('Outlook.Application');
End;
NameSpace := outlook.GetNameSpace('MAPI');
Contacts := NameSpace.GetDefaultFolder(olFolderContacts);
for i := 1 to Contacts.Items.Count do
begin
Contact := Contacts.Items.Item(i);
{now you can read any property of contact. For example, full name and
email address}
ShowMessage(Contact.FullName + ' <' + Contact.Email1Address + '>');
end;
Outlook := UnAssigned;
end;
Error Message:
Project appname.exe raised exception class EOLeSysError with message 'Invalid class string'.
The project does not get passed the below code before throwing the error.
Try
outlook:=GetActiveOleObject('Outlook.Application');
Except
outlook:=CreateOleObject('Outlook.Application');
End;
Is there an effective way to get a list of all contacts from outlook imported to a memo for example?
Maybe it's case sensitivity? I test for outlook.application:
const
scxOutlookApp = 'outlook.application';
scxNameSpace = 'MAPI';
function TDataModuleSyncOutlook.ConnectToOutlook(AUserSMTP: String = ''): Boolean;
var
lRecipient,
lVar : OleVariant;
lLog,
lLoginSMTP: String;
begin
Result := false;
FWasCreated := False; // Breakpoint 'Ignore subsequent exceptions'
try
FOutlookApp := GetActiveOleObject(scxOutlookApp); // Application object
Result := True;
except
try
FOutlookApp := CreateOleObject(scxOutlookApp);
FWasCreated := True;
Result := True;
except
on E:Exception do TSyncLogger.LogError(E.Message);
end;
end;
if Result then // Breakpoint 'Handle subsequent exceptions'
begin
FNameSpace := FOutlookApp.GetNamespace(scxNameSpace);
// Solution from http://stackoverflow.com/questions/18053110/retrieve-outlook-logged-in-user-smtp-address-after-connecting-through-ole/
lLog := Format('Connected to Outlook; Application.DefaultProfilename: %s, Application.Name: %s, Application.Version: %s, NameSpace.CurrentProfileName: %s, NameSpace.ExchangeMailboxServerName: %s, NameSpace.Type: %s',
[FOutlookApp.DefaultProfileName,
FOutlookApp.Name,
FOutlookApp.Version,
FNameSpace.CurrentProfileName,
FNameSpace.ExchangeMailboxServerName,
FNameSpace.Type]);
TSyncLogger.LogDetail(lLog);
lVar := FOutlookApp.Session; // NameSpace object for the current session
if not VarIsClear(lVar) then lVar := lVar.CurrentUser; // Recipient object for the currently logged-on user
if not VarIsClear(lVar) then lVar := lVar.AddressEntry; // AddressEntry object for the recipient
if not VarIsClear(lVar) then lVar := lVar.GetExchangeUser; // Returns an ExchangeUser object that represents the AddressEntry
if not VarIsClear(lVar) then lVar := lVar.PrimarySmtpAddress; // String representing the SMTP address for the ExchangeUser
if not VarIsClear(lVar) then
begin
lLoginSMTP := FOutlookApp.Session.CurrentUser.AddressEntry.GetExchangeUser.PrimarySmtpAddress;
TSyncLogger.LogDetail('Primary Exchange SMTP address detected as: ' + lLoginSMTP);
end
else
begin
TSyncLogger.LogError(sErrNoExchangeAccount);
DisConnectFromOutlook;
Exit;
end;
if LowerCase(AUserSMTP) <> Lowercase(lLoginSMTP) then
begin // Open shared calendar if it's a different user
lRecipient := FNameSpace.CreateRecipient(AUserSMTP);
try
FCalendarFolder := FNameSpace.GetSharedDefaultFolder(lRecipient, olFolderCalendar);
lLog := Format('Logging in as different user (%s), created recipient for %s, GetSharedDefaultFolder folder path = %s',[AUserSMTP,lRecipient.Address,FCalendarFolder.FolderPath]);
TSyncLogger.LogAlways(lLog);
except
on E:Exception do
begin
Result := false;
TSyncLogger.LogError(Format(sErrOpenGedeeldeAgenda,[AUserSMTP]));
end;
end;
end
else // ... otherwise open default calendar folder
begin
FCalendarFolder := FNameSpace.GetDefaultFolder(olFolderCalendar);
TSyncLogger.LogDetail('Opened default calendar folder, folder path = ' + FCalendarFolder.FolderPath);
end;
end;
FOleInitialized := Result;
if Result then TSyncLogger.LogDetail('Connected to Outlook') else TSyncLogger.LogAlways('Connection to Outlook failed');
end;
Notes:
1. This opens the default calendar for any user, but you would not need to go that far (besides, your issue is earlier)
2. TSyncLogger is our logging handler
3. FOleInitialized, FWasCreated: Boolean; FOutlookApp, FNameSpace, FCalendarFolder: OleVariant; are some private properties we maintain
4. Essential to this code is that it first does a GetActiveOleObject to catch a running instance of Outlook; if that fails it does a CreateOleObject
As you can see from the code snippet below. I am currently gathering the information about the AD from the currently logged on user using adshlp and ActiveDs_TLB. I have a form that allows the user to enter their AD password and I verify that is correct before allowing access to the system. This woks fine. The problem I have now is that the users want to be able to enter any AD and ID in the form mydomain.com\userid and have the code authenticate and bring back the same data the code currently retrieves. I have not been able to find an LDAP call that will do that. I would appreciate any help and suggestions that I can get.
Thanks
uses
adshlp, ActiveDs_TLB
function Tlogon_form.GetUser(Domain, UserName, pword: string; var ADSIUser: TADSIUserInfo): boolean;
var
usr : IAdsUser;
usr1 : IADs;
flags : integer;
grps : IAdsMembers;
grp : IAdsGroup;
varGroup : OleVariant;
Temp : LongWord;
pwd, cn_name, FQDN, AD_path: string;
HR : boolean;
fad_domain:string;
objsysinfo: IADsADSystemInfo;
domainDN: string;
List: array [0..10] of String;
I: integer;
name_nodes :string;
const
ADS_SECURE_AUTHENTICATION = $00000001;
begin
ADSIUser.UID:='';
ADSIUser.UserName:='';
ADSIUser.DB_login :='';
ADSIUser.Disabled:=true;
ADSIUser.LockedOut:=true;
ADSIUser.Groups:='';
Result:=false;
FQDN :='';
AD_path := '';
SBN_SQL.Common_login :='';
FPassword := pword;
FUserName := UserName;
//FDomain := lowercase(Domain); // + '.local';
if FUserName = '' then exit;
objsysinfo := CoADSystemInfo.Create;
domainDN := objsysinfo.GetAnyDCName;
fad_domain := objsysinfo.DomainDNSName;
name_nodes := objsysinfo.UserName;
if domain > '' then
begin
fad_domain := domain;
end
else
begin
domain := fad_domain;
end;
fad_domain := fad_domain + '.';
FQDN := domainDN;
ad_path := name_nodes;
try
if trim(FUserName)<>'' then
begin
ADsOpenObject('LDAP://' + AD_path, FUserName, FPassword,ADS_SECURE_AUTHENTICATION, IADsUser, usr);
end;
if usr=nil then exit;
ADSIUser.UID:= UserName;
ADSIUser.UserName := usr.FullName;
ADSIUser.DB_login := usr.employeeid;
//usr:=nil;
Result:=true;
exit;
except
on e: exception do begin
Result:=false;
exit;
end;
end;
end;
What you could do is search for that user based on the userid (without the domain) and thus get the relevant info back.
I wrote an article in "The Delphi Magazine" way back in October 2000 about searching using ADSI and Delphi - and you can still download my code sample and a Delphi component TADSISearcher from my web site - hopefully, that can get you started!
I also use ADsOpenObject for LDAP validation and in your code you pass the domain as a parameter, so use such parameter in the ADsOpenObject call or perhaps I did not clearly understood the question
function Authenticate(const pUser, pPassword,pDomain: String): HRESULT;
Var
aUser : IAdsUser;
begin
Try
Result := ADsOpenObject(Format('LDAP://%s',[pDomain]),Format('%s\%s',[pDomain,pUser]),pPassword,ADS_SECURE_AUTHENTICATION,IAdsUser,aUser);
// here retrieve the information needed
Finally
aUser := Nil
End
end;
I have a working application that can access Outlook via COM and send, save or show emails I create inside this app.
What I want is all the settings of the account in Outlook getting applied on my mail too, so this means which mail-type (text, html or rich), custom fonts, signatures, and so on.
here a SSCCE (the the rest of the code is just some logging, and the form only contains the most neccessary controls):
...
strict private
FOutlook: _Application;
...
procedure TMainForm.ShowMailDlg(aModal: Boolean);
var
mail: _MailItem;
begin
Connect();
mail := FOutlook.CreateItem(olMailItem) as _MailItem;
mail.Recipients.Add(Trim(EdTo.Text));
mail.CC := Trim(EdCc.Text);
mail.Subject := Trim(EdSubject.Text);
mail.Body := EmailText.Lines.Text;
mail.SendUsingAccount := GetAccountForEmailAddress(Trim(EdFrom.Text));
//mail.Attachments.Add('Path1', olByValue, 1, 'Caption1');
//mail.Attachments.Add('Path2', olByValue, 2, 'Caption2');
mail.Display(aModal);
end;
procedure TMainForm.Connect;
begin
FOutlook := CreateOleObject('Outlook.Application') as _Application;
end;
function TMainForm.GetAccountForEmailAddress(const aSmtp: string): _Account;
var
accounts: _Accounts;
account: _Account;
i: Integer;
begin
accounts := FOutlook.Session.Accounts;
for i := 1 to accounts.Count do begin
account := accounts.Item(i);
if LowerCase(account.SmtpAddress) = LowerCase(aSmtp) then begin
Result := account;
Exit;
end;
end;
raise Exception.Create('No Account with SMTP address ' + aSmtp + ' found!');
end;
How can I get the MailItem to use all formatting-options from the chosen account?
I still haven't found a real solution, but here is a workaround.
The trick is to use the CreateItemFromTemplate-method, where your template contains all the settings. Oviously the user is required to create a template for this purpose, but it's a one-time-action which shoulnd't be too hard.
procedure TMainForm.DoMailAction(aAction: TMailAction);
var
mail: _MailItem;
folder: OleVariant;
begin
Connect();
folder := FOutlook.Session.GetDefaultFolder(olFolderDrafts);
mail := FOutlook.CreateItemFromTemplate('C:\\Users\\fkoch\\default.oft', folder) as _MailItem;
...
Additionally, the selected folder "Drafts" causes the signature getting attached to the mailbody, as long as the mailItem is manually send by the user in the mail-dialog (mail.display(False)). This doesn't happen when directly processed via mail.send() or mail.save().
I've found the solution now. I'v set the body the wrong way, thats why it didn't work.
procedure CreateMail(aMailInfo.TMailInfo)
var
...
insp: _Inspector;
editor: OleVariant;
begin
FMailItem := FOutlook.CreateItem(olMailItem) as _MailItem;
...
insp := FMailItem.GetInspector;
if (insp.EditorType = olEditorWord) then begin
editor := insp.WordEditor;
editor.Characters.item(1).InsertBefore(mailText);
end else begin
if FMailItem.BodyFormat = olFormatHTML then begin
regex := TRegEx.Create(cReplaceNewline);
FMailItem.HTMLBody := regex.Replace(mailText, '<br />');
end else
FMailItem.Body := mailText;
end;
...
end;
is there a simple way to look up if a domain has a MX record or not using Delphi? I have a list of emails that I wish to verify work, I want to check each of the domains and see if a MX server even exists.
Thanks.
Edit: The email addresses I have are all from bounced email messages of error code: 5.4.0. But too many servers don't follow any standards and 5.4.0 error code itself can mean too much. I don't want to just remove all the email addresses found with that error code erroraneously, so I figure a better way is to first check if the domain or mx record don't exist and remove those for sure.
You can use the windows DnsQuery API to check the MX records for a given server name. Unfortunately I didn't find a proper Delphi translation for the headers, so I made a partial (but workable) translation myself. It only supports MX and IpV4 A records, nothing else. Adding support for IpV6 address should be trivial.
Here's my translation, including a simple ServerHasMxRecords(const ServerName:string):Boolean function that returns True if any MX records are found:
unit DnsMxCheck;
interface
uses Windows, Classes;
type
DNS_STATUS = Integer;
IP4_ADDRESS = DWORD;
_DNS_RECORD_FLAGS = packed record
case Boolean of
True: (DW: DWORD);
False: (DNS_RECORD_FLAGS: DWORD);
end;
DNS_A_DATA = packed record
case Boolean of
True: (IpAddress: IP4_ADDRESS);
False: (Bytes:array[0..3] of Byte);
end;
DNS_MX_DATA = packed record
pNameExchange: PWChar;
wPreference: Word;
Pad: Word;
end;
_DNS_RECORD_DATA_UNION = packed record
case Integer of
0: (A: DNS_A_DATA);
1: (MX1, MX2, AFSDB1, AFSDB2, RT1, RT2: DNS_MX_DATA);
999: (Filler: array[0..1024] of Byte); // I have no idea what the true size of the record shoud be!
end;
PDNS_RECORD = ^DNS_RECORD;
DNS_RECORD = packed record
NextRecord: PDNS_RECORD;
pName: PWChar;
wType: Word;
wDataLength: Word;
Flags: _DNS_RECORD_FLAGS;
dwTtl: DWORD;
dwReserved: DWORD;
Data: _DNS_RECORD_DATA_UNION;
end;
const DNS_TYPE_A = $0001;
DNS_TYPE_MX = $000f;
function DnsQuery_W(lpstrName: PWChar; wType: Word; Options: DWORD; pExtra: Pointer; out ppQueryResultsSet: PDNS_RECORD; pReserved: Pointer): DNS_STATUS;stdcall;external 'dnsapi.dll';
function ServerHasMxRecords(const ServerName:string):Boolean;
implementation
function ServerHasMxRecords(const ServerName:string):Boolean;
var DNS_REC: PDNS_RECORD;
begin
if DnsQuery_W(PWChar(ServerName), DNS_TYPE_MX, 0, nil, DNS_REC, nil) = 0 then
begin
while Assigned(DNS_REC) do
begin
if DNS_REC.wType = DNS_TYPE_MX then
begin
Exit(True);
end;
DNS_REC := DNS_REC.NextRecord;
end;
end;
Result := False;
end;
end.
It is actually good to have an e-mail checker. If nothing else you can clean you e-mail base and avoid sending over and over to non existing mails. Or you can use it as means of verifying user mails when they sign on to your application.
Here is a part of the code in my mail checking class.
procedure TMailValidator.ResolveEmailAddress(const Address: TEMailAddress; const DNSServer: string);
var
I: Integer;
MXEmpty: Boolean;
DomainName: string;
DNSResolver: TIdDNSResolver;
begin
DNSResolver := TIdDNSResolver.Create(nil);
try
DomainName := StrAfter('#', string(Address));
MXEmpty := True;
DNSResolver.Host := DNSServer;
{$IFNDEF IT_UseIndy9}
DNSResolver.QueryType := [qtMx];
{$ELSE}
DNSResolver.QueryRecords := [qtMx];
{$ENDIF} // IT_UseIndy9
try
{$IFNDEF IT_UseIndy9}
DNSResolver.WaitingTime := FDNSResolveTimeout;
{$ELSE}
DNSResolver.ReceiveTimeout := FDNSResolveTimeout;
{$ENDIF} // IT_UseIndy10
DNSResolver.Resolve(DomainName);
for I := 0 to DNSResolver.QueryResult.Count - 1 do
begin
if DNSResolver.QueryResult[I].RecType = qtMX then
begin
MXEmpty := False;
CheckEmailAddress(Address, TMXRecord(DNSResolver.QueryResult[I]).ExchangeServer);
// were we successfull
if CheckSMTPExitErrorCode then
Exit;
end;
end;
// check for servers flag
if FFoundMailServer then
begin
SendLogMessage(Format('Address "%s" is not valid on domain "%s"', [Address, DNSServer]));
SetLastError(cUserErrorCodeBase + 5);
end
else
begin
if MXEmpty then
begin
SendLogMessage(Format('No valid mail(MX) server could be found for domain "%s"', [DomainName]));
CheckEmailAddress(Address, DomainName);
end
else
begin
SendLogMessage(Format('Mail server did not respond on domain "%s"', [DomainName]));
SetLastError(cUserErrorCodeBase + 3);
end;
end;
except
on E: Exception do
begin
SendLogMessage(Format('Address "%s" validation failed for domain "%s": %s', [Address,
DomainName,
E.Message]));
SetLastError(cUserErrorCodeBase + 4, E.Message);
end;
end;
finally
DNSResolver.Free;
end;
end;
procedure TMailValidator.CheckEmailAddress(const Address: TEMailAddress; const MailServer: string);
var
SMTP: TIdSMTP;
begin
SendLogMessage(Format('Validating address "%s" on server "%s"', [Address, MailServer]));
if (FCheckStep = csAddress) or (FCheckStep = csDomain) then
begin
// finish if flags in [FLAG_CheckLocal, FLAG_CheckDomain]
SendLogMessage(Format('Address "%s" successfuly validated.', [Address]));
Exit;
end;
SMTP := TIdSMTP.Create(nil);
try
FCurrentStep := csMailBox;
try
SMTP.ReadTimeout := FSMTPReadTimeout;
{$IFNDEF IT_UseIndy9}
SMTP.AuthType := satNone;
{$ELSE}
SMTP.AuthenticationType := atNone;
{$ENDIF} // IT_UseIndy9
SMTP.Host := MailServer;
SMTP.Port := 25;
SMTP.Connect;
try
FFoundMailServer := True;
try
SMTP.SendCmd('Helo ' + FQueryingServer, 250 );
SMTP.SendCmd('Rset');
SMTP.SendCmd('Mail from:<' + string(Address) + '>', 250);
SMTP.SendCmd('RCPT to:<' + string(Address) + '>', [250, 251] );
SendLogMessage(Format('Address "%s" successfuly validated on server "%s".', [FEMailAddress,
MailServer]));
except
on E: Exception do
begin
SendLogMessage(Format('Address "%s" validation failed on server "%s": %s', [Address,
MailServer,
E.Message]));
SetLastError(SMTP.LastCmdResult.NumericCode, E.Message);
Exit;
end;
end
finally
SMTP.Disconnect;
end;
except
// handle all other exceptions
on E: Exception do
begin
SendLogMessage(Format('CheckMail [%s] : Failure (Server) "%s" [%s]', [Address,
MailServer,
E.Message]));
SetLastError(Max(cUserErrorCodeBase + 6, SMTP.LastCmdResult.NumericCode), E.Message);
end;
end;
finally
SMTP.Free;
end;
end;
Basically you do it in three steps:
Check the mail syntax.
Check the domain and validate MX server
Validate the user mailbox
The only way to check if you can deliver an email is to actually deliver it, and check the zillion ways you can get a bounce response.