Outlook send mail via COM with user settings - delphi

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;

Related

Using Outlook Contacts In Delphi XE7

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

Active Directory authentication via LDAP with user#mydomain.com using Delphi

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;

Delphi - get user EmailAddress from active directory

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.

delphi MS Office outlook error

I am trying to send a mail through my application developed in BDS 2006 via MS office Outlook.
It works totally fine with my outlook running ,but it fails in the try block if outlook is closed.
It displays error EOlesystem error : Operation unavailable and does not go to Exceptblock
my code
procedure TMyform.BTN_mailClick(Sender: TObject);
const
olMailItem =0;
var
Outlook: OleVariant;
vMailItem: variant;
begin
try
Outlook := GetActiveOleObject('Outlook.Application');
except
Outlook := CreateOleObject('Outlook.Application');
end;
vMailItem := Outlook.CreateItem(olMailItem);
vMailItem.Recipients.Add(mailaddress);
vMailItem.Subject := 'mymail';
vMailItem.Body := 'Dear '
vMailItem.Attachments.Add(path);
vMailItem.Send;
VarClear(Outlook);
end;
How can I overcome this ?
Thanks
It has to go to the except block. Did you set a breakpoint there to check?
But nevertheless you can prevent the exception from happening:
var
Outlook: OleVariant;
ClassID: TCLSID;
Unknown: IUnknown;
begin
if Succeeded(GetActiveObject(ClassID, nil, Unknown)) then
OleCheck(Unknown.QueryInterface(IDispatch, Outlook)) else
Outlook := CreateOleObject('Outlook.Application');
{ ... }
I had the same problem. But recently I found a workaround. Instead of adding multiple e mail addresses using "vMailItem.Recipients.Add(mailaddress);", I used "vMailItem.To := 'mailID';". I hope it helps you.
Here is an example:
procedure TForm1.SendMailClick(Sender: TObject);
const olMailItem = $00000000;
Var
Outlook: OleVariant;
Mail: Variant;
begin
try
try
Outlook := GetActiveOleObject('Outlook.Application');
except
Outlook := CreateOleObject('Outlook.Application');
end;
Mail := Outlook.CreateItem(olMailItem);
Mail.To := 'receiver1#xyz.com' + ';' + 'receiver2#xyz.com';
Mail.Subject := 'your subject';
Mail.Display; //Mail.Send; if you want to send directly
Except
on E : Exception do
ShowMessage(E.ClassName+' error raised, with message : '+E.Message);
End;
end;

How to send a MAPI email with an attachment to a fax recipient?

I am using this method to send a MAPI email with a PDF attachment from inside a Delphi application.
It brings up an MS Outlook "new message" window with the pdf document already attached, and a blank recipient.
If you type in a normal email contact, then it goes through fine.
However, if you select a fax recipient, it appears in my "Sent Items" folder, but delivery fails silently (no error, no MS Outlook "delivery failed" message, and no delivery of the message).
The "fax recipient" is set up in MS Outlook with nothing but a fax number. No email or anything. We use a faxcore server to route these "faxes" to the outlook inbox.
If you look at this image, the only field I've filled in for this contact is the one labeled "Business Fax".
If I manually (i.e., outside of my application) create a standard MS Outlook email and choose the very same fax recipient, and manually attach the very same PDF, then it goes through fine.
So it seems that something about using MAPI to send to a fax number causes it to fail.
This post sounds similar, except they get a "message undeliverable" error and I don't.
Can anyone give me some pointers on this?
Thanks
Update: If I use MAPI to create the email, but then I manually delete the attachment, then it does work. So from within outlook, I can email an attachment to a fax recipient, but using MAPI it fails.
Complete source code follows:
unit Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
function SendEMailUsingMAPI(const Subject, Body, FileName, SenderName,
SenderEMail, RecipientName, RecipientEMail: string): integer;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses
Mapi;
procedure TForm1.Button1Click(Sender: TObject);
begin
//this will bring up an MS Outlook dialog.
//inside that dialog, if i choose a normal email recipient, it works.
// if i choose a fax recipient, it fails silently.
//if i create the email from w/in outlook, it can go to *either* with success.
SendEmailUsingMAPI(
'Subject', //subject of email
'Body', //body of email text
'c:\my_doc.pdf', //attachment file name
'My name', //sender email name
'myemail#mydomain.com', //sender email address
'', //recipient email name
''); //recipient email address
end;
function TForm1.SendEMailUsingMAPI(const Subject, Body, FileName, SenderName,
SenderEMail, RecipientName, RecipientEMail: string): Integer;
var
Message: TMapiMessage;
lpSender, lpRecipient: TMapiRecipDesc;
FileAttach: TMapiFileDesc;
SM: TFNMapiSendMail;
MAPIModule: HModule;
FileType: TMapiFileTagExt;
begin
FillChar(Message,SizeOf(Message),0);
if (Subject <> '') then begin
Message.lpszSubject := PChar(Subject);
end;
if (Body <> '') then begin
Message.lpszNoteText := PChar(Body);
end;
if (SenderEmail <> '') then
begin
lpSender.ulRecipClass := MAPI_ORIG;
if (SenderName = '') then begin
lpSender.lpszName := PChar(SenderEMail);
end
else begin
lpSender.lpszName := PChar(SenderName);
end;
lpSender.lpszAddress := PChar(SenderEmail);
lpSender.ulReserved := 0;
lpSender.ulEIDSize := 0;
lpSender.lpEntryID := nil;
Message.lpOriginator := #lpSender;
end;
if (RecipientEmail <> '') then begin
lpRecipient.ulRecipClass := MAPI_TO;
if (RecipientName = '') then begin
lpRecipient.lpszName := PChar(RecipientEMail);
end
else begin
lpRecipient.lpszName := PChar(RecipientName);
end;
lpRecipient.lpszAddress := PChar(RecipientEmail);
lpRecipient.ulReserved := 0;
lpRecipient.ulEIDSize := 0;
lpRecipient.lpEntryID := nil;
Message.nRecipCount := 1;
Message.lpRecips := #lpRecipient;
end
else begin
Message.lpRecips := nil;
end;
if (FileName = '') then begin
Message.nFileCount := 0;
Message.lpFiles := nil;
end
else begin
FillChar(FileAttach,SizeOf(FileAttach),0);
FileAttach.nPosition := Cardinal($FFFFFFFF);
FileAttach.lpszPathName := PChar(FileName);
FileType.ulReserved := 0;
FileType.cbEncoding := 0;
FileType.cbTag := 0;
FileType.lpTag := nil;
FileType.lpEncoding := nil;
FileAttach.lpFileType := #FileType;
Message.nFileCount := 1;
Message.lpFiles := #FileAttach;
end;
MAPIModule := LoadLibrary(PChar(MAPIDLL));
if MAPIModule = 0 then begin
Result := -1;
end
else begin
try
#SM := GetProcAddress(MAPIModule,'MAPISendMail');
if #SM <> nil then begin
Result := SM(0,Application.Handle,Message,
MAPI_DIALOG or MAPI_LOGON_UI,0);
end
else begin
Result := 1;
end;
finally
FreeLibrary(MAPIModule);
end;
end;
if Result <> 0 then begin
MessageDlg('Error sending mail ('+IntToStr(Result)+').',mtError,[mbOK],0);
end;
end;
end.
Ok, your update points towards the attachment, so I'm going to put in another guess: try setting the filetype of the attachment explicitly to 'application/pdf' (your current code doesn't set the lpFileType field). The fax handling might be dependent on that. You can just leave the encoding parts of the MapiFileTagExt (the type lpFileType points to) blank, simply FillChar the record and set cbTag and lpTag fields.
If you need code (the mapi structures can be a bit dazzling at times) just yell, but it'll take me some time to find a moment to type it up.. And anyway, again, I'm just guessing. I don't have a fax setup in my home environment, otherwise I'd do some proper testing.
EDIT
Illustrating bit of code below. However, I've since then checked with Outlook Spy, and with neither method, nor when attaching a file manually, the PR_ATTACH_MIME_TAG property seems to be set on the sent item, only on the resulting incoming message.
FillChar(FileAttach,SizeOf(FileAttach),0);
FileAttach.nPosition := Cardinal($FFFFFFFF);
FileAttach.lpszPathName := PChar(FileName);
//
MimeType := 'application/pdf';
//
FileType.ulReserved := 0;
FileType.cbTag := Length( MimeType );
FileType.lpTag := PByte(MimeType);
FileType.cbEncoding := 0;
FileType.lpEncoding := nil;
//
FileAttach.lpFileType := #FileType;
Message.nFileCount := 1;
Message.lpFiles := #FileAttach;
(code-formatter is not being particularly helpful).
Could it be the fax addresses are not available in the 0 (temporary) session? In other words, does logging into a session using MAPILogon first, then providing the hSession in the MAPISendMail call help?
You could try enabling Outlook Transport Logging, hopefully some (any) error message will turn up there. Make sure to log a manual fax (working situation) first, to check if anything related actually does show up in this log.
Unfortunately, my personal success rate in solving issues through this log is zilch, but trying to get more information never hurts, right?

Resources