email.pas

收发MAPI E-Mail(非SMTP E-mail), 传真的构件

  W32RegQueryValueEx: function( hKey: HKEY; lpValueName: PChar;
                                lpReserved: Pointer; lpType: PDWORD;
                                lpData: PByte; lpcbData: PDWORD;
                                id: longint): longint;

procedure InitWin32; far;
begin
  @W32RegQueryValueEx := @Call32;
  id_W32RegQueryValueEx := Declare32('RegQueryValueEx', 'advapi32', 'ippppp');
{
function RegQueryValueEx(hKey: HKEY; lpValueName: PChar;
  lpReserved: Pointer; lpType: PDWORD; lpData: PByte; lpcbData: PDWORD): Longint; stdcall;
}

  @W32RegOpenKeyEx := @Call32;
  id_W32RegOpenKeyEx := Declare32('RegOpenKeyEx', 'advapi32', 'ipiip');
{
function RegOpenKeyEx(hKey: HKEY; lpSubKey: PChar;
  ulOptions: DWORD; samDesired: REGSAM; var phkResult: HKEY): Longint; stdcall;
}

  @W32RegCloseKey := @Call32;
  id_W32RegCloseKey := Declare32('RegCloseKey', 'advapi32', 'i');
{
function RegCloseKey(hKey: HKEY): Longint; stdcall;
}
end;

function RegOpenKeyEx32( ahKey: HKEY; lpSubKey: PChar;
                         ulOptions: DWORD; samDesired: longint;
                         var phkResult: HKEY): Longint;
var
  aKey : HKEY;
begin
  RegOpenKeyEx32 := W32RegOpenKeyEx(ahKey, lpSubKey, ulOptions, samDesired, @aKey, id_W32RegOpenKeyEx);
  phkResult := aKey;
end;

function RegCloseKey32(ahKey: HKEY): Longint;
begin
  RegCloseKey32 := W32RegCloseKey(ahKey, id_W32RegCloseKey);
end;


function RegQueryValueEx32( hKey: HKEY; lpValueName: PChar; lpReserved: Pointer;
                            lpType: DWORD; lpData: PByte; var lpcbData: DWORD): longint;
var
  theData: DWORD;
begin
  theData := lpcbData;
  RegQueryValueEx32 := W32RegQueryValueEx( hKey, lpValueName, nil, @lpType,
                                           lpData, @lpcbData, id_W32RegQueryValueEx);

end;
{$ENDIF UseGenericThunks} {$ENDIF WIN32}


{ Logon to E-Mail system. }
{-------------------------}

function TEmail.Logon: Integer;
const
  ProfileKey95 = 'Software\Microsoft\Windows Messaging Subsystem\Profiles';
  ProfileKeyNT = 'Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles';
var
  LogonProfile : PChar;
  LogonPassword: PChar;

  ProfileKey   : PChar;

{$IFDEF WIN32}
  Reg : TRegistry;
{$ELSE}
  {$IFDEF UseGenericThunks}
    RegHandle: HKEY;
    RegDataSize: longint;
    RegResult : longint;
  {$ENDIF UseGenericThunks}
{$ENDIF WIN32}

begin
  CheckMapi;

  Result := SUCCESS_SUCCESS;

  { Check if already logged in. }

  if hSession = 0 then
  begin

    if FUseDefProfile then
    begin
    {$IFDEF WIN32}
      Reg := TRegistry.Create;
      try
        { get platform (Win95/NT) dependent profile key                }
        {  code added by Ulrik Schoth [e-mail] }
        if Reg.KeyExists(ProfileKeyNT) then
        begin
          ProfileKey := ProfileKeyNT;
        end
        else
        begin
          ProfileKey := ProfileKey95;
        end;

        Reg.Rootkey := HKEY_CURRENT_USER;
        if Reg.OpenKey(ProfileKey, False) then
        begin
          try
            FProfile := Reg.Readstring('DefaultProfile');
          except
            FProfile := '';
          end;
        end;
      finally
        Reg.Free;
      end;
    {$ELSE}
      {$IFDEF UseGenericThunks}
        if Call32NTError = false then
        begin
          RegResult := RegOpenKeyEx32( HKEY_CURRENT_USER,
                                       ProfileKeyNT,
                                       0,
                                       KEY_QUERY_VALUE,
                                       RegHandle);

          { what, no NT registry entry ?? - then try Win95 entry }
          if RegResult <> ERROR_SUCCESS then
            RegResult := RegOpenKeyEx32( HKEY_CURRENT_USER,
                                         ProfileKey95,
                                         0,
                                         KEY_QUERY_VALUE,
                                         RegHandle);

          RegDataSize := SizeOf(FProfile)-1;
          RegResult := RegQueryValueEx32( RegHandle,
                                          'DefaultProfile',
                                          nil,
                                          REG_SZ,
                                          pointer(PChar(@FProfile)+1),
                                          RegDataSize);
          FProfile[0] := char(StrLen(PChar(@FProfile)+1));

          RegResult := RegCloseKey32(RegHandle);
        end;
      {$ENDIF UseGenericThunks}
    {$ENDIF WIN32}
    end;

    LogonProfile := nil;
    LogonPassword := nil;

    try
      if Length(FProfile) > 0 then
      begin
        LogonProfile := StrPCopy(StrAlloc(Length(FProfile)+1), FProfile);
      end;

      if Length(FPassword) > 0 then
      begin
        LogonPassword := StrPCopy(StrAlloc(Length(FPassword)+1), FPassword);
      end;

      DoBeforeLogon;

      Result := MapiLogon(0, LogonProfile, LogonPassword, flLogonFlags, 0, @hSession);
      if Result <> SUCCESS_SUCCESS then
        Result := MapiLogon(0, nil, nil, flLogonFlags or MAPI_Logon_UI, 0, @hSession);

      if Result = SUCCESS_SUCCESS then
        DoAfterLogon
      else
        DoMapiError(Result);

    finally
      StrDispose(LogonProfile);
      StrDispose(LogonPassword);
    end;
  end;
end;


{ Logoff E-Mail system. }
{-----------------------}

function TEmail.Logoff: Integer;
begin
  CheckMapi;

  Result := SUCCESS_SUCCESS;

  if hSession <> 0 then
  begin
    DoBeforeLogoff;

    Result   := MapiLogoff(hSession, 0, 0, 0);
    hSession := 0;

    DoAfterLogoff;
  end;
end;

{ Download e-mail messages now }
{------------------------------}

procedure TEmail.DownLoad;
begin
  DownLoadFirst := True;
  Logoff;
  Logon;
end;

{ truncate Attachment filename to 8.3 - specs and code by MJK }
{ slightly modified by Stefan Hoffmeister                     }
{-------------------------------------------------------------}
function TEmail.TruncAttachmentFN(const LongFN: SString): SString;
var
  Att83         : SString;
  Att83p        : Integer;
begin
  { Include the following if.....END section, ONLY if the
  { Attachment name should be truncated to about 12 chars,
    (usually in 8.3 format), and with the LEADING chars being
    discarded, if needed.                                      }

  if Length(LongFN) > 12 then
  begin
    Att83 := LongFN;
    Att83p := Pos('.', Att83);

    if Att83p > 9 then
    begin
      { }
      Att83 := Copy(Att83, Att83p-8, Length(Att83) - Att83p + 9);
    end;

    if Length(Att83) > 12 then
      Att83 := Copy(Att83, Length(Att83)-11, 12);

    while Att83[1] = '.' do
      Att83 := Copy(Att83, 2, Length(Att83)-1);

    TruncAttachmentFN := Att83;
  end
  else
  begin
    Result := LongFN; { no changes required }
  end;
end;

{ Send Mail message. }
{--------------------}

function TEmail.SendMailEx(DoSave: boolean): Integer;
var
  MapiMessage   : TMapiMessage;
  MapiRecipDesc : TMapiRecipDesc;
  MapiFileDesc  : TMapiFileDesc;
  lpRecipArray  : TlpRecipArray;
  lpAttachArray : TlpAttachArray;
  lpszPathname  : TlpszPathname;
  lpszFileName  : TlpszFileName;

  szSubject     : PChar;
  szText        : PChar;
  szMessageId   : PChar;
  szMessageType : PChar;

  Attachment    : SString;
  flFlags       : ULONG;
  flLogoff      : Boolean;

  i             : Integer;
  nRecipients   : Integer;
  nAttachments  : Integer;

begin
  CheckMapi;

  {make sure the cleanup does not free garbage }
  lpRecipArray  := nil;
  lpAttachArray := nil;

  flLogoff      := False;

  {check our built-in limits - which have effectively been removed }
  nRecipients := Frecip.Count + FCC.Count + FBCC.Count;
  if nRecipients > RECIP_MAX then
  begin
    Result := MAPI_E_TOO_MANY_RECIPIENTS;

    DoMapiError(Result);

    exit;
  end;

  nAttachments := FAttachment.Count;
  if nAttachments > ATTACH_MAX then
  begin
    Result := MAPI_E_TOO_MANY_FILES;

    DoMapiError(Result);

    exit;
  end;

  { begin the work }
  try

    flLogoff := (hSession = 0);

    { Logon to mail server if not already logged on. }

    if Logon <> SUCCESS_SUCCESS then
    begin
      Result := MAPI_E_LOGIN_FAILURE;

      DoMapiError(Result);
      
      exit;
    end;


    { Initialise MAPI structures and local arrays. }

    FillChar(MapiMessage,   SizeOf(TMapiMessage),   0);
    FillChar(MapiRecipDesc, SizeOf(TMapiRecipDesc), 0);
    FillChar(MapiFileDesc,  SizeOf(TMapiFileDesc),  0);

    lpRecipArray  := TlpRecipArray(StrAlloc(nRecipients*SizeOf(TMapiRecipDesc)));
    FillChar(lpRecipArray^, StrBufSize(PChar(lpRecipArray)), 0);

    lpAttachArray := TlpAttachArray(StrAlloc(nAttachments*SizeOf(TMapiFileDesc)));
    FillChar(lpAttachArray^, StrBufSize(PChar(lpAttachArray)), 0);

    { Fill in subject & message text. }

    szSubject      := nil;
    szText         := nil;
    szMessageId    := nil;
    szMessageType  := nil;

    try
      if Length(FSubject) > 0 then
      begin
        szSubject := StrAlloc(length(FSubject) + 1);
        StrPCopy(szSubject, FSubject);
      end;
      MapiMessage.lpszSubject  := szSubject;

      if Length(FText) > 0 then
      begin
        szText := StrAlloc(length(FText) + 1);
        StrPCopy(szText, FText);
      end;
      MapiMessage.lpszNoteText := szText;

      { for non-IPM messages }
      if Length(FMessageType) > 0 then
      begin
        szMessageType := StrAlloc(Length(FMessageType) + 1);
        StrPCopy(szMessageType, FMessageType);
      end;
      MapiMessage.lpszMessageType := szMessageType;

      if FpLongText <> nil then
        MapiMessage.lpszNoteText := FpLongText;

      { check and fill in recipients if any}
      nRecipients := 0;
      ListToRecipArray(FRecip, MAPI_TO,  lpRecipArray, nRecipients);
      ListToRecipArray(FCC,    MAPI_CC,  lpRecipArray, nRecipients);
      ListToRecipArray(FBcc,   MAPI_BCC, lpRecipArray, nRecipients);


      MapiMessage.nRecipCount := nRecipients;

      if nRecipients > 0 then
      begin
        if FShowDialog then
          flFlags := MAPI_DIALOG
        else
          flFlags := 0; { Don't display MAPI Dialog if recipient specified. }

        MapiMessage.lpRecips := @lpRecipArray^;
      end
      else
      begin
        flFlags := MAPI_DIALOG; { we need to show the dialog }
        MapiMessage.lpRecips  := nil ;
      end;

      { Process file attachments. }

      nAttachments := 0;

      for i := 0 to (Fattachment.Count - 1) do
      begin
        Attachment := CheckAttachment(Fattachment.Strings[i]);
        if Length(Attachment) = 0 then
        begin
          Result := MAPI_E_ATTACHMENT_NOT_FOUND;

          DoMapiError(Result);
          
          exit;
        end;
        lpAttachArray^[i].nPosition    := Integer($FFFFFFFF);  {Top of message. }
        lpszPathname                   := new(TlpszPathname);
        lpAttachArray^[i].lpszPathName := StrPcopy(lpszPathname^, Attachment);


      { begin code added by MJK }
        lpszFileName                   := new(TlpszFileName);

        { truncate attachment filename if desired }
        if FTruncAttFN then
        begin
          { truncate }
          lpAttachArray^[i].lpszFileName :=
            StrPCopy(lpszFileName^, TruncAttachmentFN(ExtractFileName(Attachment)))
        end
        else
        begin
          { leave alone }
          lpAttachArray^[i].lpszFileName :=
            StrPCopy(lpszFileName^, ExtractFileName(Attachment));
        end;
      {end code added by MJK}

        Inc(nAttachments);
      end;

      MapiMessage.nFileCount := nAttachments;
      if nAttachments > 0 then
      begin
        MapiMessage.lpFiles := @lpAttachArray^;
      end
      else
      begin
        MapiMessage.lpFiles := nil;
      end;

      { receipt requested ? }
      if FAcknowledge then
        MapiMessage.flFlags := MapiMessage.flFlags or MAPI_RECEIPT_REQUESTED;

      if DoSave then
      begin
        { set the message ID; leave nil if MessageID is empty }
        if FMessageID <> '' then
        begin
          szMessageId := StrAlloc(MsgIdSize);
          StrPcopy(SzMessageId, FMessageId);
        end;

        { finally save the email message }
        DoBeforeSaveMail;

        Result := MapiSaveMail(hSession, 0, @MapiMessage, 0, 0, szMessageId);
        if Result <> SUCCESS_SUCCESS then
          DoMapiError(Result)
        else
          DoAfterSaveMail;
      end
      else
      begin
        { finally send the email message }

        DoBeforeSendMail;

        Result := MapiSendMail(hSession, 0, @MapiMessage, flFlags, 0);
        if Result = SUCCESS_SUCCESS then
          DoAfterSendMail
        else
          DoMapiError(Result);
      end;


    finally