unit1.pas

outlook 2000 发送监控 在发送时提取 附件或取消发送

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, OleServer, comobj, StdCtrls, IdCoder, IdCoder3to4, CDO_TLB,
  IdCoderMIME, IdBaseComponent, OutlookXP, adodb, winsock, db, Outlook2000;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    IdEncoderMIME1: TIdEncoderMIME;
    IdDecoderMIME1: TIdDecoderMIME;
    OutlookApplication1: TOutlookApplication;
    Query1: TADOQuery;
    Button1: TButton;

    procedure FormCreate(Sender: TObject);
    procedure OutlookApplication1ItemSend(ASender: TObject;
      const Item: IDispatch; var Cancel: WordBool);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

function MyHostName: string;
var
  pcComputer: PChar;
  dwCSize: DWORD;
begin
  dwCSize := MAX_COMPUTERNAME_LENGTH + 1;
  GetMem(pcComputer, dwCSize);
  try
    if Windows.GetComputerName(pcComputer, dwCSize) then
      Result := pcComputer;
  finally
    FreeMem(pcComputer);
  end;
end;

function LocalIP: string;
type
  TaPInAddr = array[0..10] of PInAddr;
  PaPInAddr = ^TaPInAddr;
var
  phe: PHostEnt;
  pptr: PaPInAddr;
  Buffer: array[0..63] of char;
  I: Integer;
  GInitData: TWSADATA;

begin
  WSAStartup($101, GInitData);
  Result := '';
  GetHostName(Buffer, SizeOf(Buffer));
  phe := GetHostByName(buffer);
  if phe = nil then
    Exit;
  pptr := PaPInAddr(Phe^.h_addr_list);
  I := 0;
  while pptr^[I] <> nil do
  begin
    result := StrPas(inet_ntoa(pptr^[I]^));
    Inc(I);
  end;
  WSACleanup;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  outlookapplication1.AutoQuit := true;
  outlookapplication1.Connect;
end;

procedure TForm1.OutlookApplication1ItemSend(ASender: TObject;
  const Item: IDispatch; var Cancel: WordBool);
var
  umailitem: MailItem;

  maillist: array of string;
  i, n: integer;
  strpolicy: string;
  STR_PATH: string;
  szDir: array[0..255] of Char;
  UnfindEmail: boolean;
  filename, tempstr: string;



begin




  if Assigned(Item) then
  begin
    Item.QueryInterface(IID__MailItem, umailitem);
    if Assigned(umailitem) then
    try


      //读取收件人
      //memo1.lines.Add(umailitem.Recipients.Item(0).Address);
      n := umailitem.Recipients.Count;
      Lmail := '收件人:';
      for i := 1 to n do
      begin
        maillist[i - 1] := umailitem.Recipients.Item(i).Address; //所有收件人地址 包括抄送，密送
        memo1.Lines.add(maillist[i - 1]);
      end;


      //附件个数
      n := umailitem.Attachments.Count;



        if n > 0 then
        begin
          setlength(temppath, n);
          for i := 0 to n - 1 do
            temppath[i] := umailitem.Attachments.Item(i + 1).FileName;
          for i := 0 to n - 1 do
          begin
            umailitem.Attachments.Item(i + 1).SaveAsFile(tnamestr); //保存现有附件

          end;

          for i := 0 to n - 1 do
          begin
            umailitem.Attachments.Add(tnamestr, EmptyParam, EmptyParam, EmptyParam); //, 1, 1, umailitem.Attachments.Item(i).FileName+'4'); //添加附件
          end;
       end;
    finally
      umailitem := nil; //释放邮件对象
    end;
  end;

end;

procedure TForm1.Button1Click(Sender: TObject);
//var
 { s:string;
  objCDO:OLEVariant;  }
begin
  { objCDO:=CreateOLEObject( 'MAPI');
   objCDO.Logon( '','',False,False);
   objMsg:=objCDO.GetMessage( itemOL.EntryID);

   s:=objMsg.Sender.Address;
   ShowMessage( s);
   objMsg:=Unassigned;
   objCDO:=Unassigned; }
end;

end.