调用系统默认邮件程序发送邮件(支持Foxmail带附件但有些问题)

因客户要求利用系统默认发送邮件并要支持Foxmail,于是动手试了下,下面的代码可以运行,但用Foxmail发送附件很有问题:1.文件路径名不能出现空格 2.路径必须是正确否则无法打开写邮件窗体.建议用纯文本格式发送, 5.0版本只能用纯文本格式发送,

操作:先用SKY++软件查看Foxmail,取得窗体的类名及收件人抄送等类名,还有要看清楚级别(优先级)用于if TRichEditCount=2 then 这里就用到了.具体看代码吧.

unit GMailfun;
interface
uses windows,SysUtils,Graphics,Messages, forms,classes,StdCtrls,dialogs,SHDocVw,mapi;

type
  ClipboardType =(Ctext,Cbitmap,Cother);   //剪贴板格式

function ReadFoxmailINI(var key:string):Boolean;   //读注册表，返回Foxmail执行程序路径
function foxmailisdefmail:boolean;   //是否默认FOXMAIL
procedure ShellExecAndWait(dateiname: string; Parameter: string);  //打开FOXMAIL程序并等待
function SendByEmail(sEmail,sEmailCC,attachs,subjects,bodys:string):boolean;    //发送邮件

var foxSemail,foxSemailCC,foxsubjects,foxbodys:string; TzEditorCount,TRichEditCount:integer;
    tempstr:string;tempBmp:TbitMap;Ctype:ClipboardType;       //临时存放剪贴板内容

implementation
uses ShellAPI,Registry,MSHTML,ActiveX,Clipbrd,StrUtils;

type
TObjectFromLResult = function(LRESULT: lResult; const IID: TIID; WPARAM: wParam; out pObject): HRESULT; stdcall;

function  SendByEmail(sEmail,sEmailCC,attachs,subjects,bodys:string):boolean;
var
  strkey:string;
  hFox:HWND;
begin
  result:=false;
  if (not ReadFoxmailINI(strkey)) or (not foxmailisdefmail) then   //默认不是Foxmail就以outlook发送
  begin
    SendToMAPI(sEmail, sEmailCC,'', attachs,bodys, subjects, '','',true);
  end
  else
  begin
     // if GetFoxmailWindow>0 then
    //  sendmessage(GetFoxmailWindow,WM_CLOSE,0,0);       //得到FOXMAIL邮件编辑窗体句柄发送消息关闭该窗体
    hFox:=findwindow('TFoxmail_Main',nil);      //得到Foxmail主窗体句柄
    if (hFox=0) then
    begin
      showmessage('Foxmail程序未开启,请启动后再操作！');
      exit;
    end;
    TzEditorCount:=0;   //初始化用于查找主题
    TRichEditCount:=0;// 初始化用于查找收件人和抄送
    ShellExecAndWait(pchar(strkey),attachs);         //发送多个文件,请在文件路径之间加空格,文件路径或文件名中出现空格或路径不正确不弹出写邮件窗体
    foxSemail:=sEmail;      //收件人                         //如ShellExecAndWait(pchar(strkey),'C:/aa.exe c:/bb.exe');
    foxSemailCC:=sEmailCC;          //抄送
    foxsubjects:=subjects;                //主题
    foxbodys:=bodys;                       //正文内容
    FindFoxMailWindow;
  end;

 result:=true;
end;

function FindFoxMailWindow: THandle;
var
  FoxMailWindowHandle: THandle;

  function GetFoxmailWindow:HWND;   //得到写邮件窗体句柄
  begin
    result:=findwindow('TF_compose',nil);            ////TF_compost为邮件编辑窗口的类名
  end;

function EnumChildWindowsProc(H: HWnd; lparam: longint): Boolean; stdcall;
  var
    s{,clipboardtext}: string;
    IE: IWebBrowser2;
    Document: IHtmlDocument2;
    v: OleVariant;
    bmp:Tbitmap;
  begin
    Result := True;
    SetLength(s, 255);
    GetClassName(h, PChar(s), 255);
    if Pos('TZEDITOR', UpperCase(s)) > 0 then   //查找Foxmail主题的类名
    begin
      TzEditorCount:=TzEditorCount+1;
      if TzEditorCount=1 then  //正文内容
      begin
        Clipboard.AsText:=foxbodyS;         //正文内容(纯文本格式) 注:5.0版本建议用纯文本格式发送
        SendMessage(h, WM_PASTE, 0, 0);
      end;
      if TzEditorCount=2 then    //主题
      begin
        Clipboard.AsText:=foxsubjects;
        SendMessage(h, WM_PASTE, 0, 0);      //主题:无法用WM_SETTEXT得到，只能用该方法
      end;
    end;
    if Pos('TZRICHEDIT', UpperCase(s)) > 0 then   //用于查找抄送及收件人
    begin
      TRichEditCount:=TRichEditCount+1;
      if TRichEditCount=2 then
      SendMessage(h, WM_SETTEXT, 0, LongInt(Pchar(foxsEmailCC)));    //抄送人
      if TRichEditCount=3 then
      SendMessage(h, WM_SETTEXT, 0, LongInt(Pchar(foxsEmail)));    //收件人
    end;
    if Pos('INTERNET EXPLORER_SERVER', UpperCase(s)) > 0 then  //正文内容(HTML格式)
    begin
      GetIEFromHWnd(H, IE);           //根据INTERNET EXPLORER_SERVER类名得到 IWebbrowser2接口
      Document := IE.Document as IHtmlDocument2;
      Document.body.innerText:=foxbodyS;
      Document.Close;
    end;
  end;

begin
  FoxMailWindowHandle := GetFoxmailWindow;          //得到句柄
 // while FoxMailWindowHandle=0 do
  //FoxMailWindowHandle := GetFoxmailWindow;
 // EnumChildWindows(FoxMailWindowHandle, @EnumChildWindowsProc, 0);
  if FoxMailWindowHandle <> 0 then
  begin
    try
      tempbmp:=Tbitmap.Create;
      watchClipboard(true);   //保存剪贴板内容
      EnumChildWindows(FoxMailWindowHandle, @EnumChildWindowsProc, 0);    //遍历得到TZRICHEDIT类型的句柄并保存
      watchClipboard(false);  //写入剪贴板
    finally
      tempbmp.Free;
    end;
  end;
  Result := FoxMailWindowHandle;
end;

 

procedure watchClipboard(flag:Boolean);  //剪贴板flag:true取出剪贴板内容保存为临时,false:把临时内容写入到剪贴板
begin
  if (flag) then
  begin
    if (Clipboard.HasFormat(CF_TEXT) or Clipboard.HasFormat(CF_OEMTEXT)) then
    begin
      tempstr:=Clipboard.astext;      //得到剪贴板内容
      Ctype:=Ctext;
    end
    else
    if (Clipboard.HasFormat(CF_BITMAP)) then
    begin
      tempbmp.Assign(Clipboard);
      Ctype:=Cbitmap;
    end
    else
    Ctype:=Cother;
  end
  else
  begin
    if Ctype=Ctext then
      Clipboard.astext:=tempstr     

   else
    if Ctype=Cbitmap then
    begin
      Clipboard.Assign(tempbmp);
    end;
  end;
end;

{************************************************************
  函数名:GetIEFromHWND
  参数:hWnd,WebBrowser控件的窗口句柄
  功能:通过WM_HTML_GETOBJECT取得控件的IWebbrowser2接口
************************************************************}
function GetIEFromHWND(WHandle: HWND; var IE: IWebbrowser2): HRESULT;
var
  hInst: HWND;
  lRes: Cardinal;
  MSG: Integer;
  pDoc: IHTMLDocument2;
  ObjectFromLresult: TObjectFromLresult;
begin
  hInst := LoadLibrary('Oleacc.dll');
  @ObjectFromLresult := GetProcAddress(hInst, 'ObjectFromLresult');
  if @ObjectFromLresult <> nil then
  begin
    try
      MSG := RegisterWindowMessage('WM_HTML_GETOBJECT');
      SendMessageTimeOut(WHandle, MSG, 0, 0, SMTO_ABORTIFHUNG, 1000, lRes);
      Result := ObjectFromLresult(lRes, IHTMLDocument2, 0, pDoc);
      if Result = S_OK then
        (pDoc.parentWindow as IServiceprovider).QueryService(IWebbrowserApp, IWebbrowser2, IE);
    finally
      FreeLibrary(hInst);
    end;
  end;
end;

function foxmailisdefmail:boolean;

  function ReadiniDefaultMail:string;  //读注册表默认是否Foxmail
  var reg:TRegistry;
  begin
    result:='';
    reg:=Tregistry.Create;
    reg.rootkey:=HKEY_CLASSES_ROOT;
    if reg.openkey('mailto/shell/open/command',false) then
    begin
     result:=reg.ReadString('');
    end;
    reg.CloseKey;
    reg.Destroy;
  end;

begin
  result:=Pos('FOXMAIL', UpperCase(ReadiniDefaultMail)) > 0;
end;

//读注册表，返回Foxmail执行程序路径
function ReadFoxmailINI(var key:string):Boolean;
var reg:TRegistry;
begin
  result:=false;
  reg:=Tregistry.Create;
  reg.rootkey:=HKEY_CURRENT_USER;
  if reg.openkey('SOFTWARE/Aerofox/Foxmail/V3.1',false) then
  begin
    key:=reg.ReadString('FoxmailPath');
    result:=true;
  end;
  reg.CloseKey;
  reg.Destroy;
end;

procedure ShellExecAndWait(dateiname: string; Parameter: string);
var executeInfo: TShellExecuteInfo;
begin
  FillChar(executeInfo, SizeOf(executeInfo), 0);
  with executeInfo do
  begin
    cbSize := SizeOf(executeInfo);
    fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_DDEWAIT;
    Wnd := GetActiveWindow();
    executeInfo.lpVerb := 'open';
    executeInfo.lpParameters := PChar(Parameter);
    lpFile := PChar(dateiname);
    nShow := SW_SHOWNORMAL;
  end;
  ShellExecuteEx(@executeInfo);
  while WaitForSingleObject(executeInfo.hProcess, 50) <> WAIT_OBJECT_0 do
    Application.ProcessMessages;
end;

function SendToMAPI(sTo, sCC, sBCC, sAtts: string;
  const body, subject, SenderName, SenderEmail: string;
  ShowError: boolean = true): Integer;
var
  aTo, aCC, aBCC, aAtts:TstringList;
  SM: TFNMapiSendMail;
  MAPIModule: HModule;

  Msg: MapiMessage;
  lpSender: MapiRecipDesc;
  Recips: array of MapiRecipDesc;
  Att: array of MapiFileDesc;
  p1, p2, p3, LenTo, LenCC, LenBCC, LenAtts: integer;
  sErro: string;

  procedure StrToArray(sor:string;var aarray:TstringList);
  begin
     if sor='' then
     begin
       exit;
     end;
     if pos(';',sor)<>0 then
     begin
        sor:=stringReplace(sor,';',#13#10,[rfReplaceAll])
     end;
     aarray.Text:=sor;
  end;
begin
  try
    aTo:=TstringList.Create; aCC:=TstringList.Create; aBCC:=TstringList.Create; aAtts:=TstringList.Create;
    StrToArray(sTo,aTo);
    StrToArray(sCC,aCC);
    StrToArray(sBCC,aBCC);
    StrToArray(sAtts,aAtts);

    FillChar(Msg, SizeOf(Msg), 0);
   { get the length of all array passed to this function }
    LenTo := aTo.Count;
    LenCC := aCC.Count;
    LenBCC := aBCC.Count;
    LenAtts := aAtts.Count;
   { ... }
    Setlength(Recips, LenTo + LenCC + LenBCC);
    Setlength(Att, LenAtts);
   { to }
    for p1 := 0 to LenTo - 1 do
    begin
      FillChar(Recips[p1], SizeOf(Recips[p1]), 0);
      Recips[p1].ulReserved := 0;
      Recips[p1].ulRecipClass := MAPI_TO;
      Recips[p1].lpszName := pchar(aTo[p1]);
      Recips[p1].lpszAddress := '';
    end;
   { cc }
    for p2 := 0 to LenCC - 1 do
    begin
      FillChar(Recips[p1 + p2], SizeOf(Recips[p1 + p2]), 0);
      Recips[p1 + p2].ulReserved := 0;
      Recips[p1 + p2].ulRecipClass := MAPI_CC;
      Recips[p1 + p2].lpszName := pchar(aCC[p2]);
      Recips[p1 + p2].lpszAddress := '';
    end;
   { bcc }
    for p3 := 0 to LenBCC - 1 do
    begin
      FillChar(Recips[p1 + p2 + p3], SizeOf(Recips[p1 + p2 + p3]), 0);
      Recips[p1 + p2 + p3].ulReserved := 0;
      Recips[p1 + p2 + p3].ulRecipClass := MAPI_BCC;
      Recips[p1 + p2 + p3].lpszName := pchar(aBCC[p3]);
      Recips[p1 + p2 + p3].lpszAddress := '';
    end;
   { atts }
    for p1 := 0 to LenAtts - 1 do
    begin
      FillChar(Att[p1], SizeOf(Att[p1]), 0);
      Att[p1].ulReserved := 0;
      Att[p1].flFlags := 0;
      Att[p1].nPosition := Cardinal($FFFFFFFF); // ULONG(-1);
      Att[p1].lpszPathName := pchar(aAtts[p1]);
      Att[p1].lpszFileName := '';
      Att[p1].lpFileType := nil;
    end;
   { fill the message }
    with Msg do
    begin
      ulReserved := 0;
      if subject <> '' then
        lpszSubject := pChar(subject);
      if body <> '' then
        lpszNoteText := pchar(body);
      if SenderEmail <> '' then
      begin
        lpSender.ulRecipClass := MAPI_ORIG;
        if SenderName = '' then
          lpSender.lpszName := pchar(SenderEmail)
        else
          lpSender.lpszName := pchar(SenderName);
        lpSender.lpszAddress := pchar(SenderEmail);
        lpSender.ulEIDSize := 0;
        lpSender.lpEntryID := nil;
        lpOriginator := @lpSender;
      end
      else
        Msg.lpOriginator := nil;
      Msg.lpszMessageType := nil;
      Msg.lpszDateReceived := nil;
      Msg.lpszConversationID := nil;
      Msg.flFlags := 0;
      Msg.nRecipCount := LenTo + LenCC + LenBCC;
      Msg.lpRecips := @Recips[0];
      Msg.nFileCount := LenAtts;
      Msg.lpFiles := @Att[0];
    end;
    MAPIModule := LoadLibrary(PChar(MAPIDLL));
    if MAPIModule = 0 then
      Result := -1
    else
    try
      @SM := GetProcAddress(MAPIModule, 'MAPISendMail');
      if @SM <> nil then
      begin
        Result := SM(0, Application.Handle, Msg, MAPI_DIALOG or MAPI_LOGON_UI, 0);
      end
      else
        Result := 1;
    finally
      FreeLibrary(MAPIModule);
    end;
    if result <> SUCCESS_SUCCESS then
    begin
     // Here I know that exist better way to get error strings direct from api calls
     // If someone know how do this, please email me
      case result of
        MAPI_E_AMBIGUOUS_RECIPIENT: sErro :=
                  '收件人不明';
//          '"MAPI_E_AMBIGUOUS_RECIPIENT"';
        MAPI_E_ATTACHMENT_NOT_FOUND: sErro :=
                 '找不到附件中的文件';
//          '"MAPI_E_ATTACHMENT_NOT_FOUND"';
        MAPI_E_ATTACHMENT_OPEN_FAILURE: sErro :=
                 '附件打开失败';
//          '"MAPI_E_ATTACHMENT_OPEN_FAILURE"';
        MAPI_E_BAD_RECIPTYPE: sErro :=
                 '收件人不存在';
//          '"MAPI_E_BAD_RECIPTYPE"';
        MAPI_E_FAILURE: sErro :=
                 '发送失败';
//         '"MAPI_E_FAILURE"';
        MAPI_E_INSUFFICIENT_MEMORY: sErro :=
                 '内存不足';
//          '"MAPI_E_INSUFFICIENT_MEMORY"';
        MAPI_E_LOGIN_FAILURE: sErro :=
                 '登录失败';
//          '"MAPI_E_LOGIN_FAILURE"';
        MAPI_E_TEXT_TOO_LARGE: sErro :=
                 '内容过大';
//          '"MAPI_E_TEXT_TOO_LARGE"';
        MAPI_E_TOO_MANY_FILES: sErro :=
                 '文件过多';
//          '"MAPI_E_TOO_MANY_FILES"';
        MAPI_E_TOO_MANY_RECIPIENTS: sErro :=
                 '收件人过多';
//          '"MAPI_E_TOO_MANY_RECIPIENTS"';
        MAPI_E_UNKNOWN_RECIPIENT: sErro :=
                 '未知收件人';
//          '"MAPI_E_UNKNOWN_RECIPIENT"';
//        MAPI_E_USER_ABORT: sErro :=
  //               '"MAPI_E_USER_ABORT"';
//                 '"MAPI_E_USER_ABORT"';
      end;
      if ShowError then
      begin
        if not result=MAPI_E_USER_ABORT then
        MessageDlg('Error sending mail (' + sErro + ').', mtError, [mbOK],
          0);
      end;
    end;
  finally
     aTo.Free;
     aCC.Free;
     aBCC.Free;
     aAtts.Free;
  end;
end;

end.