调用系统默认邮件程序发送邮件(支持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.