1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, wsbis, SOAPHTTPClient, SOAPHTTPTrans, WinInet, CAPICOM_TLB,
  JwaWinNT, JwaWinCrypt, SOAPAttachIntf, SOAPAttach, WCrypt2;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Ausgabebox: TEdit;
    Label2: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure BeforePostEvent(const HTTPReqResp: THTTPReqResp; Data: Pointer);
  private
    { Private-Deklarationen }
    function SetCertificate(Data: Pointer): Boolean;
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

const
  DLLNAME = 'C:\WINDOWS\system32\capicom.dll';(*capicom_tlb ruft Zertifikate ab, die bereits installiert sind*)


procedure TForm1.Button1Click(Sender: TObject);
const
defWSDL = 'https://beispiel.de/wsbis?wsdl';
defURL  = 'https://beispiel.de/wsbis';
var
LogonReq:LogonRequest;
LogonRes:LogonResponse;
httprio: SOAPHTTPClient.THTTPRIO;
httpreqresp: THTTPReqResp;

begin
  LogonReq := LogonRequest.Create;
  LogonReq.appId := 'beispiel';
LogonReq.credential := 'beispiel';
  LogonReq.language := 'DE';
  LogonReq.principal := '100...';
  LogonReq.processId := '1';

  httpreqresp := THTTPReqResp.Create(nil);
  httprio := THTTPRIO.Create(nil);
  httprio.HTTPWebNode := httpreqresp;
  httprio.URL := defURL;

  httpreqresp.OnBeforePost:=BeforePostEvent;
  {SetCertificate(DefWndProc);
  {BeforePostEvent(httpreqresp,DefWndProc);}

  LogonRes := GetBazeDirectRemote(false,defWSDL,httprio).logon(LogonReq);
  Ausgabebox.Text := LogonRes.error.code + ' - ' + LogonRes.error.text;
end;

function TForm1.SetCertificate(Data: Pointer): Boolean;
const
  INTERNET_OPTION_CLIENT_CERT_CONTEXT = 84;
var
  Store         : IStore;
  Cert          : ICertificate2;
  CertContext   : ICertContext;
  PCertContext  : PCCERT_CONTEXT;
  i             : Integer;
  Found         : Boolean;
  errorCode: Integer;
  FThumbprint   : string;
begin
  Found := False;
  Result := False;
  Store := CoStore.Create;
  Store.Open(CAPICOM_CURRENT_USER_STORE,'My',CAPICOM_STORE_OPEN_MAXIMUM_ALLOWED);
  i := 1;
  while (i <= Store.Certificates.Count) and Not Found do
  begin
    Cert := IInterface(Store.Certificates.Item[i]) as ICertificate2;

    if FThumbprint =  Cert.Thumbprint then
    begin
      Found := True;
    end;
    CertContext := Cert as ICertContext;
    CertContext.Get_CertContext(Integer(PCertContext));
    inc(i);
  end;
  if Not Found then
  begin
  end;
  if Not InternetSetOption(Data, INTERNET_OPTION_CLIENT_CERT_CONTEXT, PCertContext,  SizeOf(CERT_CONTEXT)) then
begin                                                    errorcode:=GetLastError();
AusgabeBox.Text:=IntToStr(errorCode);
end
  else
    Result := true;
end;

procedure TForm1.BeforePostEvent(const HTTPReqResp: THTTPReqResp; Data: Pointer);
var
  connFlags : DWord;
  len       : DWord;
  FResponseTimeout: TDateTime;
begin
  if Not SetCertificate(Data) then
  //set timeout for request
  if Not InternetSetOption(Data, INTERNET_OPTION_RECEIVE_TIMEOUT, Pointer(@FResponseTimeOut),SizeOf(FResponseTimeout)) then

  //ignore server certificat with wrong date, wrong cn and unknown ca
  len := SizeOf(connFlags);
  InternetQueryOption(Data, INTERNET_OPTION_SECURITY_FLAGS, @connFlags, len);
  connFlags := connFlags OR
               INTERNET_FLAG_IGNORE_CERT_CN_INVALID or               INTERNET_FLAG_IGNORE_CERT_DATE_INVALID or            SECURITY_FLAG_IGNORE_UNKNOWN_CA;
  InternetSetOption(Data, INTERNET_OPTION_SECURITY_FLAGS, @connFlags, len);
end;
end.