elmimeviewer_optionssmime.pas

来自「著名的SecureBlackBox控件完整源码」· PAS 代码 · 共 496 行

// File Version: 2004-04-16
unit ElMimeViewer_OptionsSMime;

interface

uses
  // System units:
  SysUtils,
  Classes,
  // SB Unicode Library
  SBChSConv,
  // El Mime units:
  SBMIMETypes,
  SBMIMEUtils,
  SBMIMEClasses,
  SBMIMEStream,
  // SBB Units:
  SBMIME,
  SBX509,
  SBConstants,
  SBPKCS12,
  // SMime units:
  SBSMIMECore,
  SBCustomCertStorage,
  SBWinCertStorage,
  // ElMime Demo units:
  ElMimeViewer_DataCommon,
  ElMimeViewer_CertDetails,
  ElMimeViewer_SMime,
  // other units:
  Windows,
  Messages,
{$IFDEF D_6_UP}Variants,
{$ENDIF}Graphics,
  Controls,
  Forms,
  Dialogs,
  StdCtrls,
  ExtCtrls,
  ComCtrls,
  Grids,
  Buttons;

type

  TFrame = TElMimePlugFrameOptions;

  TfraOptionsSMime = class(TFrame)
    OD: TOpenDialog;
    SD: TSaveDialog;
    ODC: TOpenDialog;
    SDC: TSaveDialog;
    pCSTop: TPanel;
    cbCustCert: TCheckBox;
    cbWinCert: TCheckBox;
    Panel1: TPanel;
    StringGridCertStorage: TStringGrid;
    pCSR: TPanel;
    Bevel1: TBevel;
    btnAddCert: TBitBtn;
    btnDeleteCert: TBitBtn;
    btnViewCert: TBitBtn;
    btnLoadStorage: TBitBtn;
    btnSaveStorage: TBitBtn;
    btnSaveCert: TBitBtn;
    procedure btnAddCertClick(Sender: TObject);
    procedure btnSaveStorageClick(Sender: TObject);
    procedure btnDeleteCertClick(Sender: TObject);
    procedure btnLoadStorageClick(Sender: TObject);
    procedure btnViewCertClick(Sender: TObject);
    procedure btnSaveCertClick(Sender: TObject);
    procedure cbCustCertClick(Sender: TObject);
    procedure cbWinCertClick(Sender: TObject);
  protected
    { Protected declarations }
    fNode: TTreeNodeInfoOptions;
    procedure LoadStorage(const sFileName: string);
    procedure SaveStorage(const sFileName: string);
  public
    { Public declarations }
    constructor Create(AOwner: TComponent; RootNode: TTreeNode; Nodes:
      TTreeNodesA); override;
    destructor Destroy; override;
    function GetCaption: string; override;
  protected
    procedure Init(mp: TElMessagePart; TagInfo: TTagInfo; Node: TTreeNodeInfo;
      bShow: Boolean); override;
  end;

var UserCertStorage: TElFileCertStorage;
    CurCertStorage : TElMemoryCertStorage;
    UseWinCertStorage: boolean;
    UseUserCertStorage: boolean;

procedure SMIMECollectCertificates;

implementation

uses ElMimeViewer_MainForm;

{$R *.dfm}

procedure CheckSBB(iErrorCode: Integer; const sErrorMessage: string);
begin
  if iErrorCode <> 0 then
    raise Exception.Create(sErrorMessage + '. Error code: "' +
      IntToStr(iErrorCode) + '".');
end;

procedure SMIMECollectCertificates;
var WinStorage : TElWinCertStorage;
begin
  CurCertStorage.Clear;
  if UseWinCertStorage then
  begin
    WinStorage := TElWinCertStorage.Create(nil);
    try
      WinStorage.SystemStores.Text := 'My';
      WinStorage.ExportTo(CurCertStorage);
    finally
      WinStorage.Free;
    end;
  end;
  if UseUserCertStorage then
  begin
    UserCertStorage.ExportTo(CurCertStorage);
  end;
end;

{ TfraOptionsParser }

constructor TfraOptionsSMime.Create(AOwner: TComponent; RootNode: TTreeNode;
  Nodes: TTreeNodesA);
begin
  inherited;

  fNode := TTreeNodeInfoOptions.Create(Nodes, tiOptions);
  fNode.ImageIndex := 56;
  fNode.SelectedIndex := 56;
  fNode.PlugFrame := Self;
  Nodes.AddNode(fNode, RootNode, 'SMIME', nil, naAddChild);

  UserCertStorage := TElFileCertStorage.Create(nil);
  CurCertStorage := TElMemoryCertStorage.Create(nil);

  StringGridCertStorage.Cells[0, 0] := 'User Certificates Storage :';

  // sync settings:
{$IFDEF _DEBUG_}
  cbWinCert.Checked := False;
{$ENDIF}
  cbWinCert.OnClick(nil);
  cbCustCert.OnClick(nil);

  fraSMIMEViewCert := TfraSMIMEViewCert.Create(Self);

  // Load default user storage
  LoadStorage('CerStorageDef.ucs');

end;

destructor TfraOptionsSMime.Destroy;
begin
  if fNode <> nil then
  begin
    fNode.PlugFrame := nil;
  end;

  CurCertStorage.Free;
  UserCertStorage.Free;
  inherited;
end;

procedure TfraOptionsSMime.Init(mp: TElMessagePart; TagInfo: TTagInfo; Node:
  TTreeNodeInfo; bShow: Boolean);
begin
  inherited;
end;

function TfraOptionsSMime.GetCaption: string;
begin
  Result := 'SMIME Options';
end;

const
  sDefCertPswdInCustStorage: AnsiString =
  '{37907B5C-B309-4AE4-AFD2-2EAE948EADA2}';

procedure TfraOptionsSMime.LoadStorage(const sFileName: string);
var
  sm: TAnsiStringStream;
  i: integer;
  ws: WideString;
  cer: TElX509Certificate;
begin

  UserCertStorage.Free;
  UserCertStorage := TElFileCertStorage.Create(nil);
  StringGridCertStorage.RowCount := 2;
  StringGridCertStorage.Cells[0, 1] := '';
  StringGridCertStorage.Objects[0, 1] := nil;

  if not FileExists(sFileName) then
    exit;

  sm := TAnsiStringStream.Create;
  sm.LoadFromFile(sFileName);
  try
    sm.Position := 0;
    CheckSBB(
      UserCertStorage.LoadFromBufferPFX(sm.Memory{$IFNDEF DELPHI_NET},
      sm.Size{$ENDIF}, sDefCertPswdInCustStorage),
      'Cannot load certificates from file storage: "' + sFileName + '"'
      );
    // UserCertStorage.ExportTo(fIntCertStorage);
    for i := 0 to UserCertStorage.Count - 1 do
    begin

      cer := UserCertStorage.Certificates[i];
       //if not cer.PrivateKeyExists then
       //  continue;

      ws :=
        fraSMIMEViewCert.GetCertificateIssuedToCN(cer) + ' / ' +
        fraSMIMEViewCert.GetCertificateIssuedToE(cer)
        ;
      StringGridCertStorage.RowCount := StringGridCertStorage.RowCount + 1;

      StringGridCertStorage.Cells[0, StringGridCertStorage.RowCount - 2] := ws;
      StringGridCertStorage.Objects[0, StringGridCertStorage.RowCount - 2] :=
        cer;

    end;
    if StringGridCertStorage.RowCount > 2 then
      StringGridCertStorage.RowCount := StringGridCertStorage.RowCount - 1;
  finally
    sm.Free;
  end;
end;

procedure TfraOptionsSMime.SaveStorage(const sFileName: string);
var
  iError, iSize: Integer;
  sm: TAnsiStringStream;
{$IFDEF DELPHI_NET}
  buffer: TBytes;
{$ENDIF}
begin

  sm := TAnsiStringStream.Create;
  try

    iSize := 0;
{$IFDEF DELPHI_NET}
    buffer := TBytes(TObject(null));
{$ENDIF}
    iError :=
      UserCertStorage.SaveToBufferPFX({$IFDEF DELPHI_NET}buffer{$ELSE}nil{$ENDIF}, iSize, sDefCertPswdInCustStorage,
      SB_ALGORITHM_PBE_SHA1_3DES, SB_ALGORITHM_PBE_SHA1_3DES);

    if (iError <> SB_PKCS12_ERROR_BUFFER_TOO_SMALL) or (iSize <= 0) then
      CheckSBB(iError, 'SaveToBufferPFX failed to save the storage');

    sm.Size := iSize;
{$IFDEF DELPHI_NET}
    buffer := sm.Memory;
{$ENDIF}
    CheckSBB(
      UserCertStorage.SaveToBufferPFX({$IFDEF DELPHI_NET}buffer{$ELSE}sm.Memory{$ENDIF}, iSize, sDefCertPswdInCustStorage,
      SB_ALGORITHM_PBE_SHA1_3DES, SB_ALGORITHM_PBE_SHA1_3DES),
      'SaveToBufferPFX failed to save the storage');
{$IFDEF DELPHI_NET}
    sm.Memory := buffer;
{$ENDIF}
    sm.SaveToFile(sFileName);
  finally
    sm.Free;
  end;
end;

procedure TfraOptionsSMime.btnAddCertClick(Sender: TObject);
var
  ws: WideString;
  sPswd: AnsiString;
  cer: TElX509Certificate;
  idx: Integer;
begin
  if ODC.Execute then
  begin

    ws := InputBox('Certificate Password',
      'Please enter password if it is needed', #0);
    if ws <> #0 then
      sPswd := ws
    else
      sPswd := '';

    cer := LoadCertificateFromFile(
             // FileName
      ODC.FileName,
            // pswd
      sPswd
      );

    if cer = nil then
      ShowMessage('Error loading the certificate')
    else
    begin
      idx := UserCertStorage.IndexOf(cer);
      if (idx >= 0) and (cer.PrivateKeyExists) and (not
        UserCertStorage.Certificates[idx].PrivateKeyExists) then
      begin
        UserCertStorage.Remove(idx);
        idx := -1;
      end;
      if idx < 0 then
      begin
        UserCertStorage.Add(cer);

        ws :=
          fraSMIMEViewCert.GetCertificateIssuedToCN(cer) + ' / ' +
          fraSMIMEViewCert.GetCertificateIssuedToE(cer);

        if StringGridCertStorage.Objects[0, 1] <> nil then
          StringGridCertStorage.RowCount := StringGridCertStorage.RowCount + 1;

        StringGridCertStorage.Cells[0, StringGridCertStorage.RowCount - 1] :=
          ws;
        StringGridCertStorage.Objects[0, StringGridCertStorage.RowCount - 1] :=
          UserCertStorage.Certificates[UserCertStorage.Count - 1];
      end
      else
        ShowMessage('Certificate is already in the list.');
    end;

  end;
end;

procedure TfraOptionsSMime.btnSaveStorageClick(Sender: TObject);
begin
  if SD.Execute then
    SaveStorage(SD.FileName);
end;

procedure TfraOptionsSMime.btnDeleteCertClick(Sender: TObject);
var
  cer: TElX509Certificate;
  idx: Integer;
begin

  if (StringGridCertStorage.Row < 0) or
    (StringGridCertStorage.Objects[0, StringGridCertStorage.Row] = nil) then
    exit;

  cer := TElX509Certificate(StringGridCertStorage.Objects[0,
    StringGridCertStorage.Row]);

  for idx := StringGridCertStorage.Row + 1 to StringGridCertStorage.RowCount - 1
    do
  begin
    StringGridCertStorage.Cells[0, idx - 1] := StringGridCertStorage.Cells[0,
      idx];
    StringGridCertStorage.Objects[0, idx - 1] :=
      StringGridCertStorage.Objects[0, idx];
  end;
  if StringGridCertStorage.RowCount > 2 then
    StringGridCertStorage.RowCount := StringGridCertStorage.RowCount - 1
  else
  begin
    StringGridCertStorage.Cells[0, 1] := '';
    StringGridCertStorage.Objects[0, 1] := nil;
  end;

  idx := UserCertStorage.IndexOf(cer);
  if idx >= 0 then
    UserCertStorage.Remove(idx);
end;

procedure TfraOptionsSMime.btnLoadStorageClick(Sender: TObject);
begin
  if OD.Execute then
    LoadStorage(OD.FileName);
end;

procedure TfraOptionsSMime.btnViewCertClick(Sender: TObject);
var
  f: TForm;
  bOK: TBitBtn;
  cer: TElX509Certificate;
  D: Integer;
begin
  if (StringGridCertStorage.Row < 0) or
    (StringGridCertStorage.Objects[0, StringGridCertStorage.Row] = nil) then
    exit;

  cer := TElX509Certificate(StringGridCertStorage.Objects[0,
    StringGridCertStorage.Row]);

  fraSMIMEViewCert.SetCertificate(cer);

  f := TForm.Create(Application);
  try
    fraSMIMEViewCert.Parent := f;
    fraSMIMEViewCert.Visible := True;
    fraSMIMEViewCert.Top := 1;
    fraSMIMEViewCert.Left := 1;

    f.Width := 2 * (fraSMIMEViewCert.Left + f.BorderWidth) +
      fraSMIMEViewCert.Width + 2;

    D := f.Height - f.ClientHeight;
    f.Height := D + 2 * fraSMIMEViewCert.Top + f.BorderWidth +
      fraSMIMEViewCert.Height + btnViewCert.Height;

    f.BorderIcons := [biSystemMenu];
    f.BorderStyle := bsDialog;
    f.Position := poScreenCenter;

    bOK := TBitBtn.Create(f);
    bOK.Caption := '&Close';
    bOK.Width := 80;
    bOK.Parent := f;
    bOK.Top := fraSMIMEViewCert.Top + fraSMIMEViewCert.Height + 10;
    bOK.Left := fraSMIMEViewCert.Left + fraSMIMEViewCert.Width - 15 - bOK.Width;
    bOK.Visible := True;
    bOK.ModalResult := mrOK;
    bOK.Default := True;

    f.ShowModal;

  finally
    fraSMIMEViewCert.Parent := nil;
    f.Free;
  end;
end;

procedure TfraOptionsSMime.btnSaveCertClick(Sender: TObject);
var
  sm: TAnsiStringStream;
  cer: TElX509Certificate;
  ws: WideString;
  sPswd: AnsiString;
begin
  if (StringGridCertStorage.Row >= 0)
    and (StringGridCertStorage.Objects[0, StringGridCertStorage.Row] <> nil)
    and SDC.Execute then
  begin
    sm := TAnsiStringStream.Create;
    try
      cer := TElX509Certificate(StringGridCertStorage.Objects[0,
        StringGridCertStorage.Row]);
      if cer.PrivateKeyExists then
      begin
        ws := InputBox('Certificate Password',
          'Please Enter Password if it needed', #0);
        if ws = #0 then
          sPswd := #0
        else
          sPswd := ws
      end;
      if sPswd <> #0 then
      begin
        cer.SaveToStreamPFX(sm,
          sPswd,
          SB_ALGORITHM_PBE_SHA1_RC4_128, SB_ALGORITHM_PBE_SHA1_RC4_128);
        sm.SaveToFile(SDC.FileName);
      end
      else
      begin
        cer.SaveToStream(sm);
        sm.SaveToFile(SDC.FileName);
        if cer.PrivateKeyExists then
          ShowMessage('Saved without private key');
      end;
    finally
      sm.Free;
    end;
  end;
end;

procedure TfraOptionsSMime.cbCustCertClick(Sender: TObject);
begin
  UseUserCertStorage := cbCustCert.Checked;
end;

procedure TfraOptionsSMime.cbWinCertClick(Sender: TObject);
begin
  UseWinCertStorage := cbWinCert.Checked;
end;

initialization
  TfraOptionsSMime.RegisterClass(TfraOptionsSMime);
  
end.