This example shows how to sign an Email message using the S/MIME protocol, the NIST sha-512 algorithm, and X509 certificate.
procedure TForm1.btnSendClick(Sender: TObject);
var
certificate: TclCertificate;
begin
//build message
clSMimeMessage1.BuildMessage(memText.Lines.Text, '');
clSMimeMessage1.Subject := edtSubject.Text;
clSMimeMessage1.From.FullAddress := edtFrom.Text;
clSMimeMessage1.ToList.EmailAddresses := edtRecipient.Text;
if (cbSign.Checked) then
begin
//validate certificate
if (cbCertificate.ItemIndex < 0) then
begin
raise Exception.Create('The signing certificate is not specified');
end;
certificate := clCertificateStore1.Items[cbCertificate.ItemIndex];
if (certificate.Email <> clSMimeMessage1.From.Email) then
begin
if (MessageDlg('The signing certificate E-mail address does not match the E-mail sender. Continue anyway?',
mtConfirmation, [mbYes, mbNo], 0) <> mrYes) then
begin
Exit;
end;
end;
if not clCertificateStore1.Verify(certificate) then
begin
if (MessageDlg('The certificate is not suitable for signing. Continue anyway?',
mtConfirmation, [mbYes, mbNo], 0) <> mrYes) then
begin
Exit;
end;
end;
//sign message
clSMimeMessage1.Sign();
end;
//send message
clSmtp1.Server := edtSmtpHost.Text;
clSmtp1.Port := StrToInt(edtSmtpPort.Text);
clSmtp1.UserName := edtSmtpUser.Text;
clSmtp1.Password := edtSmtpPassword.Text;
ProgressBar1.Position := 0;
clSmtp1.Open();
try
clSmtp1.Send(clSMimeMessage1);
finally
clSmtp1.Close();
end;
ProgressBar1.Position := 100;
ShowMessage('The E-mail was sent successfully.');
end;
procedure TForm1.btnLoadCertificateClick(Sender: TObject);
var
i: Integer;
begin
clCertificateStore1.Close();
cbCertificate.Clear();
case cbCertificateSource.ItemIndex of
0: clCertificateStore1.ImportFromPFX(edtCertificateFileName.Text, edtCertificatePassword.Text);
1: clCertificateStore1.Open('MY');
end;
for i := 0 to clCertificateStore1.Items.Count - 1 do
begin
if (clCertificateStore1.Items[i].FriendlyName <> '') then
begin
cbCertificate.Items.Add(clCertificateStore1.Items[i].FriendlyName);
end else
begin
cbCertificate.Items.Add(clCertificateStore1.Items[i].IssuedTo);
end;
end;
if (cbCertificate.Items.Count > 0) then
begin
cbCertificate.ItemIndex := 0;
end;
end;
procedure TForm1.clSMimeMessage1GetSigningCertificate(Sender: TObject;
var ACertificate: TclCertificate; AExtraCerts: TclCertificateList;
var Handled: Boolean);
begin
ACertificate := clCertificateStore1.Items[cbCertificate.ItemIndex];
Handled := True;
end;
Article ID: 151, Created: March 2, 2020 at 3:34 PM, Modified: March 4, 2020 at 5:06 PM