Hi everyone and sorry for my poor english.
I have a problem to query a webservice that requires a certificate in Basic Authentication. This is the code that I created
procedure Tmenu.btnConverterClick (Sender: TObject);
var
_ccSoap: VisualizzaErogatoRicevuta;
_rio: THTTPRIO;
ParametridaPassare: VisualizzaErogatoRichiesta;
myservice: visualizzaErogatoPT;
begin
_rio: = THTTPRIO.Create (Self);
_rio.OnBeforeExecute: = Self.httpRioBeforeExecute;
_rio.OnAfterExecute: = Self.httpRioAfterExecute;
_rio.HTTPWebNode.OnBeforePost: = Self.HTTPRIOHTTPWebNode1BeforePost;
_rio.URL:='https://demservicetest.sanita.finanze.it/DemRicettaErogatoServicesWeb/services/demVisualizzaErogato';
ParametridaPassare: = VisualizzaErogatoRichiesta.Create;
_ccSoap: = VisualizzaErogatoRicevuta.Create;
ParametridaPassare.pinCode: = 'xxxx';
ParametridaPassare.codiceRegioneErogatore: = '222';
ParametridaPassare.codiceAslErogatore: = '299';
ParametridaPassare.codiceSsaErogatore: = '33333338';
ParametridaPassare.nre: = '190345435345';
ParametridaPassare.tipoOperazione: = '1';
myservice: = _ rio as visualizzaErogatoPT;
_ccSoap: = myservice.visualizzaErogato (ParametridaPassare);
try
ShowMessage (_ccsoap.cognNome);
ShowMessage (_ccsoap.codiceAss);
ShowMessage (_ccsoap.cfMedico1);
ShowMessage (_ccsoap.cfMedico2);
ShowMessage (_ccsoap.descrizioneDiagnosi);
ShowMessage (_ccsoap.nre);
finally
_ccSoap: = nil;
end;
end;
procedure TMenu.HTTPRIOHTTPWebNode1BeforePost (const HTTPReqResp: THTTPReqResp; Data: Pointer);
Const
INTERNET_OPTION_CLIENT_CERT_CONTEXT = 84;
var
Store : IStore;
Certs : ICertificates;
Cert : ICertificate2;
CertContext : ICertContext;
PCertContext : PCCERT_CONTEXT;
V : OleVariant;
SS,S : String;
CertificateFilename: PWideChar;
Certificate: ICertificate2;
Password: String;
i : integer;
UserName: string;
begin
V := '6C791E67ACD205940DB36444BDB5C81FD89A2214';
Store := CoStore.Create;
(* open the My Store containing certs with private keys *)
Store.Open( CAPICOM_CURRENT_USER_STORE, 'MY', CAPICOM_STORE_OPEN_MAXIMUM_ALLOWED );
Certs := Store.Certificates;
for i := 1 to certs.Count do
begin
cert := IInterface(Certs.Item[i]) as ICertificate2;
ss:=cert.SubjectName;
if cert.Thumbprint=V then
begin
CertContext := Cert as ICertContext;
CertContext.Get_CertContext( Integer( PCertContext ) );
HTTPReqResp.ClientCertificate.CertName:=cert.SubjectName;
HTTPReqResp.ClientCertificate.Issuer:=cert.IssuerName;
HTTPReqResp.ClientCertificate.SerialNum:=cert.SerialNumber;
if InternetSetOption( Data, INTERNET_OPTION_CLIENT_CERT_CONTEXT, PCertContext, Sizeof( CERT_CONTEXT ) ) = False then
begin
ShowMessage( 'Problema no certificado!!!!!!!!!!' );
end;
end
end;
procedure TMenu.httpRioAfterExecute(const MethodName: string;
SOAPResponse: TStream);
begin
SOAPResponse.Position := 0;
mmResponse.Lines.LoadFromStream(SOAPResponse);
SOAPResponse.Position := 0;
end;
procedure TMenu.httpRioBeforeExecute(const MethodName: string;
SOAPRequest: TStream);
begin
SOAPRequest.Position := 0;
mmRequest.Lines.LoadFromStream(SOAPRequest);
SOAPRequest.Position := 0;
end;
It seems that the certificate is loaded correctly. What are the instructions and where do I put them to query the webservice in basic authentication through username and password in BASE64?
Thank you all for the help.
Please, about this code:
type
TClient = class(TObject)
public
Host: String;
Queue: TIdThreadSafeStringList;
end;
var
Clients: TThreadList;
procedure TMain.FormCreate(Sender: TObject);
const
Hosts: Array[0..4] of String = (
'HOST1', 'HOST2', 'HOST3', 'HOST4, 'HOST5'
);
var
I: Integer;
List: TList;
Client: TClient;
begin
Clients := TThreadList.Create;
Clients.Duplicates := dupAccept;
for I := Low(Hosts) to High(Hosts) do
begin
Client := TClient.Create;
Client.Host := Hosts[I];
Client.Queue := TIdThreadSafeStringList.Create;
Clients.Add(Client);
Client := nil;
end;
end;
I would like to know if the correct way of releasing it memory is:
procedure TMain.FormDestroy(Sender: TObject);
var
I: Integer;
List: TList;
begin
List := Clients.LockList;
try
for I := 0 to List.Count - 1 do
TClient(List[I]).Free;
finally
Clients.UnlockList;
Clients.Free;
end;
end;
Or maybe like this:
procedure TMain.FormDestroy(Sender: TObject);
var
I: Integer;
List: TList;
begin
List := Clients.LockList;
try
for I := 0 to List.Count - 1 do
begin
TClient(List[I]).Queue.Free;
TClient(List[I]).Free;
end;
finally
Clients.UnlockList;
Clients.Free;
end;
end;
In other words, I would like to know if when I release an object (TClient) all elements (Queue) are released automatically, or must I do it manually.
Thanks!
The queue object needs to be destroyed when the client object is destroyed. However, the correct way to do this is to make the client class take charge of its members.
type
TClient = class
private
FHost: String;
FQueue: TIdThreadSafeStringList;
public
constructor Create(const Host: string);
destructor Destroy; override;
end;
....
constructor TClient.Create(const Host: string);
begin
inherited Create;
FQueue := TIdThreadSafeStringList.Create;
FHost := Host;
end;
destructor TClient.Destroy;
begin
FQueue.Free;
inherited;
end;
If you do it this way then it's not possible to instantiate the class and fail to instantiate its members. Do it your way, and every time you need to instantiate the class then you have to repeat the code to instantiate the members. It's just all too easy to make a mistake that way. What's more it makes the code harder to read and maintain.
I search to connect to a Web service but when I call the method I obtain this error "Element "OutputObj" does not contain a single text node'.
This is the Unit I create importing my WSDL file:
// ************************************************************************ //
// The types declared in this file were generated from data read from the
// WSDL File described below:
// WSDL : D:\SVN\XML IE815\WSDL\DispatcherBean.wsdl
// >Import : D:\SVN\XML IE815\WSDL\DispatcherBean.wsdl>0
// >Import : D:\SVN\XML IE815\WSDL\DispatcherBean.wsdl>1
// Encoding : UTF-8
// Version : 1.0
// (16/07/2014 9.33.06 - - $Rev: 25127 $)
// ************************************************************************ //
unit UNDispatcherBean;
interface
uses InvokeRegistry, SOAPHTTPClient, SOAPHTTPTrans, Types, XSBuiltIns;
const
IS_OPTN = $0001;
IS_UNBD = $0002;
IS_NLBL = $0004;
IS_UNQL = $0008;
IS_REF = $0080;
type
// ************************************************************************ //
// The following types, referred to in the WSDL document are not being represented
// in this file. They are either aliases[#] of other types represented or were referred
// to but never[!] declared in the document. The types from the latter category
// typically map to predefined/known XML or Embarcadero types; however, they could also
// indicate incorrect WSDL documents that failed to declare or import a schema type.
// ************************************************************************ //
// !:anyType - "http://www.w3.org/2001/XMLSchema"[Gbl]
// !:string - "http://www.w3.org/2001/XMLSchema"[Gbl]
// !:base64Binary - "http://www.w3.org/2001/XMLSchema"[Gbl]
MessageDTO = class; { "http://dto.domest.it.sogei"[GblCplx] }
XmlDTO = class; { "http://dto.domest.it.sogei"[GblCplx] }
ArrayOfXmlDTO = array of XmlDTO; { "http://dto.domest.it.sogei"[GblCplx] }
// ************************************************************************ //
// XML : MessageDTO, global, <complexType>
// Namespace : http://dto.domest.it.sogei
// ************************************************************************ //
MessageDTO = class(TRemotable)
private
FinputObj: Variant;
FoutputObj: Variant;
FserviceID: string;
FxmlList: ArrayOfXmlDTO;
public
destructor Destroy; override;
published
property inputObj: Variant Index (IS_NLBL or IS_UNQL) read FinputObj write FinputObj;
property outputObj: Variant Index (IS_NLBL or IS_UNQL) read FoutputObj write FoutputObj;
property serviceID: string Index (IS_NLBL or IS_UNQL) read FserviceID write FserviceID;
property xmlList: ArrayOfXmlDTO Index (IS_NLBL or IS_UNQL) read FxmlList write FxmlList;
end;
// ************************************************************************ //
// XML : XmlDTO, global, <complexType>
// Namespace : http://dto.domest.it.sogei
// ************************************************************************ //
XmlDTO = class(TRemotable)
private
Fxml: TByteDynArray;
published
property xml: TByteDynArray Index (IS_UNQL) read Fxml write Fxml;
end;
// ************************************************************************ //
// Namespace : http://dispatcher.domest.it.sogei
// soapAction: dispatcher
// transport : http://schemas.xmlsoap.org/soap/http
// style : document
// binding : DispatcherBeanSoapBinding
// service : DispatcherBeanService
// port : DispatcherBean
// URL : https://ws.agenziadogane.it/DomestRouter/services/DispatcherBean
// ************************************************************************ //
DispatcherBean = interface(IInvokable)
['{2D4F3F8E-969E-CF9A-EBAA-1C558EEF5A88}']
function dispatcher(const messaggio: MessageDTO): MessageDTO; stdcall;
end;
function GetDispatcherBean(UseWSDL: Boolean=System.False; Addr: string=''; HTTPRIO: THTTPRIO=nil; PmTlmAmbiente: Integer=0): DispatcherBean;
implementation
uses SysUtils;
function GetDispatcherBean(UseWSDL: Boolean; Addr: string; HTTPRIO: THTTPRIO; PmTlmAmbiente: Integer): DispatcherBean;
{PmTlmAmbiente
0 = Ambiente di addestramento
1 = Ambiente reale}
const
defWSDL_test = 'https://wstest.agenziadogane.it/DomestRouter/services/DispatcherBean/?wsdl';
defWSDL_real = 'https://ws.agenziadogane.it/DomestRouter/services/DispatcherBean/?wsdl';
defSvc = 'DispatcherBeanService';
defPrt = 'DispatcherBean';
defURL_real = 'https://ws.agenziadogane.it/DomestRouter/services/DispatcherBean';
defURL_test = 'https://wstest.agenziadogane.it/DomestRouter/services/DispatcherBean';
var
RIO: THTTPRIO;
begin
Result := nil;
if (Addr = '') then
begin
if UseWSDL then
begin
// ambiente addestramento
if PmTlmAmbiente = 0 then
Addr := defWSDL_test;
// ambiente reale
if PmTlmAmbiente = 0 then
Addr := defWSDL_real;
end
else
begin
// ambiente addestramento
if PmTlmAmbiente = 0 then
Addr := defURL_test;
// ambiente reale
if PmTlmAmbiente = 1 then
Addr := defURL_real;
end;
end;
if HTTPRIO = nil then
RIO := THTTPRIO.Create(nil)
else
RIO := HTTPRIO;
try
Result := (RIO as DispatcherBean);
if UseWSDL then
begin
RIO.WSDLLocation := Addr;
RIO.Service := defSvc;
RIO.Port := defPrt;
end else
RIO.URL := Addr;
finally
if (Result = nil) and (HTTPRIO = nil) then
RIO.Free;
end;
end;
destructor MessageDTO.Destroy;
var
I: Integer;
begin
for I := 0 to System.Length(FxmlList)-1 do
SysUtils.FreeAndNil(FxmlList[I]);
System.SetLength(FxmlList, 0);
inherited Destroy;
end;
initialization
InvRegistry.RegisterInterface(TypeInfo(DispatcherBean), 'http://dispatcher.domest.it.sogei', 'UTF-8');
InvRegistry.RegisterDefaultSOAPAction(TypeInfo(DispatcherBean), 'dispatcher');
InvRegistry.RegisterInvokeOptions(TypeInfo(DispatcherBean), ioDocument);
RemClassRegistry.RegisterXSInfo(TypeInfo(ArrayOfXmlDTO), 'http://dto.domest.it.sogei', 'ArrayOfXmlDTO');
RemClassRegistry.RegisterXSClass(MessageDTO, 'http://dto.domest.it.sogei', 'MessageDTO');
RemClassRegistry.RegisterXSClass(XmlDTO, 'http://dto.domest.it.sogei', 'XmlDTO');
end.
This is the code to call the Web Service method:
Procedure PrcSendSOAPRequest(const ServiceID:string; InputObj: Variant; PmPathXML: string);
{ServiceId
D1 : richiesta di Invio Draft IE815
D2 : richiesta Esito Invio Draft IE815 (IE801)
D3 : richiesta di Annullamento (IE810)
D4 : richiesta di Cambio Destinazione (IE813)
D5 : rischiesta di invio Appuramento (IE818)
D6 : richiesta di Rigetto (IE819)
InputObj
se ServiceID D2 : Protocollo di cui si vuole conoscere l'esito
}
var
FMEXPTXTEAD: TFMEXPTXTEAD;
SOAP_RequestMsg : MessageDTO;
SOAP_ResponseMsg : MessageDTO;
XMLDto_Element : XmlDTO;
XMLDtoArray : ArrayOfXmlDTO;
begin
FMEXPTXTEAD := TFMEXPTXTEAD.Create(Application);
try
with FMEXPTXTEAD do
begin
// richiesta di Invio Draft IE815
if ServiceID = D1 then
begin
XMLDto_Element := XmlDTO.Create;
SOAP_RequestMsg := MessageDTO.Create;
SOAP_ResponseMsg := MessageDTO.Create;
try
XMLDto_Element.xml := StringToByteArray(PmPathXML);
SetLength(XMLDtoArray, 1);
XMLDtoArray[0] := XMLDto_Element;
// MESSAGGIO DI RICHIESTA
SOAP_RequestMsg.serviceID := ServiceID;
SOAP_RequestMsg.xmlList := XMLDtoArray;
// MESSAGGIO DI RISPOSTA
SOAP_ResponseMsg := GetDispatcherBean(False,'',HTTPRIO1,0).dispatcher(SOAP_RequestMsg);
// LETTURA DEL MESSAGGIO DI RISPOSTA
PrcReadSOAPResponse(D1,SOAP_ResponseMsg);
finally
begin
XMLDto_Element.Free;
SOAP_RequestMsg.Destroy;
SOAP_ResponseMsg.Destroy;
end;
end;
end;
end;
finally
FMEXPTXTEAD.Close;
end;
and this is the XML Response from the Web Service:
<soapenv:Envelope xmlns:soapenv="http://schemas.xmlsoap.org/soap/envelope/">
<soapenv:Body>
<ns2:dispatcherResponse xmlns:ns2="http://dispatcher.domest.it.sogei">
<dispatcherReturn>
<inputObj xsi:nil="true" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"/>
<outputObj xsi:type="ns4:XmlDTO" xmlns:ns4="http://dto.domest.it.sogei" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance">
<xml>Nzd1L1BEOTRiV3dnZG1WeWMybHZiajBpTVM0d0lpQmxibU52WkdsdVp6MGlkWFJtTFRnaVB6NEtQ</xml>
</outputObj>
<serviceID>D1</serviceID>
<xmlList>
<XmlDTO>
<xml>Nzd1L1BEOTRiV3dnZG1WeWMybHZiajBpTVM0d0lpQmxibU52WkdsdVp6MGlkWFJtTFRnaVB6NEtQ</xml>
</XmlDTO>
</xmlList>
</dispatcherReturn>
</ns2:dispatcherResponse>
</soapenv:Body>
</soapenv:Envelope>
When I call the GetDispatcherBean(False,'',HTTPRIO1,0).dispatcher(SOAP_RequestMsg) I obtain the error.
On the BeforeExecute of the RIO I just controll that the XML Request it's fine like a XML Request with SoapUI.
On the AfterExecute of the RIO I just controll that the XML Response it's fine like a XML Response with SoapUI.
The GetDispatcherBean(False,'',HTTPRIO1,0).dispatcher(SOAP_RequestMsg) Return an MessageDTO wich Class is define in the UNDispatcherBean Unit but I think Delphi don't parse correctly the XML Response to the Object MessageDTO.
Any idea about the Error ? Where I have to search the causes ?
It's my first project with Web Service and SOAP and I hope don't write estupid thigs.
I need help to transcribe a struct that has another nested struct to Delphi. Below is a struct:
#define CHANNEL_TAG_LENGTH 17
struct stChannelInfo
{
char ChannelTag[CHANNEL_TAG_LENGTH]; // Tag (máx 16 caracteres)
char ChannelEnabled; // Habilitado se diferente de "0"
};
// Structure with information about channels
struct stChannel
{
int ChannelNumber; // Número de canais no buffer
struct stChannelInfo *ChannelInfo; // Buffer com informações dos canais
};
In Borland C + + 6, the example uses the following code to read the value of ChannelTag:
stChannels = this->deviceInterface->LookForAvailableChannels(EdDirectorySource->Text.c_str(), iSn, dateTimeStart, dateTimeEnd);
for(int i = 0; i < stChannels.ChannelNumber; i++)
{
CLbChannels->Items->Add(stChannels.ChannelInfo[i].ChannelTag); // Add to list the values found
}
I wish I could do the same in Delphi. How should I transcribe structs?
Thanks and sorry because English is not my native language
EDIT
I was wrong not to post what I had done on Delphi. Follow my attempt:
// record who receive the values
type stChannelInfo = record
ChannelTag : string[16];
ChannelEnabled : char ;
end;
type stChannel = record
ChannelNumber:integer; // Númber of buffer channels
ChannelInfo : ^stChannelInfo ;
end;
And so i tried to read :
Var DadosCanais : stChannel; // defined in var section of procedure onclick Button.
DadosCanais:=LookForAvailableChannels (Pwidechar(dirroot) , sn , datepickerinicial.DateTime,datepickerfinal.DateTime);
for i := 0 to (DadosCanais.ChannelNumber-1) do
begin
Showmessage(String(DadosCanais.ChannelInfo^.ChannelTag));
inc(DadosCanais.ChannelInfo);
end;
I get the record, but I can not correctly read ChannelTag values. It seems that the size is incorrect, because the strings is truncated and always lose the first character of the name.
Maybe this clarify a little the question. Thanks again
SOLUTION
Following advice from Remy , i do this :
sn:=strtoint(lstdirMaquinas.Items[lstdirMaquinas.Itemindex]);
Dadoscanais := LookForAvailableChannels(PChar(dirroot) , sn , datepickerinicial.DateTime,datepickerfinal.DateTime);
for i:=0 to DadosCanais.ChannelNumber-1 do
begin
ListboxChannel.Items.add(String(DadosCanais.ChannelInfo[i].ChannelTag));
end;
For now this resolves my problem. Thanks all.
{$POINTERMATH ON}
Type
PstChannelInfo = ^stChannelInfo;
stChannelInfo = record
ChannelTag: array[0..CHANNEL_TAG_LENGTH-1] of AnsiChar; // Tag (máx 16 caracteres)
ChannelEnabled: AnsiChar; // Habilitado se diferente de "0"
end;
// Structure with information about channels
stChannel = record
ChannelNumber: Integer; // Número de canais no buffer
ChannelInfo: PstChannelInfo; // Buffer com informações dos canais
end;
stChannels := Self.deviceInterface.LookForAvailableChannels(PChar(EdDirectorySource.Text), iSn, dateTimeStart, dateTimeEnd);
for i := 0 to stChannels.ChannelNumber-1 do begin
CLbChannels.Items.Add(stChannels.ChannelInfo[i].ChannelTag); // Add to list the values found
end;
Alternatively:
Type
PstChannelInfo = ^stChannelInfo;
stChannelInfo = record
ChannelTag: array[0..CHANNEL_TAG_LENGTH-1] of AnsiChar; // Tag (máx 16 caracteres)
ChannelEnabled: AnsiChar; // Habilitado se diferente de "0"
end;
// Structure with information about channels
stChannel = record
ChannelNumber: Integer; // Número de canais no buffer
ChannelInfo: PstChannelInfo; // Buffer com informações dos canais
end;
PstChannelInfoList = ^TstChannelInfoList;
TstChannelInfoList = [0..(MaxInt div SizeOf(stChannelInfo))-1] of stChannelInfo;
stChannels := Self.deviceInterface.LookForAvailableChannels(PChar(EdDirectorySource.Text), iSn, dateTimeStart, dateTimeEnd);
for i := 0 to stChannels.ChannelNumber-1 do begin
CLbChannels.Items.Add(PstChannelInfoList(stChannels.ChannelInfo)^[i].ChannelTag); // Add to list the values found
end;
I've written a TOpenPictDialog (source code see below) component, which finally fails under certain circumstands when calling
Result := TDialogFunc(DialogFunc)(DialogData);
in Dialogs.pas. As DialogFunc correctly points to GetOpenFileName I call CommDlgExtendedError afterwards for test to find out what's wrong. It returns CDERR_FINDRESFAILURE. In this case the dialog is simply not showing. My test form only contains a button and the TOpenPictDialog component, when pressing the button, OpenPictDialog1->Execute is called - that's all.
The very strange thing is that it does work perfectly (besides of the TListView flickering on resize) under one of the following circumstands:
a) add ExtDlgs in "uses" in calling form
b) add an original TOpenPictureDialog to the form without calling it
c) adding the PAS file containing TOpenPictDialog to the project (although TOpenPictDialog has been already installed)
If I write a C++ Builder application with the one calling form I never get TOpenPictDialog working (even if I add the additional TOpenPictureDialog component).
unit PictureDlg;
{$R-,H+,X+}
{$IF CompilerVersion > 23} {$DEFINE GE_DXE2} {$IFEND}
interface
{$IFDEF GE_DXE2}
uses Winapi.Messages, Winapi.Windows, System.SysUtils, System.Classes, Vcl.Controls, Vcl.StdCtrls,
Vcl.Graphics, Vcl.ExtCtrls, Vcl.Buttons, Vcl.Dialogs, Vcl.ExtDlgs, Vcl.Consts, Vcl.ComCtrls;
{$ELSE}
uses Messages, Windows, SysUtils, Classes, Controls, StdCtrls,
Graphics, ExtCtrls, Buttons, Dialogs, ExtDlgs, Consts, ComCtrls;
{$ENDIF}
(*$HPPEMIT '// Alias records for C++ code that cannot compile in STRICT mode yet.' *)
(*$HPPEMIT '#if defined(_VCL_ALIAS_RECORDS)' *)
(*$HPPEMIT '#if !defined(STRICT)' *)
// (*$HPPEMIT ' #pragma alias "#Vcl#Extdlgs#TOpenPictDialog#Execute$qqrpv"="#Vcl#Extdlgs#TOpenPictDialog#Execute$qqrp6HWND__"' *)
(*$HPPEMIT '#endif' *)
(*$HPPEMIT '#endif' *)
type
{ TOpenPictDialog }
TOpenPictDialog = class(TOpenDialog)
private
FListView: TListView;
FTopLabel, FBottomLabel: TStaticText;
FImageCtrl: TImage;
FSavedFilename: string;
FOldDialogWndProc: Pointer;
FDialogMethodInstance: Pointer;
FDialogHandle: THandle;
function IsFilterStored: Boolean;
procedure DialogWndProc(var Msg: TMessage);
protected
procedure DoClose; override;
procedure DoSelectionChange; override;
procedure DoShow; override;
function TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool; override;
published
property Filter stored IsFilterStored;
public
constructor Create(AOwner: TComponent); override;
function Execute(ParentWnd: HWND): Boolean; override;
property DialogListView: TListView read FListView;
property DialogImage: TImage read FImageCtrl;
property TopLabel: TStaticText read FTopLabel;
property BottomLabel: TStaticText read FBottomLabel;
end;
procedure Register;
implementation
uses
{$IFDEF GE_DXE2}
{$IF DEFINED(CLR)}
System.Runtime.InteropServices, System.Reflection, System.Security.Permissions, System.IO,
{$IFEND}
System.Math, Vcl.Forms, Winapi.CommDlg, Winapi.Dlgs, System.Types, Winapi.ShlObj, Winapi.ActiveX;
{$ELSE}
{$IF DEFINED(CLR)}
InteropServices, Reflection, Permissions, IO,
{$IFEND}
Math, Forms, CommDlg, Dlgs, Types, ShlObj, ActiveX;
{$ENDIF}
{ TOpenPictDialog }
constructor TOpenPictDialog.Create(AOwner: TComponent);
begin
FDialogHandle := 0;
FDialogMethodInstance := NIL;
inherited Create(AOwner);
Filter := GraphicFilter(TGraphic);
FListView := TListView.Create(Self);
FImageCtrl := TImage.Create(Self);
with FListView do
begin
Name := 'ListView';
SetBounds(204, 5, 169, 200);
BevelOuter := bvNone;
BorderWidth := 6;
TabOrder := 1;
Color := clWindow;
ParentDoubleBuffered := false;
DoubleBuffered := true;
OwnerDraw := true;
Ctl3D := true;
with FImageCtrl do
begin
Picture := nil;
Name := 'Image';
Parent := FListView;
end;
end;
FTopLabel := TStaticText.Create(Self);
with FTopLabel do
begin
Name := 'TopLabel';
SetBounds(6, 6, 157, 23);
AutoSize := False;
Caption := 'Preview:';
end;
FBottomLabel := TStaticText.Create(Self);
with FBottomLabel do
begin
Name := 'BottomLabel';
SetBounds(6, 6, 157, 23);
AutoSize := False;
Caption := 'Image size: 208 x 149 px';
Alignment := taCenter;
end;
end;
procedure TOpenPictDialog.DialogWndProc(var Msg: TMessage);
var
PreviewRect, ListViewRect, WindowRect, LabelRect: TRect;
WndControl: HWND;
begin
Msg.Result := CallWindowProc(FOldDialogWndProc, FDialogHandle, Msg.Msg, Msg.WParam, Msg.LParam);
if ((Msg.Msg = WM_WINDOWPOSCHANGED) and
((TWMWindowPosMsg(Msg).WindowPos.Flags and SWP_NOSIZE) = 0)) or
(Msg.Msg = WM_SHOWWINDOW) then begin
PreviewRect := FListView.BoundsRect;
GetWindowRect(Handle, WindowRect);
WndControl := FindWindowEx(FDialogHandle, 0, 'SHELLDLL_DefView', nil);
WndControl := FindWindowEx(WndControl, 0, 'SysListView32', nil);
if WndControl <> 0 then begin
GetWindowRect(WndControl, ListViewRect);
PreviewRect.Top := ListViewRect.Top - WindowRect.Top;
PreviewRect.Bottom := PreviewRect.Top + ListViewRect.Bottom - ListViewRect.Top;
if (not EqualRect(PreviewRect, FListView.BoundsRect)) then
FListView.BoundsRect := PreviewRect;
LabelRect := PreviewRect;
Dec(LabelRect.Top, 24);
LabelRect.Bottom := LabelRect.Top + 16;
FTopLabel.BoundsRect := LabelRect;
LabelRect := PreviewRect;
LabelRect.Top := PreviewRect.Bottom + 9;
LabelRect.Bottom := LabelRect.Top + 16;
FBottomLabel.BoundsRect := LabelRect;
end;
end;
end;
procedure TOpenPictDialog.DoSelectionChange;
var
FullName: string;
function ValidFile(const FileName: string): Boolean;
begin
Result := FileGetAttr(FileName) <> -1;
end;
begin
FullName := FileName;
if FullName <> FSavedFilename then
begin
FSavedFilename := FullName;
end;
inherited DoSelectionChange;
end;
procedure TOpenPictDialog.DoClose;
begin
if Assigned(FDialogMethodInstance) then begin
SetWindowLong(FDialogHandle, GWL_WNDPROC, Integer(FOldDialogWndProc));
FreeObjectInstance(FDialogMethodInstance);
end;
FDialogHandle := 0;
FDialogMethodInstance := NIL;
inherited DoClose;
{ Hide any hint windows left behind }
Application.HideHint;
end;
procedure TOpenPictDialog.DoShow;
var
PreviewRect, StaticRect, OldDialogRect: TRect;
DialogWidth, DialogHeight, NewLeft, NewTop: integer;
const
SizeIncrease = 25;
begin
FDialogHandle := GetParent(Handle);
GetWindowRect(FDialogHandle, OldDialogRect);
DialogWidth := OldDialogRect.Right - OldDialogRect.Left + SizeIncrease;
DialogHeight := OldDialogRect.Bottom - OldDialogRect.Top;
NewLeft := (Screen.Width - DialogWidth) div 2;
NewTop := (Screen.Height - DialogHeight) div 2;
GetWindowRect(Handle, PreviewRect);
MoveWindow(FDialogHandle, NewLeft, NewTop, DialogWidth, DialogHeight, true);
MoveWindow(Handle, 0, 0, PreviewRect.Right - PreviewRect.Left + SizeIncrease, PreviewRect.Bottom - PreviewRect.Top, false);
StaticRect := GetStaticRect;
GetClientRect(Handle, PreviewRect);
PreviewRect.Left := StaticRect.Left + (StaticRect.Right - StaticRect.Left);
Inc(PreviewRect.Top, 4);
Dec(PreviewRect.Right, 8);
Dec(PreviewRect.Bottom, 20);
FListView.BoundsRect := PreviewRect;
FDialogMethodInstance := MakeObjectInstance(DialogWndProc);
FOldDialogWndProc := Pointer(SetWindowLong(FDialogHandle, GWL_WNDPROC, Integer(FDialogMethodInstance)));
FSavedFilename := '';
FListView.ParentWindow := Handle;
FTopLabel.ParentWindow := Handle;
FBottomLabel.ParentWindow := Handle;
inherited DoShow;
end;
[UIPermission(SecurityAction.LinkDemand, Window=UIPermissionWindow.SafeSubWindows)]
function TOpenPictDialog.Execute(ParentWnd: HWND): Boolean;
begin
if NewStyleControls and not (ofOldStyleDialog in Options) and not
((Win32MajorVersion >= 6) and UseLatestCommonDialogs) then
Template := 'DLGTEMPLATE'
else
{$IF DEFINED(CLR)}
Template := '';
{$ELSE}
Template := nil;
{$IFEND}
Result := inherited Execute(ParentWnd);
end;
function TOpenPictDialog.TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool;
begin
// This makes sense ONLY if you are compiling with a run-time packages
// Thanks to Peter Below (www.delphifaq.com)
TOpenfilename(Dialogdata).hInstance := FindClassHInstance(Classtype);
Result := inherited TaskModalDialog(DialogFunc, DialogData);
end;
function TOpenPictDialog.IsFilterStored: Boolean;
begin
Result := not (Filter = GraphicFilter(TGraphic));
end;
procedure Register;
begin
RegisterComponents('Dialogs', [TOpenPictDialog]);
end;
end.
When you copied the code from ExtDlgs.pas to begin writing yours, you didn't copy enough. In particular, you didn't copy the $R directive that links the associated ExtDlgs.rc file, which contains the dialog resource describing the additional layout of the custom dialog box.
Your code tells the API to use a dialog resource named DLGTEMPLATE, but you haven't included that resource in your program. That explains why the error code you get is about a failure to find a resource. Using the ExtDlgs unit has the side effect of linking that unit's associated resources.
Go copy the dialog template from ExtDlgs.rc into your own RC file and link it as ExtDlgs.pas does. Use a different name for the resource, though, to avoid a name clash with the existing DLGTEMPLATE resource. Adjust your code accordingly.