I use Delphi RAD Studio 2010 and the next code to send email with Outlook:
procedure SendOutlookMail(email,subject,body,fileat:string);
const
olMailItem = 0;
var
vMailItem: variant;
Outlook: OutlookApplication;
NmSpace: NameSpace;
Folder: MAPIFolder;
begin
Outlook := CoOutlookApplication.Create;
NmSpace := Outlook.GetNamespace('MAPI');
NmSpace.Logon('', '', False, False);
Folder := NmSpace.GetDefaultFolder(olFolderInbox);
Folder.Display;
vMailItem := Outlook.CreateItem(olMailItem);
if email<>'' then vMailItem.Recipients.Add(email);
vMailItem.Subject := subject;
vMailItem.Body := Body;
vMailItem.Attachments.Add(fileat);
vMailItem.Display(false);
end;
It opens a new Outlook message and bring it to front to just press "Send" to send it. That's ok. The problem is, creating a new email message with this method doesn't add the signature. If I create a new message within Ms Outlook, the signature is added automatically.
Is there anyway I can add the signature that the user has configured in MS Outlook? (without adding the signature text to "Body" string variable). Thanks in advance.
the signature is added when you call MailItem.Display or access MailItem.GetInspecrtor.
Call MailItem.Display first (the signature will be added at that moment), then merge your data with the existing body. Note that setting the plain text Body property will wipe out formatting, so you will need to work with the HTMLBody property. Keep in mind that 2 HTML strings cannot be simply concatenated - read the HTMLBody property, find the appropriate insertion position (after the <body> tag?), then insert your data.
//Here is how I did it in Delphi. It shows the part no-one else did, which is //parsing the email HTML and putting your text above the signature.
//The part at the beginning loads up the string that I will be adding, so you //could ignore that.
procedure TfrmEngInfo2.CreateMSOutlookHoldEmail;
var
i: Integer;
Outlook: OleVariant;
Mail: OleVariant;
EmailTo,EmailCC: string;
SubjectLine: string;
PartNbr,PONbr,JobNbr: string;
HTMLInfo: string;
JobInfo: string;
x: integer;
iPos: integer;
RealPosition,GTPosition: integer;
const
olMailItem = 0;
olByValue = 1;
olFormatHTML = 2;
begin
SubjectLine := 'PCB Hold /';
if JOBHEMAI.state = dsInactive then
JOBHEMAI.open;
if CUST.state = dsInactive then CUST.open;
if RELEASE.FindKey([AdsQuery1.FieldByName('R-JOB#').asstring, AdsQuery1.FieldByName('R-RELEASE-NBR').asstring]) then
begin
PONbr := RELEASE.FieldByName('R-PO-NBR').asstring;
JobNbr := AdsQuery1.FieldByName('R-JOB#').asstring + AdsQuery1.FieldByName('R-RELEASE-NBR').asstring;
SubjectLine := SubjectLine + ' PO#: ' + PONbr + ' / ';
end;
if JOBHEMAI.FindKey([AdsQuery1.FieldByName('R-JOB#').asstring]) then
EmailTo := JOBHEMAI.FieldByName('HoldEmailAddress').asstring;
if HEADER.FindKey([AdsQuery1.FieldByName('R-JOB#').asstring]) then
begin
PartNbr := HEADER.FieldByName('H-PART#').asstring;
SubjectLine := SubjectLine + ' Part#: ' + PartNbr;
if CUST.FindKey([HEADER.FieldByName('H-CUST-NBR').asstring]) then
if EmailTo = '' then
EmailTo := CUST.FieldByName('HoldEmailAddress').asstring;
if SALEPRSN.FindKey([HEADER.FieldByName('H-SLMN#').asstring]) then
EmailCC := SALEPRSN.fieldByName('E-mail').asstring;
end;
SubjectLine := SubjectLine + JobNbr;
try
Outlook := GetActiveOleObject('Outlook.Application');
except
Outlook := CreateOleObject('Outlook.Application');
end;
JobInfo := 'We have released the hold for your job Part: ' + PartNbr + ' PO: ' + PONbr
+ 'Job Number: ' + JobNbr;
Mail := Outlook.CreateItem(olMailItem);
Mail.To := EmailTo;
Mail.cc := EmailCC;
Mail.Subject := SubjectLine;
// Main.Attachments.Add('c:\test.jpg', olByValue, 1, 'My Test Image');
Mail.BodyFormat := olFormatHTML;
//This load the HTMLBody with all the outlook stuff including the users signature. Basically a blank email message
Mail.GetInspector;
// Find the position of the opening <body command.
x := pos('<body',Mail.HTMLBody);
// Put the HTMLBody in to a string field so we can examine it.
HTMLInfo := Mail.HTMLBody;
// Now loop through and find the position of the closing tag. '>' It must be in a position greater than the starting tag
RealPosition := 0;
while pos('>',HTMLInfo) > 0 do
begin
GTPosition := pos('>',HTMLInfo);
RealPosition := RealPosition + GTPosition;
if RealPosition > x then
break;
HTMLInfo := copy(HTMLInfo,GTPosition + 1,Length(HTMLInfo) - GTPosition);
end;
// Since we destroyed the HTMLInfo in the analysis, load it again.
HTMLInfo := Mail.HTMLBody;
// Now insert our information at the right spot.
insert(JobInfo,HTMLInfo,RealPosition + 1);
// Now load the modified HTMLInfo back to the Mail.HTMLBody so that it can display in the message.
Mail.HTMLBody := HTMLInfo;
// Finally display the Outlook Email
Mail.Display;
Outlook := unassigned;
end;
Related
How can I add a large text file (actually a HTML file) as an attachment to a channel in Slack? A working example would be great. I use SDriver - the included demo works fine to send some strings, but I don't find anything on how to use attachments.
What I did so far:
procedure TForm1.SendActionExecute(Sender: TObject);
var
LWebHook: IMessageBuffer;
LMessage: IMessage;
LStopWatch: TStopWatch;
vAttachment: IAttachment;
vField: IFields;
begin
LStopWatch := TStopWatch.StartNew;
LMessage := TMessage.Create(EditMessage.Text + ' [' + TimeToStr(Now) + ']');
LMessage.UserName := EditUserName.Text;
LMessage.Icon_URL := EditIcon_URL.Text;
LMessage.Icon_Emoji := EditIcon_Emoji.Text;
LMessage.Channel := EditChannel.Text;
vAttachment := LMessage.AddAttachment;
vField := vAttachment.AddFields;
vField.Title := 'Title';
vField.Value := 'Value';
///////////////////////////////////////////////////////
// How can I add a large text file as attachment here ?
///////////////////////////////////////////////////////
LWebHook := TIncomingWebHook.Create(EditWebHookURL.Text, False);
LWebHook.Push(LMessage);
LWebHook.Flush;
end;
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
Hello all experts,
procedure TForm1.domail(Sender: TObject; fromname, fromadd, sub, toadd, thedocdone, theacc: string; body: widestring);
const
olMailItem = 0;
var
Outlook: OLEVariant;
vmailitem: variant;
Attachment: TIdAttachment;
savetofol: string;
begin
try
Outlook := GetActiveOleObject('Outlook.Application');
except
Outlook := CreateOleObject('Outlook.Application');
end;
vmailitem := Outlook.CreateItem(olMailItem);
vmailitem.Recipients.Add(toadd);
vmailitem.ReplyRecipients.Add('email#email.com');
vmailitem.Subject := sub;
vmailitem.body := 'SENT: ' + formatdatetime('dd mmmm yyyy - hh:nn am/pm', now) + #13#10 + body;
vmailitem.ReadReceiptRequested := true;
vmailitem.importance := 2;
if thedocdone <> 'NIL' then
begin
vmailitem.Attachments.Add(thedocdone, 1, 1, 'SBSA_' + theacc);
if ansipos('string1', lowercase(toadd)) <> 0 then
begin
vmailitem.Attachments.Add('*manual path', 1, 2, '*manual name');
Memo1.Lines.Add('Adding consent letter to mail...');
end;
if ansipos('string2', lowercase(toadd)) <> 0 then
begin
vmailitem.Attachments.Add('*manual path', 1, 2, '*manual name');
Memo1.Lines.Add('Adding consent letter to mail...');
end;
savetofol := extractfilepath(thedocdone) + copy(extractfilename(thedocdone), 0, length(extractfilename(thedocdone)) - 8);
vmailitem.saveas(savetofol + '_eml.doc', 4); // ^ +'.doc'
end;
// vmailitem.clear;
vmailitem.Send;
Outlook := Unassigned;
end;
With the above piece of code i am able to attach to outlook and send out an email and attach an attachment to that mail...
My problem is that IT WONT attach the 2nd attachment... ??? i have tried every which way using different methods to do this but i just cannot get the 2nd attachment to attach to the mail...
Please help...
See Attachments Object (Outlook):
To ensure consistent results, always save an item before adding or
removing objects in the Attachments collection of the item.
Wrong:
vmailitem.Attachments.Add();
vmailitem.Attachments.Add();
vmailitem.Attachments.Add();
Right:
vmailitem.Attachments.Add();
vmailitem.save;
vmailitem.Attachments.Add();
vmailitem.save;
vmailitem.Attachments.Add();
vmailitem.save;
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 made a simple program that adds ones information (Name, surname, ID ect) to a .txt file. When ever I make new details in the program, and click on a button to save the information, it rewrites it in the .txt file.
Here's my code:
procedure TForm1.BitBtn1Click(Sender: TObject);
var
InfoFile : TStringList;
Name, Surname, ExtraInfo : String;
PhoneNumber,ID : Integer;
Date : TDateTime;
begin
InfoFile := TStringList.Create;
Name := edtName.text;
Surname := edtSurname.Text;
ID := StrToInt64(edtID.Text);
PhoneNumber := StrToInt64(edtPhone.Text);
Date := StrToDate(edtJoinDate.Text);
try
InfoFile.Add('NAME: '+Name);
InfoFile.Add('SURNAME: '+Surname);
InfoFile.Add('ID NUMBER: '+IntToStr(ID));
InfoFile.Add('PHONE NUMBER: '+IntToStr(PhoneNumber));
InfoFile.Add('DATE JOINED :'+DateToStr(Date));
InfoFile.Add(''); // Spacers to separate next set of details
InfoFile.Add('');
InfoFile.SaveToFile('C:\Users\GrassMan\Desktop\InfoSaver\imfofile.txt');
finally
InfoFile.Free;
end;
So instead of ADDING new details to the .txt file, its rewriting it. I know im doing something, if someone wouldn't mind giving me a hand.
Thanks
Either load the file at the beginning (via LoadFromFile), before adding to it and writing it back; or else forget about TStringList, and just use WriteLn, after opening the file with Append.
Should look like this:
begin
InfoFile := TStringList.Create;
Name := edtName.text;
Surname := edtSurname.Text;
ID := (edtID.Text);
PhoneNumber :=(edtPhone.Text);
try
InfoFile.LoadFromFile('C:\Users\grassman\Desktop\infofile.txt');
InfoFile.Add('NAME: '+Name);
InfoFile.Add('SURNAME: '+Surname);
InfoFile.Add('ID NUMBER: '+ ID);
InfoFile.Add('PHONE NUMBER: '+(PhoneNumber));
InfoFile.Add('Time of registration: ' + TimeToStr(time));
InfoFile.Add('Date of registration: ' + DateToStr(date));
InfoFile.Add(''); // Spacers to separate next set of details
InfoFile.Add('');
InfoFile.SaveToFile('C:\Users\grassman\Desktop\infofile.txt');
finally
InfoFile.Free;
procedure TForm1.BitBtn1Click(Sender: TObject);
var
InfoFile : TStringList;
Name, Surname, ExtraInfo : String;
PhoneNumber,ID : Integer;
Date : TDateTime;
FS : TFileStream;
begin
Name := edtName.text;
Surname := edtSurname.Text;
ID := StrToInt64(edtID.Text);
PhoneNumber := StrToInt64(edtPhone.Text);
Date := StrToDate(edtJoinDate.Text);
InfoFile := TStringList.Create;
try
InfoFile.Add('NAME: '+Name);
InfoFile.Add('SURNAME: '+Surname);
InfoFile.Add('ID NUMBER: '+IntToStr(ID));
InfoFile.Add('PHONE NUMBER: '+IntToStr(PhoneNumber));
InfoFile.Add('DATE JOINED :'+DateToStr(Date));
InfoFile.Add(''); // Spacers to separate next set of details
InfoFile.Add('');
FS := TFileStream.Create('C:\Users\GrassMan\Desktop\InfoSaver\imfofile.txt', fmOpenWrite);
try
FS.Seek(0, soEnd);
InfoFile.SaveToStream(FS);
finally
FS.Free;
end;
finally
InfoFile.Free;
end;
end;
You should use TFileStream:
var
recordStr: string;
fs: TFileStream;
fsFlags: Word;
filePath: string;
begin
filePath := 'C:\Users\GrassMan\Desktop\InfoSaver\imfofile.txt';
recordStr := 'NAME: '+ Name + #13#10 +
'SURNAME: '+ Surname + #13#10 +
'ID NUMBER: '+ IntToStr(ID) + #13#10 +
'PHONE NUMBER: '+ IntToStr(PhoneNumber) + #13#10 +
'DATE JOINED :' + DateToStr(Date) + #13#10 +
#13#10#13#10; // Spaces to separate next set of details
// open if exists, create if not
fsFlags := fmOpenWrite;
if (not FileExists(filePath)) then
fsFlags := fsFlags or fmCreate;
try
fs := TFileStream.Create(filePath);
try
fs.Seek(0, soEnd); // go to the end of the file
fs.Write(recordStr[1], Length(recordStr));
finally
fs.Free;
end;
except on ex: Exception do
begin
ShowMessage('Error while writing to the file: ' + ex.Message);
end;
end;
end;