If you are using MSOutlook then this should do the trick, otherwise I don't
have a clue.
Unit1 code:
unit Unit1;
{*************************************************************************}
{ Programmer: Kevin S. Gallagher }
{ Description: Shows simple example of sending a message via MS-OutLook }
{ Comments: }
{ 1. You need to place a valid email address into the }
{ textbox "txtMailTo". }
{ 2. Review my comments on sending attachments. I only do }
{ a single attachement, although multiples are simple. }
{ 3. Although the attachments work, I didn't attempt to }
{ figure out why they show in the message area instead }
{ of in the "attachment area". }
{*************************************************************************}
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Menus, ExtCtrls, ComCtrls;
type
TfrmMain = class(TForm)
Panel1: TPanel;
MainMenu1: TMainMenu;
mnuFile: TMenuItem;
mnuAbout: TMenuItem;
Sep1: TMenuItem;
mnuExitdemo: TMenuItem;
cmsSendMail: TButton;
ListBox1: TListBox;
Label1: TLabel;
Label2: TLabel;
txtMailTo: TEdit;
txtSubject: TEdit;
cmdAttachFile: TButton;
lblAttachDoc: TLabel;
MessageGroupBox: TGroupBox;
Memo1: TMemo;
OpenDialog1: TOpenDialog;
cmdExit: TButton;
StatusBar1: TStatusBar;
rdoImportance: TRadioGroup;
procedure cmsSendMailClick(Sender: TObject);
procedure mnuExitdemoClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure cmdAttachFileClick(Sender: TObject);
procedure FormResize(Sender: TObject);
private
{$IFNDEF VER120}
procedure WMGetMinMaxInfo(var Message: TWMGetMinMaxInfo); message WM_GETMINMAXINFO ;
{$ENDIF}
public
{ Public declarations }
end;
var
frmMain: TfrmMain;
cAttachFile:String ;
implementation
uses ShellAPI, ComObj ;
{$R *.DFM}
procedure TfrmMain.cmsSendMailClick(Sender: TObject);
function NoCrLf(const cMsg:String):String ;
var nLen,i:Integer ;
begin
nLen := Length(cMsg) ;
i := 1;
while i <= nLen do begin
if cMsg[i] in [#10,#13] then
Result := Result + ''
else
Result := Result + cMsg[i] ;
Inc(i) ;
end ;
end ;
const
aOutLook = 'Outlook.Application' ;
olMailitem = 0 ;
olImportanceLow = 0 ;
olImportanceNormal = 1 ;
olImportanceHigh = 2 ;
var
OutLook,
MailItem: Variant ;
cTo,
cSubject,
cMessage:String ;
i:Integer ;
begin
ListBox1.Items.Clear ;
cTo := txtMailTo.Text ;
cSubject := txtSubject.Text ;
if Length(cTo) = 0 then begin
MessageDlg('Must supply a name to send message to!',mtError,[mbOK],0) ;
exit ;
end ;
if Length(cSubject) = 0 then
cSubject := 'This is a test of sending mail in Delphi' ;
for i := 0 to Memo1.Lines.Count do begin
cMessage := Memo1.Lines.Strings[i] ;
end ;
if Length(cMessage) >0 then
cMessage := NoCrLf(cMessage)
else
cMessage := 'This is a test' ;
try
try
OutLook := GetActiveOleObject(aOutLook) ;
ListBox1.Items.Add('Utilizing OutLook Object') ;
except
OutLook := CreateOleObject(aOutLook) ;
ListBox1.Items.Add('Created OutLook Object') ;
end;
except
ListBox1.Items.Add('failed to create ' + aOutLook) ;
MessageDlg('Unable to create OLE Object for' + #13 +
aOutLook,mtError,[mbOK],0) ;
exit ;
end;
try
mailitem:= Outlook.CreateItem(olMailitem) ;
case rdoImportance.ItemIndex of
0: MailItem.Importance := olImportanceLow ;
1: MailItem.Importance := olImportanceNormal ;
2: MailItem.Importance := olImportanceHigh ;
end;
ListBox1.Items.Add('Created Mail Item') ;
except
ListBox1.Items.Add('Failed to create Mail Item') ;
messageDlg('Unable to create mail item',mtError,[mbOK],0) ;
exit ;
end;
try
try
MailItem.To := cTo ;
MailItem.Recipients.ResolveAll ;
Mailitem.Subject := cSubject ;
{ To keep things simple, we only allow sending one attachment.
If you need to send more then one attachment, then build
code to use a TStringList, cycle through it and add the
attachment. i.e.
for i := 0 to LengthOfStringList do
Mailitem.Attachments.Add(aAttachments[i]) ; }
if length(cAttachFile) >0 then
MailItem.Attachments.Add(cAttachFile) ;
MailItem.Body := 'This is a test of automating OutLook'+ #13 +#10 ;
ListBox1.Items.Add('SendingMessage...') ;
MailItem.Send ;
ListBox1.Items.Add('Message sent!') ;
except on Exception do begin
ListBox1.Items.Add('Message not sent') ;
MessageDlg('Error Sending Report',mtError,[mbOK],0) ;
exit ;
end ;
end ;
finally
{------------------------------------------------------------------
Here I dereference <OutLook> variable rather then telling OutLook
to quit. You could modify the code to see if GetOleObject or
CreateOleObject was used, thus determing if the object should be
unassigned or have OutLook close down
------------------------------------------------------------------}
OutLook := Unassigned ;
if VarIsEmpty(OutLook) then
ListBox1.Items.Add('released OutLook Object')
else
ListBox1.Items.Add('OutLook Object not released properly') ;
// Outlook.Quit; -- See above comment.
end;
end;
procedure TfrmMain.mnuExitdemoClick(Sender: TObject);
begin
Close ;
end;
procedure TfrmMain.FormCreate(Sender: TObject);
begin
cAttachFile := '' ;
rdoImportance.ItemIndex := 0 ;
end;
procedure TfrmMain.cmdAttachFileClick(Sender: TObject);
begin
if OpenDialog1.Execute then begin
cAttachFile := OpenDialog1.FileName ;
lblAttachDoc.Caption := cAttachFile ;
end else
lblAttachDoc.Caption := 'None' ;
end;
procedure TfrmMain.FormResize(Sender: TObject);
var
x:Integer ;
begin
cmdExit.Left := (Width - cmdExit.Width) - 10 ;
cmdExit.Top := (ClientHeight - cmdExit.Height) - 20 ;
MessageGroupBox.Width := (Panel1.Width - ListBox1.Width) - 15 ;
end;
{$IFNDEF VER120}
procedure TfrmMain.WMGetMinMaxInfo(var Message: TWMGetMinMaxInfo) ;
begin
{ Just having a little fun }
with Message.MinMaxInfo^ do begin
// Restrain min dimension of form (width/height)
ptMinTrackSize := Point(522,387) ;
ptMaxTrackSize := Point(800,387) ;
end;
Message.Result := 0;
inherited ;
end ;
{$ENDIF}
end.
DFM Code
(Save as Unit1.txt, then run Convert.exe found in Delphi's Bin directory to
create
a DFM file)
object frmMain: TfrmMain
Left = 200
Top = 108
Width = 522
Height = 387
Caption = 'Automating MS-OutLook'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
Menu = MainMenu1
ShowHint = True
OnCreate = FormCreate
OnResize = FormResize
PixelsPerInch = 96
TextHeight = 13
object Panel1: TPanel
Left = 0
Top = 0
Width = 514
Height = 281
Align = alTop
TabOrder = 0
object Label1: TLabel
Left = 26
Top = 16
Width = 31
Height = 13
Caption = 'Mail to'
end
object Label2: TLabel
Left = 21
Top = 48
Width = 36
Height = 13
Caption = 'Subject'
end
object lblAttachDoc: TLabel
Left = 64
Top = 212
Width = 26
Height = 13
Caption = 'None'
end
object cmsSendMail: TButton
Left = 3
Top = 245
Width = 75
Height = 25
Hint = 'Send the message'
Caption = '&Send'
TabOrder = 4
OnClick = cmsSendMailClick
end
object ListBox1: TListBox
Left = 286
Top = 1
Width = 227
Height = 279
Hint = 'Shows processing of code events'
TabStop = False
Align = alRight
ItemHeight = 13
TabOrder = 6
end
object txtMailTo: TEdit
Left = 62
Top = 15
Width = 171
Height = 21
Hint = 'Enter a email address to send the message too'
TabOrder = 0
Text = 'SomeName@SomeLocation.com'
end
object txtSubject: TEdit
Left = 62
Top = 47
Width = 223
Height = 21
Hint = 'Enter the Subjec of this message'
TabOrder = 1
end
object cmdAttachFile: TButton
Left = 8
Top = 210
Width = 49
Height = 20
Hint = 'Attach a document to your message'
Caption = 'Add File'
TabOrder = 5
OnClick = cmdAttachFileClick
end
object MessageGroupBox: TGroupBox
Left = 8
Top = 127
Width = 273
Height = 73
Caption = 'Message'
TabOrder = 3
object Memo1: TMemo
Left = 2
Top = 15
Width = 269
Height = 56
Align = alClient
Lines.Strings = (
'Place your message here!')
TabOrder = 0
end
end
object rdoImportance: TRadioGroup
Left = 61
Top = 72
Width = 185
Height = 57
Caption = 'Importance'
Items.Strings = (
'Low'
'Normal'
'High')
TabOrder = 2
end
end
object cmdExit: TButton
Left = 437
Top = 295
Width = 75
Height = 25
Caption = 'E&xit'
TabOrder = 1
OnClick = mnuExitdemoClick
end
object StatusBar1: TStatusBar
Left = 0
Top = 322
Width = 514
Height = 19
Panels = <>
SimplePanel = False
end
object MainMenu1: TMainMenu
Left = 614
Top = 178
object mnuFile: TMenuItem
Caption = '&File'
object mnuAbout: TMenuItem
Caption = '&About'
end
object Sep1: TMenuItem
Caption = '-'
end
object mnuExitdemo: TMenuItem
Caption = 'E&xit'
OnClick = mnuExitdemoClick
end
end
end
object OpenDialog1: TOpenDialog
Filter =
'MS-Word document|*.doc|MS-Excel spreadsheet|*.xls|MS-DOS text fi' +
'le|*.txt|BitMap file|*.bmp|All file(s)|*.*'
Left = 612
Top = 118
end
end |
|
