Send email by calling Outlook 2013

Question

To send emails use the function Sendemail:

function SendEMail(Handle: THandle; Mail: TStrings): Cardinal;
type
  TAttachAccessArray = array [0..0] of TMapiFileDesc;
  PAttachAccessArray = ^TAttachAccessArray;
var
  MapiMessage: TMapiMessage;
  Receip, ComCopia: TMapiRecipDesc;
  Attachments: PAttachAccessArray;
  AttachCount: Integer;
  i1: integer;
  FileName: string;
  dwRet: Cardinal;
  MAPI_Session: Cardinal;
  WndList: Pointer;

  aRecep: Array of TMapiRecipDesc;
  iRecipC, iCont: Integer;
  sAuxCCo, sCCo, sTO: String;
begin
  dwRet := MapiLogon(Handle, PAnsiChar(''), PAnsiChar(''), MAPI_LOGON_UI or MAPI_NEW_SESSION, 0, @MAPI_Session);
  if (dwRet <> SUCCESS_SUCCESS) then
  begin
    MessageBox(Handle, PChar('Error while trying to send email'#10+SysErrorMessage(GetLastError)), PChar('Error'), MB_ICONERROR or MB_OK);
  end
  else
  begin
    AttachCount := 0;
    Attachments := nil;
    try
      FillChar(MapiMessage, SizeOf(MapiMessage), #0);
      FillChar(Receip, SizeOf(Receip), #0);
      FillChar(ComCopia, SizeOf(ComCopia), #0);

      iRecipC := 0;
      if Mail.Values['to'] <> '' then
      begin
        sAuxCCo := Mail.Values['to'];
        if (sAuxCCo[Length(sAuxCCo)] <> ';') then
          sAuxCCo := sAuxCCo + ';';
        while (Pos(';',sAuxCCo)) > 0 do
        begin
          sTO := sTO + Copy(sAuxCCo,1,Pos(';',sAuxCCo));
          Delete(sAuxCCo,1,Pos(';',sAuxCCo));
          Inc(iRecipC);
        end;
      end;

      if Mail.Values['CCo'] <> '' then
      begin
        sAuxCCo := Mail.Values['CCo'];
        if (sAuxCCo[Length(sAuxCCo)] <> ';') then
          sAuxCCo := sAuxCCo + ';';
        while (Pos(';',sAuxCCo)) > 0 do
        begin
          sCCo := sCCo + Copy(sAuxCCo,1,Pos(';',sAuxCCo));
          Delete(sAuxCCo,1,Pos(';',sAuxCCo));
          Inc(iRecipC);
        end;
      end;

      SetLength(aRecep, iRecipC);

      iCont := 0;
      if sTO <> '' then
      begin
        while ((sTO) <> '') do
        begin
          sAuxCCo := Copy(sTO,1,Pos(';',sTO)- 1);

          aRecep[iCont].ulReserved   := 0;
          aRecep[iCont].ulRecipClass := MAPI_TO;
          aRecep[iCont].lpszName     := StrNew(PAnsiChar(AnsiString(sAuxCCo)));
          aRecep[iCont].lpszAddress  := StrNew(PAnsiChar(AnsiString('SMTP:' + sAuxCCo)));
          aRecep[iCont].ulEIDSize    := 0;

          Delete(sTO,1,Pos(';',sTO));
          Inc(iCont);
        end;
      end;

      if sCCo <> '' then
      begin
        while ((sCCo) <> '') do
        begin
          sAuxCCo := Copy(sCCo,1,Pos(';',sCCo)- 1);

          aRecep[iCont].ulReserved   := 0;
          aRecep[iCont].ulRecipClass := MAPI_BCC;
          aRecep[iCont].lpszName     := StrNew(PAnsiChar(AnsiString(sAuxCCo)));
          aRecep[iCont].lpszAddress  := StrNew(PAnsiChar(AnsiString('SMTP:' + sAuxCCo)));
          aRecep[iCont].ulEIDSize    := 0;

          Delete(sCCo,1,Pos(';',sCCo));
          Inc(iCont);
        end;
      end;

      AttachCount := 0;

      for i1 := 0 to MaxInt do
      begin
        if Mail.Values['attachment' + IntToStr(i1)] = '' then
          break;
        Inc(AttachCount);
      end;

      if AttachCount > 0 then
      begin
        GetMem(Attachments, SizeOf(TMapiFileDesc) * AttachCount);

        for i1 := 0 to AttachCount - 1 do
        begin
          FileName := Mail.Values['attachment' + IntToStr(i1)];
          Attachments[i1].ulReserved := 0;
          Attachments[i1].flFlags := 0;
          Attachments[i1].nPosition := ULONG($FFFFFFFF);
          Attachments[i1].lpszPathName := StrNew(PAnsiChar(AnsiString(FileName)));
          Attachments[i1].lpszFileName := StrNew(PAnsiChar(AnsiString(ExtractFileName(FileName))));
          Attachments[i1].lpFileType := nil;
        end;
      end;

      with MapiMessage do
      begin
        ulReserved         := 0;
        lpszSubject        := StrNew(PAnsiChar(AnsiString(Mail.Values['subject'])));
        lpszNoteText       := StrNew(PAnsiChar(AnsiString(Mail.Values['body'])));
        lpszMessageType    := Nil;
        lpszDateReceived   := Nil;
        lpszConversationID := Nil;
        flFlags            := 0;
        lpOriginator       := Nil;
        nRecipCount        := iRecipC;
        lpRecips           := @aRecep[0];
        nFileCount         := AttachCount;
        lpFiles            := @Attachments[0];
      end;

      WndList := DisableTaskWindows(0);
      try
        Result := MapiSendMail(MAPI_Session, Handle, MapiMessage, MAPI_DIALOG, 0);
      finally
        EnableTaskWindows( WndList );
      end;
    finally
      for i1 := 0 to AttachCount - 1 do
      begin
        StrDispose(Attachments[i1].lpszPathName);
        StrDispose(Attachments[i1].lpszFileName);
      end;

      if Assigned(MapiMessage.lpszSubject) then
        StrDispose(MapiMessage.lpszSubject);
      if Assigned(MapiMessage.lpszNoteText) then
        StrDispose(MapiMessage.lpszNoteText);
      if Assigned(Receip.lpszAddress) then
        StrDispose(Receip.lpszAddress);
      if Assigned(Receip.lpszName) then
        StrDispose(Receip.lpszName);

      MapiLogOff(MAPI_Session, Handle, 0, 0);
    end;
  end;
end;

Until the Office 2010 it works perfectly, but from the Office 2013 does not work anymore. The error pops right after processing the first line, generating the message:

MessageBox(Handle, PChar('Error while trying to send email'#10+SysErrorMessage(GetLastError)), PChar('Error'), MB_ICONERROR or MB_OK);

Does anyone know how to solve?

Answer 1

Based on the comments. an alternative solution to your problem would be to run a shell or . bat command with "mailto:"

Ex.: ShellExecute(0, 'open', 'mailto:', '', nil, SW_HIDE);