Solved

Delphi: How can I read mails from an Outlook folder and save them as .txt files

Posted on 2010-09-16
5
678 Views
Last Modified: 2012-05-10
I need to iterate over all mails in a folder in Outlook and extract the text of the emails for further processing. The solution doesn't have to be pretty; just a pragmatic way for accessing the text of the mails would suffice.

I tried the approach with an ADO Connection. This works fine for iterating over the mails. I can read the subject, length, recipient and other data but I don't know how to get the text of the mail itself. It seems that I have to cast the content to some object but I have no idea what object. If you know how to do that would also be enough for me.

Many thanks in advance.

Regards,

Dirk.
0
Comment
Question by:dirkil2
  • 2
  • 2
5 Comments
 
LVL 25

Expert Comment

by:Luis Pérez
Comment Utility
I don't know how you're accessing the Outlook items via ADO.net, but have you tried the "Body" property to get the text of the e-mail?
0
 
LVL 36

Accepted Solution

by:
Geert Gruwez earned 500 total points
Comment Utility
this is something i developed to get the mails from outlook 2007
(you need 2007 to eliminate the annyoing popup, to allow reading the mails by a external app)

it looks in my inbox (folder SAP ALERTS) for mail with the text in textFind

The app also creates a insert in the oracle db to send a sms
A other app picks this up and sends the sms (just a way of allowing multiple apps to send a sms :) )
unit uTest;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, OleServer, OutlookXP, Buttons, ExtCtrls;

const
  FolderFind = 'SAP ALERTS';
  textFind = 'ALERT for SOL \ Availability \,RED CCMS alert';
  MaxAttempts = 60;
  OraServer = '#######';
  OraUser   = '#######';
  OraPass   = '#######';
  OraSmsProc = '####################################';
  MaxSmsLen = 160;
  SmsRecipients = '###############'; 
  MaxLines = 500;
  MaxLinesDelta = 25;

type
  TfrmSapAlerter = class(TForm)
    memInfo: TMemo;
    outlook: TOutlookApplication;
    pnlOptions: TPanel;
    btnStart: TBitBtn;
    btnStop: TBitBtn;
    timerCheck: TTimer;
    timerStart: TTimer;
    btnRunNow: TBitBtn;
    btnConfig: TBitBtn;
    chkTest: TCheckBox;
    procedure btnStartClick(Sender: TObject);
    procedure timerCheckTimer(Sender: TObject);
    procedure btnStopClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure timerStartTimer(Sender: TObject);
    procedure btnRunNowClick(Sender: TObject);
  private
    fRunning: Boolean;
    procedure AddMsg(Msg: String);
    function FindFolder(aName: string; aFolder: MapiFolder): MapiFolder;
    function ValidMsg(m: MailItem): Boolean;
    procedure SendSms(Msg: string);
    procedure CheckMails;
    procedure SetRunning(const Value: boolean);
    function DoSendSms(nr, msg, body: string): boolean;
    procedure WMUser(var Msg: TMessage); message WM_USER;
  protected
    procedure UpdateActions; override;
    property Running: boolean read fRunning write SetRunning;

  public

  end;

var
  frmSapAlerter: TfrmSapAlerter;

implementation

uses MemDS, DBAccess, Ora, StrUtils;

{$R *.dfm}

procedure TfrmSapAlerter.AddMsg(Msg: String);
var I: Integer;
begin
  if memInfo.Lines.Count >= MaxLines then
    for I := 0 to MaxLinesDelta- 1 do
      memInfo.Lines.Delete(0);
  memInfo.Lines.Add(Msg);
end;

procedure TfrmSapAlerter.FormShow(Sender: TObject);
begin
  PostMessage(Handle, WM_USER, 0, 0);
end;

procedure TfrmSapAlerter.WMUser(var Msg: TMessage);
begin
  timerStart.Enabled := True;
end;

function TfrmSapAlerter.DoSendSms(nr, msg, body: string): boolean;
var  s: TOraSession;
  q: TOraStoredProc;
begin
  Result := False;
  s := TOraSession.Create(nil);
  try
    s.Server := OraServer;
    s.Username := OraUser;
    s.Password := OraPass;
    s.LoginPrompt := False;
    try
      AddMsg('Trying database connection ...');
      s.Connect;
      if s.Connected then
      try
        AddMsg('Database connected ...');
        q := TOraStoredProc.Create(nil);
        try
          q.StoredProcName := OraSmsProc;
          try
            q.Prepare;
            q.ParamByName('I_GSMNR').AsString := nr;
            q.ParamByName('I_SUBJECT').AsString := msg;
            q.ParamByName('I_MESSAGE').AsString := body;
            q.ExecProc;
            AddMsg('Sms sent to database !');
            Result := True;
          except
            on E: SysUtils.Exception do
            begin
              AddMsg('Exception occured: ' + E.Message);
            end;
          end;
        finally
          q.Free;
        end;
      finally
        s.Disconnect;
        AddMsg('Database disconnected.');
      end;
    except
      on E: SysUtils.Exception do
      begin
        AddMsg('Connection failed to oracle server');
      end;
    end;
  finally
    s.Free;
  end;
end;

procedure TfrmSapAlerter.SendSms(Msg: string);
var List: TStringList;
  I: Integer;
begin
  if not chkTest.Checked then
  begin
    AddMsg(Msg);
    List := TStringList.Create;
    try
      List.StrictDelimiter := True;
      List.CommaText := SmsRecipients;
      for I := 0 to List.Count - 1 do
        DoSendSms(List[I], 'SAP ALERT', Copy(Msg, 1, MaxSmsLen));
    finally
      List.Free;
    end;
  end else
    AddMsg('SendSms Test: ' + Msg);
end;

procedure TfrmSapAlerter.SetRunning(const Value: boolean);
begin
  fRunning := Value;
  timerCheck.Enabled := False;
  timerCheck.Enabled := Value;
  AddMsg('Mail check ' + IfThen(Value, '', 'not ') + 'running ' + DateTimeToStr(Now));
end;

procedure TfrmSapAlerter.timerCheckTimer(Sender: TObject);
begin
  timerCheck.Enabled := False;
  AddMsg('Starting check '+  DateTimeToStr(Now));
  CheckMails;
  timerCheck.Enabled := fRunning;
end;

procedure TfrmSapAlerter.timerStartTimer(Sender: TObject);
begin
  Running := True;
  timerStart.Enabled := False;
end;

procedure TfrmSapAlerter.UpdateActions;
begin
  btnStart.Enabled := not fRunning;
  btnStop.Enabled := timerStart.Enabled or fRunning;
end;

procedure TfrmSapAlerter.btnStopClick(Sender: TObject);
begin
  timerStart.Enabled := False;
  Running := False;
end;

procedure TfrmSapAlerter.btnRunNowClick(Sender: TObject);
begin
  CheckMails;
end;

procedure TfrmSapAlerter.btnStartClick(Sender: TObject);
begin
  Running := True;
end;

function TfrmSapAlerter.FindFolder(aName: string; aFolder: MapiFolder): MapiFolder;
var
  I: OleVariant;
  n: Integer;
  x: MapiFolder;
begin
  Result := nil;
  if aFolder.Name = aName then
    Result := aFolder
  else
  begin
    n := aFolder.Folders.Count;
    if n > 0 then
    begin
      I := 1;
      while I <= n do
      begin
        x := FindFolder(aName, aFolder.Folders.Item(I));
        if Assigned(x) then
        begin
          Result := X;
          Break;
        end;
        I := I +1;
      end;
    end;
  end;
end;

function TfrmSapAlerter.ValidMsg(m: MailItem): Boolean;
var
  List: TStringList;
  I, n: integer;
  Msg: string;
begin
  Result := False;
  Msg := UpperCase(m.Body);
  List := TStringList.Create;
  try
    List.StrictDelimiter := True;
    List.CommaText := textFind;
    n := 0;
    for I := 0 to List.Count - 1 do
      if Pos(UpperCase(List[I]), Msg) > 0 then
        Inc(n);
    if n >= List.Count then
      Result := True;
  finally
    List.Free;
  end;
end;

procedure TfrmSapAlerter.CheckMails;
var f: MapiFolder;
  n: Integer;
  I: OleVariant;
  m: MailItem;
  x: IDispatch;
begin
  outlook.Connect;
  try
    I := 1;
    f := FindFolder(FolderFind, outlook.GetNamespace('MAPI').GetDefaultFolder(olFolderInbox));
    if Assigned(f) then
    begin
      I := 1;
      n := f.Items.Count;
      while I < n do
      begin
        x := f.Items.Item(I);
        if x.QueryInterface(_MailItem, m) = S_OK then
        begin
          if m.UnRead <> False then
          begin
            if ValidMsg(m) then
            begin
              SendSms(m.Subject + ' ' + m.Body);
              m.UnRead := False;
            end;
          end;
        end;
        I := I + 1;
      end;
    end;
  finally
    outlook.Disconnect;
  end;
end;

end.

Open in new window

0
 
LVL 36

Expert Comment

by:Geert Gruwez
Comment Utility
dfm
object frmSapAlerter: TfrmSapAlerter
  Left = 365
  Top = 206
  Caption = 'Sap Alert SMS sender [DO NOT CLOSE APPLICATION !]'
  ClientHeight = 451
  ClientWidth = 590
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnShow = FormShow
  PixelsPerInch = 96
  TextHeight = 13
  object memInfo: TMemo
    Left = 0
    Top = 65
    Width = 590
    Height = 386
    Align = alClient
    ScrollBars = ssBoth
    TabOrder = 0
  end
  object pnlOptions: TPanel
    Left = 0
    Top = 0
    Width = 590
    Height = 65
    Align = alTop
    BevelOuter = bvNone
    TabOrder = 1
    object btnStart: TBitBtn
      Left = 7
      Top = 5
      Width = 75
      Height = 57
      Caption = 'Start'
      DoubleBuffered = True
      ParentDoubleBuffered = False
      TabOrder = 0
      OnClick = btnStartClick
    end
    object btnStop: TBitBtn
      Left = 103
      Top = 5
      Width = 75
      Height = 57
      Caption = 'Stop'
      DoubleBuffered = True
      ParentDoubleBuffered = False
      TabOrder = 1
      OnClick = btnStopClick
    end
    object btnRunNow: TBitBtn
      Left = 207
      Top = 5
      Width = 75
      Height = 57
      Caption = 'Run now'
      DoubleBuffered = True
      ParentDoubleBuffered = False
      TabOrder = 2
      OnClick = btnRunNowClick
    end
    object btnConfig: TBitBtn
      Left = 311
      Top = 5
      Width = 75
      Height = 57
      Caption = 'Config'
      DoubleBuffered = True
      ParentDoubleBuffered = False
      TabOrder = 3
    end
    object chkTest: TCheckBox
      Left = 408
      Top = 16
      Width = 97
      Height = 17
      Caption = 'Testing'
      Checked = True
      State = cbChecked
      TabOrder = 4
    end
  end
  object outlook: TOutlookApplication
    AutoConnect = False
    ConnectKind = ckRunningOrNew
    AutoQuit = False
    Left = 400
    Top = 32
  end
  object timerCheck: TTimer
    Interval = 600000
    OnTimer = timerCheckTimer
    Left = 336
    Top = 32
  end
  object timerStart: TTimer
    Enabled = False
    Interval = 5000
    OnTimer = timerStartTimer
    Left = 280
    Top = 104
  end
end

Open in new window

0
 

Author Comment

by:dirkil2
Comment Utility
Thanks for the asnwer. I haven't had time to check it. I will do that soon.
0
 

Author Closing Comment

by:dirkil2
Comment Utility
Thank you for your good answer.
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

Suggested Solutions

Find out how to use dynamic social media in email signatures with this top 10 DOs & DON’Ts.
Resolve Outlook connectivity issues after moving mailbox to new Exchange 2016 server
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …

728 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

9 Experts available now in Live!

Get 1:1 Help Now