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;
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 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;
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.
Using the code below I try to set a value in the HKEY_LOCAL_MACHINE section of registry but I get an error 'Failed to set data for.....'
If I use HKEY_CURRENT_USER there is no problem.
What might I be missing here.
(The code is not complete, but I think it is the important parts of it)
type
TTypWinBits = (Bit32, Bit64);
function WinBits: TTypWinBits;
type
TIsWow64Process = function(Handle:THandle; var IsWow64 : BOOL) : BOOL; stdcall;
var
hKernel32 : Integer;
IsWow64Process : TIsWow64Process;
IsWow64 : BOOL;
begin
Result := Bit32;
hKernel32 := LoadLibrary('kernel32.dll');
if (hKernel32 = 0) then RaiseLastOSError;
#IsWow64Process := GetProcAddress(hkernel32, 'IsWow64Process');
if Assigned(IsWow64Process) then
begin
IsWow64 := False;
if (IsWow64Process(GetCurrentProcess, IsWow64)) then
Result := Bit64
else
RaiseLastOSError;
end;
FreeLibrary(hKernel32);
end;
function TFastRegistry.CreateConnection: TRegistry;
begin
Result := TRegistry.Create;
try
case WinBits of
Bit32: Result := TRegistry.Create;
Bit64: Result := TRegistry.Create(KEY_WRITE OR KEY_WOW64_64KEY);
end;
except
on E: exception do
Result := nil;
end;
end;
procedure TFastRegistry.RunAdd(aDesc, aName: string);
var
Reg: TRegistry;
sRegKey: String;
begin
sRegKey := 'Software\Microsoft\Windows\CurrentVersion\Run';
Reg := CreateConnection;
with Reg do
begin
try
RootKey := HKEY_LOCAL_MACHINE;
if not KeyExists(sRegKey) then
OpenKey(sRegKey, True)
else
OpenKey(sRegKey, False);
WriteString(aDesc, aName);
finally
CloseKey;
Free;
end;
end;
end;
A program requires elevated privileges to write to the local-machine key. Without that, functions will fail, as you've observed. If your program is supposed to be an administrative tool, then use a manifest file so the OS will prompt for permission. If you don't need that, then write to the current-user key instead so it doesn't affect all accounts on the system.
You just need to release the handle by the "Free" and for the next entry in the register to recreate it, and not keep it permanently set up and open and close them through OpenKey and CloseKey! It looks like a bug :-)
My Delphi 2010 application needs to add a Windows user to the local Administrators group. I got this part working using NetLocalGroupAddMembers.
Now the application needs to work in localized versions of Windows with other languages. For this I am using the SID with the LsaLookupSids function to get the translated name of the group, but am unable to do it because I don't know how to make the API call.
I would be grateful is someone could please show me how to use the LsaLookupSids function to get the group name ('Administrators' in English US version of Windows) from the SID.
Following is my code:
function AddUser(const username, password: PChar; resetpassword: boolean): boolean; stdcall;
var
NetApiStatus: NET_API_STATUS;
UserInfo1003: USER_INFO_1003;
UserInfo1005: USER_INFO_1005;
ui: USER_INFO_1;
grp: String;
sid: PSID;
snu: SID_NAME_USE;
sidsize: LongWord;
refdomain: PLsaReferencedDomainList; //array [0..MAX_PATH - 1] of char;
refdomainsize: LongWord;
sidstring: PChar;
lgmi3: _LOCALGROUP_MEMBERS_INFO_3;
reftranname: PLsaTranslatedName;
begin
if UserExists(username) then begin
sidstring := PChar('S-1-5-32-544'); //Local Administrators group
refdomain := AllocMem(SizeOf(refdomain));
FillChar(refdomain, SizeOf(refdomain), 0);
reftranname := AllocMem(SizeOf(reftranname));
sidsize := 0;
sid := nil;
sid := AllocMem(Length(sidstring) );
sid := PChar(sidstring);
try
LsaLookupSids(GetPolicyHandle, 1, sid, refdomain, reftranname);
grp := reftranname^.Name.Buffer;
showmessage('messg ' + grp);
finally
FreeMem(sid, sidsize);
end;
end;
You don't need LsaLookupSids, this is meant for lookup or an array of SID's.
Lookup of a single SID is usually done using LookupAccountSid. Example:
uses JwaWindows; // or JwaSddl, JwaWinBase;
var
Sid: PSID;
peUse: DWORD;
cchDomain: DWORD;
cchName: DWORD;
Name: array of Char;
Domain: array of Char;
begin
Sid := nil;
// First convert String SID to SID
Win32Check(ConvertStringSidToSid(PChar('S-1-5-32-544'), Sid));
cchName := 0;
cchDomain := 0;
// Get Length
if (not LookupAccountSid(nil, Sid, nil, cchName, nil, cchDomain, peUse))
and (GetLastError = ERROR_INSUFFICIENT_BUFFER) then
begin
SetLength(Name, cchName);
SetLength(Domain, cchDomain);
if LookupAccountSid(nil, Sid, #Name[0], cchName, #Domain[0], cchDomain, peUse) then
begin
// note: cast to PChar because LookupAccountSid returns zero terminated string
ShowMessageFmt('%s\%s', [PChar(Domain), PChar(Name)]);
end;
end;
if Assigned(Sid) then
LocalFree(DWORD(Sid));
or even easier using Jwscl:
uses JwsclSid;
var
Sid: TJwSecurityId;
begin
Sid := TJwSecurityId.Create('S-1-5-32-544');
try
ShowMessage(Sid.GetAccountName);
finally
Sid.Free;
end;
Simple example using JCL. You also could same using http://blog.delphi-jedi.net/security-library/ (like TJwSecurityId).
This code does not use LsaLookupSids, but internally LookupAccountSid (but for local group I don't think that it does matter).
uses
JclSecurity, JclWin32;
// Raises exception in case of invalid ASID or if SID is not found
function GetNameFromSid(ASID: String): String;
var
lSidLen: DWORD;
lSid: PSID;
lName, lDomain: WideString;
begin
lSidLen := SECURITY_MAX_SID_SIZE;
lSid := AllocMem(lSidLen);
try
StringToSID(ASID, lSid, lSidLen);
LookupAccountBySid(lSid, lName, lDomain);
Result := lName;
finally
FreeMem(lSid);
end;
end;