June 29, 2013

Delayed loading of a DLL

The delayed directive can be used when declaring a function exported from a DLL so that the DLL is not loaded before the function is called.

This is very useful because you may first check if the conditions are met to call the DLL before actually loading the DLL, for example check if the DLL is located where it should.

If you statically load a DLL (the default), then your application won’t start if the DLL is not present. You could as well dynamically load the DLL (LoadLibrary) to avoid this issue, but it is a little bit more work for you to declare function pointer and the get each function address (GetProcAddress) by code. Using delayed directive is much easier. Just add delayed keyword in each function declaration and suddenly a static DLL is loaded the first time one of his functions is called. If you never call a DLL’s function, then the DLL is not loaded at all.

A declaration looks like this:
?
1
function GetSomething: Integer; external 'somelibrary.dll' delayed;

This directive exists since Delphi 2010. There is valuable documentation on Embarcadero DocWiki at this URL: http://docwiki.embarcadero.com/RADStudio/XE4/en/Libraries_and_Packages#Delayed_Loading And you can find some code sample here: http://docwiki.embarcadero.com/CodeExamples/XE4/en/DelayedLoading_(Delphi)

Follow me on Twitter
Follow me on LinkedIn
Follow me on Google+
Visit my website: http://www.overbyte.be
Posted by at 6 comments:
Labels: , , , , , , ,

June 17, 2013

Drag And Drop from Windows Explorer

This article presents the required code to handle drag& drop of images from Windows Explorer to your Delphi application. The demo code shows how to drop images on a TListView and to drag & drop from TListView to a TImage.

The code is fairly basic and made so that it can be clearly understood and applied to other types of controls.

Drag & Drop from windows Explorer is handled by an application by registering a window handle along with an instance of an IDropTarget interface.

To make to code easy to reuse, I encapsulated the IDropTarget implementation into a class named TDropTarget and expose the features the Delphi way: using event.

To allow Drag & Drop from Windows Explorer to one of your form, you have to create an instance of TDropTarget and call his Register method passing the form’s handle. Of course you have to assign the events to handler in your form. The events handle all drag and drop operation:

DropAllowed event is called once when the dragged files are entering the area of the registered window. The event handler must set the “Allowed” var argument to TRUE if dropping the file(s) is allowed at the given point.

DragOver event is called as mouse move above the registered window. The event handler must set the “Allowed” var argument to TRUE if dropping the file(s) is allowed at the given point.

Drop event is called when the user drops the files.

DragLeave event is called when the dragged files leave the registered window area.

I could have made a component of TDropTarget but I didn’t. It is a simple object deriving from Object. As it implements an interface IDroptarget, beside the methods of this interface, the object also has to handle _AddRef, _Release and QueryInterface methods which exist in all interfaces. Here we use TObject life cycle, so those methods are simply do-nothing methods.

The code required in your form include creating the object in the form’s contructor (or FormCreate event), assign the event handlers. And of course free the object instance in the destructor:

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
constructor TDragDropMainForm.Create(AOwner: TComponent);
begin
    FDropTarget               := TDropTarget.Create;
    FDropTarget.OnDropAllowed := ImageDropAllowedHandler;
    FDropTarget.OnDrop        := ImageDropHandler;
    FDropTarget.OnDragOver    := ImageDragOverHandler;
    inherited Create(AOwner);
end;
 
destructor TDragDropMainForm.Destroy;
begin
    FreeandNil(FDropTarget);
    inherited;
end;

Register and Revoke should be called when the window handle is created or destroyed. For that, we have to override CreateWnd and DestroyWnd.
?
1
2
3
4
5
6
7
8
9
10
11
12
13
procedure TDragDropMainForm.CreateWnd;
begin
    inherited CreateWnd;
    if Assigned(FDropTarget) then
        FDropTarget.Register(Handle);
end;
 
procedure TDragDropMainForm.DestroyWnd;
begin
    inherited DestroyWnd;
    if Assigned(FDropTarget) then
        FDropTarget.Revoke;
end;

The demo application uses a TListView in vsList view mode and a TImage. The ListView accept the dropped images from Windows Explorer while TImage accepte images dropped from TListView. It is a good exercise for you to make TImage accept image also from Windows Explorer.

The demo application doesn’t show image in real size in TListView. Rather, it creates a thumbnail which is displayed in the list view. The thumbnails are stored on disk in the same folder as the original image and are only created if it doesn’t exist yet, or if the original image has been modified. Storing the thumbnail on disk could be a problem in some application because it requires write permission. In my application (Well the application I extracted this code from), it is an advantage because the images are very large and it takes time to create the thumbnails. Keeping the thumbnails on disk improve performance.

Thumbnails are created using GDI+ (See my other blog article about it: http://francois-piette.blogspot.be/2013/05/opensource-gdi-library.html). The code is really easy:

?
1
2
3
4
5
6
Image := TGPImage.Create(AFileName);
   Thumbnail := Image.GetThumbnailImage(ThWidth, ThHeight, nil, nil);
   Quality := 50;
   Params := TGPEncoderParameters.Create;
   Params.Add(EncoderQuality, Quality);
   Thumbnail.Save(AThumbFileName, TGPImageFormat.Jpeg, Params);

A last note about the demo application: I used custom draw of the ListView items so that it looks exactly how I require it. All list view items are represented by a class named TImageListViewItem. I have selected this representation because in the real application this demo is extracted from, there is a lot of information about each image. The class is really handy to hold the information and the processing related to it.


Here after is the complete source code. There are mainly two files: DropHanlder.pas and DragDropMain.pas. You can also download a zip file with the complete project. See my website at: http://www.overbyte.be/frame_index.html?redirTo=/blog_source_code.html

DropHandler.pas

?
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
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
unit DropHandler;
 
interface
 
uses
    Windows, Types, Classes, SysUtils, ShellAPI, ActiveX;
 
type
    TStringArray      = array of String;
 
    TDropAllowedEvent = procedure (Sender            : TObject;
                                   const FileNames   : array of String;
                                   const grfKeyState : Longint;
                                   const pt          : TPoint;
                                   var   Allowed     : Boolean)
                                 of object;
    TDragOverEvent    = procedure (Sender            : TObject;
                                   const grfKeyState : Longint;
                                   const pt          : TPoint;
                                   var   Allowed     : Boolean)
                                 of object;
    TDropEvent        =  procedure (Sender           : TObject;
                                    const DropPoint  : TPoint;
                                    const FileNames  : array of String)
                                 of object;
 
    TDropTarget = class(TObject, IDropTarget)
    private
        FRegisteredHandle : HWND;
        FDropAllowed      : Boolean;
        FOnDropAllowed    : TDropAllowedEvent;
        FOnDrop           : TDropEvent;
        FOnDragOver       : TDragOverEvent;
        FOnDragLeave      : TNotifyEvent;
        procedure GetFileNames(const dataObj : IDataObject;
                               var FileNames : TStringArray);
        function  DragEnter(const dataObj : IDataObject;
                            grfKeyState   : Integer;
                            pt            : TPoint;
                            var dwEffect  : Integer): HResult; stdcall;
        function  DragOver(grfKeyState  : Longint;
                           pt           : TPoint;
                           var dwEffect : Longint): HResult; stdcall;
        function  DragLeave: HResult; stdcall;
        function  Drop(const dataObj : IDataObject;
                       grfKeyState   : Longint;
                       pt            : TPoint;
                       var dwEffect  : Longint): HResult; stdcall;
        function _AddRef: Integer; stdcall;
        function _Release: Integer;  stdcall;
        function QueryInterface(const IID: TGUID; out Obj): HResult;  stdcall;
    public
        destructor  Destroy; override;
        // Call Register() with a window handle so that that window starts
        // accepting dropped files. Events will then be generated.
        function    Register(AHandle : HWnd) : HResult;
        // Stop accepting files dropped on the registered window.
        procedure   Revoke;
        // DropAllowed event is called once when the dragged files are
        // entering the area of the registered window.
        // The event handler must set the Allowed var argument to TRUE if
        // dropping the file(s) is allowed at the given point
        property OnDropAllowed : TDropAllowedEvent read  FOnDropAllowed
                                                   write FOnDropAllowed;
        // DragOver event is called as mouse move above the registered window
        // The event handler must set the Allowed var argument to TRUE if
        // dropping the file(s) is allowed at the given point
        property OnDragOver    : TDragOverEvent    read  FOnDragOver
                                                   write FOnDragOver;
        // Drop event is called when the user drops the files.
        property OnDrop        : TDropEvent        read  FOnDrop
                                                   write FOnDrop;
        // DragLeave event is called when the dragged files leave the
        // registered window area.
        property OnDragLeave   : TNotifyEvent      read  FOnDragLeave
                                                   write FOnDragLeave;
    end;
 
implementation
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDropTarget.Register(AHandle: HWnd): HResult;
begin
    if FRegisteredHandle = AHandle then begin
        Result := S_OK;
        Exit;
    end;
    if FRegisteredHandle <> 0 then
        Revoke;
    FRegisteredHandle := AHandle;
    Result  := ActiveX.RegisterDragDrop(FRegisteredHandle, Self);
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDropTarget.Revoke;
begin
    if FRegisteredHandle <> 0 then begin
        ActiveX.RevokeDragDrop(FRegisteredHandle);
        FRegisteredHandle := 0;
    end;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TDropTarget.Destroy;
begin
    Revoke;
    inherited Destroy;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDropTarget.GetFileNames(
    const dataObj : IDataObject;
    var FileNames : TStringArray);
var
    I           : Integer;
    FormatetcIn : TFormatEtc;
    Medium      : TStgMedium;
    DropHandle  : HDROP;
begin
    FileNames            := nil;
    FormatetcIn.cfFormat := CF_HDROP;
    FormatetcIn.ptd      := nil;
    FormatetcIn.dwAspect := DVASPECT_CONTENT;
    FormatetcIn.lindex   := -1;
    FormatetcIn.tymed    := TYMED_HGLOBAL;
    if dataObj.GetData(FormatetcIn, Medium) = S_OK then begin
        DropHandle := HDROP(Medium.hGlobal);
        SetLength(FileNames, DragQueryFile(DropHandle, $FFFFFFFF, nil, 0));
        for I := 0 to high(FileNames) do begin
            SetLength(FileNames[I], DragQueryFile(DropHandle, I, nil, 0));
            DragQueryFile(DropHandle, I, @FileNames[I][1],
                          Length(FileNames[I]) + 1);
        end;
    end;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDropTarget.DragEnter(
    const dataObj : IDataObject;
    grfKeyState   : Integer;
    pt            : TPoint;
    var dwEffect  : Integer): HResult;
var
    FileNames: TStringArray;
begin
    Result := S_OK;
    try
        GetFileNames(dataObj, FileNames);
        if (Length(FileNames) > 0) and Assigned(FOnDropAllowed) then begin
            FDropAllowed := FALSE;
            FOnDropAllowed(Self, FileNames, grfKeyState, pt, FDropAllowed);
        end;
        if FDropAllowed then
            dwEffect := DROPEFFECT_COPY
        else
            dwEffect := DROPEFFECT_NONE;
    except
        Result := E_UNEXPECTED;
    end;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDropTarget.DragLeave: HResult;
begin
    if Assigned(FOnDragLeave) then
        FOnDragLeave(Self);
    Result := S_OK;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDropTarget.DragOver(
    grfKeyState  : Integer;
    pt           : TPoint;
    var dwEffect : Integer): HResult;
begin
    Result := S_OK;
    try
        if Assigned(FOnDragOver) then
            FOnDragOver(Self, grfKeyState, pt, FDropAllowed);
        if FDropAllowed then
            dwEffect := DROPEFFECT_COPY
        else
            dwEffect := DROPEFFECT_NONE;
    except
        Result := E_UNEXPECTED;
    end;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDropTarget.Drop(
    const dataObj : IDataObject;
    grfKeyState   : Integer;
    pt            : TPoint;
    var dwEffect  : Integer): HResult;
var
    FileNames: TStringArray;
begin
    Result := S_OK;
    try
        GetFileNames(dataObj, FileNames);
        if (Length(FileNames) > 0) and Assigned(FOnDrop) then
            FOnDrop(Self, Pt, FileNames);
    except
        // Silently ignore any exception bacsue if required, they should
        // be handled in OnDrop event handler.
    end;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDropTarget.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
    if GetInterface(IID, Obj) then
        Result := 0
    else
        Result := E_NOINTERFACE;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDropTarget._AddRef: Integer;
begin
    // We don't use reference counting in this object
    // We need _AddRef because RegisterDragDrop API call it
    Result := 1;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDropTarget._Release: Integer;
begin
    // We don't use reference counting in this object
    // We need _Release because RevokeDragDrop API call it
    Result := 1;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
 
end.

DragDropMain.pas

?
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
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
unit DragDropMain;
 
interface
 
uses
    Windows, Messages, Types, SysUtils, Variants, Classes, Graphics,
    StdCtrls, ExtCtrls, Controls, ComCtrls, CommCtrl, Forms, Dialogs,
    Jpeg, ImgList,
    GdiPlus,
    DropHandler;
 
const
    AtEndOfPipe      = -1;
    AtTopOfPipe      = -2;
    THUMBNAIL_SIZE   = 64;
    THUMBNAIL_MARGIN = 8;
    // List of accepted image file extensions
    Exts     : array [0..3] of String = ('.jpg', '.png', '.bmp', '.tif');
 
type
    TImageListViewItem = class
    public
        FileName          : String;
        Bitmap            : TBitmap;
        Data              : TObject;
        ThumbnailFileName : String;
        constructor Create(const AFileName          : String;
                           const AThumbnailFileName : String;
                           const AItem              : TListItem;
                           const AWidth             : Integer;
                           const AHeight            : Integer);
        destructor  Destroy; override;
    end;
 
    TDragDropMainForm = class(TForm)
        ListView1: TListView;
        Splitter1: TSplitter;
        Image1: TImage;
        procedure ListView1CustomDrawItem(Sender          : TCustomListView;
                                          Item            : TListItem;
                                          State           : TCustomDrawState;
                                          var DefaultDraw : Boolean);
        procedure ListView1Deletion(Sender : TObject;
                                    Item   : TListItem);
        procedure ListView1MouseDown(Sender : TObject;
                                     Button : TMouseButton;
                                     Shift  : TShiftState;
                                     X, Y   : Integer);
        procedure ListView1MouseMove(Sender: TObject;
                                     Shift : TShiftState;
                                     X, Y  : Integer);
        procedure ListView1MouseUp(Sender : TObject;
                                   Button : TMouseButton;
                                   Shift  : TShiftState;
                                   X, Y   : Integer);
    private
        FDropTarget              : TDropTarget;
        FMouseDownPt             : TPoint;
        FMouseMovePt             : TPoint;
        FMouseDownFlag           : Boolean;
        FDraggingImage           : Boolean;
        procedure ImageDragOverHandler(Sender            : TObject;
                                       const grfKeyState : Longint;
                                       const pt          : TPoint;
                                       var   Allowed     : Boolean);
        procedure ImageDropAllowedHandler(Sender            : TObject;
                                          const FileNames   : array of string;
                                          const GrfKeyState : Integer;
                                          const Pt          : TPoint;
                                          var   Allowed     : Boolean);
        procedure ImageDropHandler(Sender          : TObject;
                                   const DropPoint : TPoint;
                                   const FileNames : array of string);
        function  DropImage(const AFileName : String;
                            XScreen         : Integer;
                            YScreen         : Integer): Boolean;
        procedure CreateThumbnail(const AFileName      : String;
                                     var   AThumbFileName : String);
        function  KnownExtension(const FileName : String): Boolean; overload;
        function  KnownExtension(const FileNames: array of string): Boolean; overload;
    protected
        procedure CreateWnd; override;
        procedure DestroyWnd; override;
    public
        constructor Create(AOwner : TComponent); override;
        destructor  Destroy; override;
        procedure AddImage(const FileName : String;
                           BeforeIndex    : Integer);
        procedure MoveImage(IFrom, ITo: Integer);
        procedure RemoveImage(Index: Integer); overload;
        function  FindImage(const FileName: String): Integer;
        function  AppendImage(const FileName: String): Integer;
    end;
 
function ReplaceThumb(const FileName : String) : String;
function ListViewMouseToItem(
    Pt           : TPoint;
    LV           : TListView;
    var ColIndex : Integer): TListItem;
 
var
  DragDropMainForm: TDragDropMainForm;
 
implementation
 
{$R *.dfm}
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
 
{ TDragDropMainForm }
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TDragDropMainForm.Create(AOwner: TComponent);
begin
    FDropTarget               := TDropTarget.Create;
    FDropTarget.OnDropAllowed := ImageDropAllowedHandler;
    FDropTarget.OnDrop        := ImageDropHandler;
    FDropTarget.OnDragOver    := ImageDragOverHandler;
    inherited Create(AOwner);
 
    // To have TListView work correctly in vsList view mode, we must have
    // at least one group, one column and a SmallImages image list.
    ListView1.Groups.Clear;
    ListView1.Groups.Add;
    ListView1.Columns.Clear;
    ListView1.Columns.Add;
    // Height of displayed image is set by height of SmallImages
    ListView1.SmallImages        := TImageList.Create(Self);
    ListView1.SmallImages.Height := THUMBNAIL_SIZE + 2 * THUMBNAIL_MARGIN;
    // Width of displayed image is set by ListView_SetColumnWidth macro with
    // column index set to zero.
    ListView_SetColumnWidth(ListView1.Handle, 0, THUMBNAIL_SIZE + 2 * THUMBNAIL_MARGIN);
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.CreateWnd;
begin
    inherited CreateWnd;
    if Assigned(FDropTarget) then
        FDropTarget.Register(Handle);
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TDragDropMainForm.Destroy;
begin
    FreeandNil(FDropTarget);
    inherited;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.DestroyWnd;
begin
    inherited DestroyWnd;
    if Assigned(FDropTarget) then
        FDropTarget.Revoke;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.ImageDragOverHandler(
    Sender            : TObject;
    const grfKeyState : Longint;
    const pt          : TPoint;
    var   Allowed     : Boolean);
begin
    Allowed := TRUE;
    if not PtInRect(ListView1.BoundsRect, ListView1.ScreenToClient(Pt)) then begin
        Allowed := FALSE;
        Exit;
    end;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.ImageDropAllowedHandler(
    Sender            : TObject;
    const FileNames   : array of string;
    const GrfKeyState : Integer;
    const Pt          : TPoint;
    var   Allowed     : Boolean);
begin
    Allowed := KnownExtension(FileNames);
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.ImageDropHandler(
    Sender          : TObject;
    const DropPoint : TPoint;
    const FileNames : array of string);
var
    I : Integer;
begin
    for I := 0 to High(FileNames) do
        DropImage(ReplaceThumb(FileNames[I]), DropPoint.X, DropPoint.Y);
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDragDropMainForm.DropImage(
    const AFileName : String;
    XScreen         : Integer;
    YScreen         : Integer) : Boolean;
var
    Pt       : TPoint;
    Item     : TListItem;
    ColIndex : Integer;
begin
    Result := FALSE;
    // First check if the extension is allowed
    if not KnownExtension(AFileName) then begin
        ShowMessage('Unacceptable file type (' +
                    ExtractFileExt(AFileName) + ')');
        Exit;
    end;
 
    // Check if we already got the image
    if FindImage(AFileName) >= 0 then begin
        ShowMessage(AFileName + #10 + 'Already in the ListView, ignoring');
        Exit;
    end;
 
    // Check if the drop point is inside the ListView
    Pt := ListView1.ScreenToClient(Point(XScreen, YScreen));
    if not PtInRect(ListView1.BoundsRect, Pt) then
        Exit;
    // Check if dropped on an existing item
    Item := ListViewMouseToItem(Pt, ListView1, ColIndex);
    if not Assigned(Item) then
        AppendImage(AFileName)           // Not on an item, add at the end
    else
        AddImage(AFileName, Item.Index); // Insert before the item
    Result   := TRUE;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.ListView1CustomDrawItem(
    Sender          : TCustomListView;
    Item            : TListItem;
    State           : TCustomDrawState;
    var DefaultDraw : Boolean);
var
    Bitmap  : TBitMap;
    Rc1     : TRect;
    Rc2     : TRect;
    Rc3     : TRect;
    ACanvas : TCanvas;
    YOff    : Integer;
    XOff    : Integer;
begin
    ACanvas := Sender.Canvas;
    Rc1 := Item.DisplayRect(drBounds);
    if Assigned(Item.Data) then begin
        Bitmap := TImageListViewItem(Item.Data).Bitmap;
        // Center the bitmap
        YOff := ((THUMBNAIL_SIZE - BitMap.Height) div 2) + THUMBNAIL_MARGIN;
        XOff := ((THUMBNAIL_SIZE - Bitmap.Width) div 2) + THUMBNAIL_MARGIN;
        ACanvas.Draw(Rc1.Left + 2 + XOff, Rc1.Top + 2 + YOff, Bitmap);
 
        // Draw a double FrameRect around the image with a color depending
        // on the status of the image
        Rc2.Left   := Rc1.Left + XOff;
        Rc2.Top    := Rc1.Top  + YOff;
        Rc2.Right  := Rc1.Left + Bitmap.Width  + 4 + XOff;
        Rc2.Bottom := Rc1.Top  + Bitmap.Height + 4 + YOff;
        Rc3.Left   := Rc1.Left + 1 + XOff;
        Rc3.Top    := Rc1.Top  + 1 + YOff;
        Rc3.Right  := Rc1.Left + Bitmap.Width  + 3 + XOff;
        Rc3.Bottom := Rc1.Top  + Bitmap.Height + 3 + YOff;
 
        if cdsSelected in State then
            ACanvas.Brush.Color := clBlue
        else if cdsHot in State then
            ACanvas.Brush.Color := clRed
        else
            ACanvas.Brush.Color := ListView1.Color;
 
        ACanvas.FrameRect(Rc2);
        ACanvas.FrameRect(Rc3);
 
        DefaultDraw := FALSE;
    end;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.ListView1Deletion(
    Sender : TObject;
    Item   : TListItem);
begin
    if Assigned(Item.Data) then
        TObject(Item.Data).Free;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.ListView1MouseDown(
    Sender : TObject;
    Button : TMouseButton;
    Shift  : TShiftState;
    X, Y   : Integer);
begin
    if ssLeft in Shift then begin
        FMouseDownPt := Point(X, Y);
        FMouseDownFlag := TRUE;
    end;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.ListView1MouseMove(
    Sender : TObject;
    Shift  : TShiftState;
    X, Y   : Integer);
var
    Item     : TListItem;
    ColIndex : Integer;
begin
    FMouseMovePt := Point(X, Y);
    if not FMouseDownFlag then
        Exit;
    if not FDraggingImage then begin
        Item := ListViewMouseToItem(FMouseDownPt, ListView1, ColIndex);
        if Assigned(Item) then begin
            FDraggingImage := TRUE;
            Screen.Cursor  := crDrag;
            SetCaptureControl(ListView1);
        end;
    end;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.ListView1MouseUp(
    Sender : TObject;
    Button : TMouseButton;
    Shift  : TShiftState;
    X, Y   : Integer);
var
    Pt       : TPoint;
    ItemFrom : TListItem;
    ItemTo   : TListItem;
    ColIndex : Integer;
    LV       : TListView;
    IFrom    : Integer;
    ITo      : Integer;
    FileName : String;
begin
    FMouseDownFlag := FALSE;
    if FDraggingImage then begin
        FDraggingImage := FALSE;
        Screen.Cursor  := crDefault;
        SetCaptureControl(nil);
        LV       := Sender as TListView;
        ItemFrom := ListViewMouseToItem(FMouseDownPt, LV, ColIndex);
        ItemTo   := ListViewMouseToItem(Point(X, Y),  LV, ColIndex);
        IFrom    := ItemFrom.Index;
        FileName := TImageListViewItem(ItemFrom.Data).FileName;
        if not FileExists(FileName) then begin
            if Application.MessageBox(
                   PChar('File "' + FileName + '" doesn''t exist anymore' +
                         #10 + 'Remove from ListView ?'), 'WARNING',
                         MB_YESNO + MB_DEFBUTTON2) = IDYES then begin
                RemoveImage(IFrom);
                Exit;
            end;
        end;
 
        if Assigned(ItemTo) then begin
            // Drop inside of the pipe, move items around
            if ItemTo <> ItemFrom then begin
                ITo   := ItemTo.Index;
                MoveImage(IFrom, ITo);
            end;
        end
        else begin
            if PtInRect(LV.BoundsRect, Point(X, Y)) then begin
                // Drop on the listview but not on an item, just move at the end
                ITo := LV.Items.Count - 1;
                MoveImage(IFrom, ITo);
            end
            else begin
                // Drop outside of the ListView
                // Check if within Image1
                Pt := ListView1.ClientToScreen(Point(X, Y));
                Pt := Image1.ScreenToClient(Pt);
                if (Pt.X >= 0) and (Pt.X < Image1.Width) and
                   (Pt.Y >= 0) and (Pt.Y < Image1.Height) then begin
                    Image1.Picture.LoadFromFile(TImageListViewItem(ItemFrom.Data).FileName);
                end;
            end;
        end;
    end;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.AddImage(
    const FileName : String;
    BeforeIndex    : Integer);  // Index of the item where to insert (before)
var
    IFrom : Integer;
begin
    IFrom := AppendImage(FileName);
    if IFrom < 0 then
        Exit;            // Not found or already exist, not added
    if BeforeIndex = AtTopOfPipe then
        MoveImage(IFrom, 0)
    else if (BeforeIndex >= 0) and (BeforeIndex < ListView1.Items.Count) then
        MoveImage(IFrom, BeforeIndex);
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// Search if a give file already exists in list.
// Return -1 if not found
// Return item index if already in the list
function TDragDropMainForm.FindImage(const FileName: String): Integer;
begin
    for Result := 0 to ListView1.Items.Count - 1 do begin
        if SameText(FileName,
                    TImageListViewItem(ListView1.Items[Result].Data).FileName) then
            Exit;
    end;
    Result := -1;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.MoveImage(
    IFrom : Integer;
    ITo   : Integer);
var
    Data     : Pointer;
    Capt     : String;
    I        : Integer;
begin
    if IFrom < ITo then begin
        Data := ListView1.Items[IFrom].Data;
        Capt := ListView1.Items[IFrom].Caption;
        for I := IFrom to ITo - 1 do begin
            ListView1.Items[I].Data    := ListView1.Items[I + 1].Data;
            ListView1.Items[I].Caption := ListView1.Items[I + 1].Caption;
            TImageListViewItem(ListView1.Items[I].Data).Data := ListView1.Items[I];
        end;
        ListView1.Items[ITo].Data    := Data;
        ListView1.Items[ITo].Caption := Capt;
        TImageListViewItem(ListView1.Items[ITo].Data).Data := ListView1.Items[ITo];
    end
    else begin
        Data := ListView1.Items[IFrom].Data;
        Capt := ListView1.Items[IFrom].Caption;
        for I := IFrom downto ITo + 1 do begin
            ListView1.Items[I].Data    := ListView1.Items[I - 1].Data;
            ListView1.Items[I].Caption := ListView1.Items[I - 1].Caption;
            TImageListViewItem(ListView1.Items[I].Data).Data := ListView1.Items[I];
        end;
        ListView1.Items[ITo].Data    := Data;
        ListView1.Items[ITo].Caption := Caption;
        TImageListViewItem(ListView1.Items[ITo].Data).Data := ListView1.Items[ITo];
    end;
    Windows.InvalidateRect(ListView1.Handle, nil, FALSE);
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDragDropMainForm.KnownExtension(
    const FileName : String) : Boolean;
var
    Ext : String;
    I   : Integer;
begin
    Result := FALSE;
    Ext := ExtractFileExt(FileName);
    for I := Low(Exts) to High(Exts) do begin
        if SameText(Ext, Exts[I]) then begin
            Result := TRUE;
            Exit;
        end;
    end;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDragDropMainForm.KnownExtension(
    const FileNames : array of string) : Boolean;
var
    I : Integer;
begin
    Result := FALSE;
    for I := Low(FileNames) to High(FileNames) do begin
        if KnownExtension(FileNames[I]) then begin
            Result := TRUE;
            Exit;
        end;
    end;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// Given a filename which could be a thumbnail filename, return either the
// filename unchanged or the image which is represented by thumbnail
function ReplaceThumb(const FileName : String) : String;
const
    ThSuffix = '.thumb.jpg';
var
    S : String;
    I : Integer;
begin
    if not SameText(Copy(FileName, Length(FileName) - Length(ThSuffix) + 1, 200),
                    ThSuffix) then begin
        Result := FileName;
        Exit;
    end;
 
    S := Copy(FileName, 1, Length(FileName) - Length(ThSuffix));
    for I := Low(Exts) to High(Exts) do begin
        Result := S + Exts[I];
        if FileExists(Result) then
            Exit;
    end;
    Result := FileName;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// ColIndex returns the column index, not the SubItem index.
function ListViewMouseToItem(
    Pt           : TPoint;
    LV           : TListView;
    var ColIndex : Integer): TListItem;
var
    Info : TLVHitTestInfo;
begin
//    Pt := LV.ScreenToClient(Mouse.Cursorpos);
    Result := LV.GetItemAt(Pt.X, Pt.Y);
    if Assigned(Result) then
        ColIndex := 0
    else begin
        FillChar(Info, SizeOf(Info), 0);
        Info.Pt := Pt;
        if LV.Perform(LVM_SUBITEMHITTEST, 0, LParam(@Info)) <> -1 then begin
            Result   := LV.Items[Info.iItem];
            ColIndex := Info.iSubItem;
        end;
    end;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDragDropMainForm.AppendImage(
    const FileName : String) : Integer;
var
    Item              : TListItem;
    ThumbnailFileName : String;
begin
    Result := -1;
    if not FileExists(FileName) then
        Exit;
    if FindImage(FileName) >= 0 then
        Exit;   // Already exist, do not add
    ThumbnailFileName := '';
    CreateThumbnail(FileName, ThumbnailFileName);
    Item         := ListView1.Items.Add;
    // Item.Caption is used as the hint
    Item.Caption := FileName;
    Item.Data    := TImageListViewItem.Create(FileName,
                                          ThumbnailFileName,
                                          Item,
                                          THUMBNAIL_SIZE,
                                          THUMBNAIL_SIZE);
    Result := Item.Index;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.RemoveImage(Index : Integer);
var
    I : Integer;
begin
    ListView1.Items.Delete(Index);
    for I := Index to ListView1.Items.Count - 1 do
        TImageListViewItem(ListView1.Items[I].Data).Data := ListView1.Items[I];
    Windows.InvalidateRect(ListView1.Handle, nil, FALSE);
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.CreateThumbnail(
    const AFileName      : String;
    var   AThumbFileName : String);
var
    ThWidth          : Integer;
    ThHeight         : Integer;
    FTFile           : TDateTime;
    FTThumb          : TDateTime;
    Image            : IGPImage;
    Thumbnail        : IGPImage;
    Params           : IGPEncoderParameters;
    Quality          : Int32;
begin
    AThumbFileName := ChangeFileExt(AFileName, '.thumb.jpg');
    if FileExists(AThumbFileName) then begin
        // Thumbnail file must be dated AFTER original file so that it
        // is recreated when the original file is changed.
        FileAge(AFileName, FTFile);
        FileAge(AThumbFileName, FTThumb);
        if FTThumb >= FTFile then
            Exit;
    end;
 
    Image := TGPImage.Create(AFileName);
 
    // Thumbnail preserve original width/height ratio
    if Image.Width > Image.Height then begin
        ThWidth  := THUMBNAIL_SIZE;
        ThHeight := THUMBNAIL_SIZE * Image.Height div Image.Width;
    end
    else if Image.Width < Image.Height then begin
        ThHeight := THUMBNAIL_SIZE;
        ThWidth  := THUMBNAIL_SIZE * Image.Width div Image.Height;
    end
    else begin
        ThWidth  := THUMBNAIL_SIZE;
        ThHeight := THUMBNAIL_SIZE;
    end;
 
    Thumbnail := Image.GetThumbnailImage(ThWidth, ThHeight, nil, nil);
    Quality := 50;
    Params := TGPEncoderParameters.Create;
    Params.Add(EncoderQuality, Quality);
    Thumbnail.Save(AThumbFileName, TGPImageFormat.Jpeg, Params);
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
 
{ TImagePipeItem }
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TImageListViewItem.Create(
    const AFileName          : String;
    const AThumbnailFileName : String;
    const AItem              : TListItem;
    const AWidth             : Integer;
    const AHeight            : Integer);
var
    JpegImg : TJPEGImage;
    Ext     : String;
begin
    inherited Create;
    Data               := AItem;
    FileName           := AFileName;
    ThumbnailFileName  := AThumbnailFileName;
    Bitmap             := TBitMap.Create;
    if (AThumbnailFileName <> '') and (FileExists(AThumbnailFileName)) then begin
        Ext := ExtractFileExt(AThumbnailFileName);
        if SameText(Ext, '.jpg') then begin
            JpegImg := TJPEGImage.Create;
            try
                JpegImg.LoadFromFile(AThumbnailFileName);
                BitMap.Width  := JpegImg.Width;
                BitMap.Height := JpegImg.Height;
                BitMap.Canvas.Draw(0, 0, JpegImg);
            finally
                JpegImg.Destroy;
            end;
        end
        else if SameText(Ext, '.bmp') then
            Bitmap.LoadFromFile(AThumbnailFileName)
    end
    else begin
        Bitmap.Width       := AWidth - 4;
        Bitmap.Height      := AHeight - 4;
        Bitmap.PixelFormat := pf24bit;
        Bitmap.Canvas.MoveTo(0, 0);
        BitMap.Canvas.LineTo(Bitmap.Width, Bitmap.Height);
        Bitmap.Canvas.MoveTo(Bitmap.Width, 0);
        BitMap.Canvas.LineTo(0, Bitmap.Height);
        BitMap.Canvas.LineTo(0, 0);
        BitMap.Canvas.LineTo(Bitmap.Width - 1, 0);
        BitMap.Canvas.LineTo(Bitmap.Width - 1, Bitmap.Height - 1);
        BitMap.Canvas.LineTo(0, Bitmap.Height - 1);
        Bitmap.Canvas.TextOut(4, 4, AFileName);
    end;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TImageListViewItem.Destroy;
begin
    FreeAndNil(Bitmap);
    inherited Destroy;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
 
end.


Download source code from: http://www.overbyte.be/frame_index.html?redirTo=/blog_source_code.html
Follow me on Twitter
Follow me on LinkedIn
Follow me on Google+
Visit my website: http://www.overbyte.be
Posted by at 3 comments:
Labels: , , , , , , , , , ,

June 9, 2013

Dynamic web page using Delphi, ICS and DWScript


ICS has a web application server component which allows you to build dynamic web page very easily. Delphi code for each web page is encapsulated in a TUrlHandler class and compiled into your application, making a standalone webserver application.

In the article, we will create a TUrlHandler class which will read a DWScript script from disc and execute it. The script is responsible for build a valid answer which ICS will send back to the client.

A simple “Hello World” script is made of a single line like this:

?
1
Response.Write('Server time is ' + DateTimeToStr(Now) + ' ');

To invoke it, assuming the script is located in “Hello.pas”, the user must enter this URL into his browser:
http://localhost:20105/DWScripts/Hello.pas

Remember it is a script. You can change the file on disc and the changes will be immediately reflected for the next request, without recompiling your application. This looks much like PHP but use Delphi syntax instead of PHP. To be honest, PHP may use embedded HTML code within the script which is not supported here.

A more complex script may make use of request parameters. For example, the script “Add.pas” could looks like:

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
var Value1 : String;
var Value2 : String;
Response.ContentType := 'text/html';
Response.Status := '200 OK';
Response.Write('');
Response.Write('ICS and DWScript demo
');
Response.Write('Server time is ' + DateTimeToStr(Now) + '
');
if not Request.CheckParamByName('Value1', Value1) then
    Response.Write('Missing Value1 parameter
')
else if not Request.CheckParamByName('Value2', Value2) then
    Response.Write('Missing Value2 parameter
')
else Response.Write(Value1 + ' + ' + Value2 + ' = ' +
    IntToStr(StrToIntDef(Value1, 0) + StrToIntDef(Value2, 0)));
Response.Write('');

The URL to use in the browser looks like:
http://localhost:20105/DWScripts/Add.pas?Value1=123&Value2=456

Getting ICS and DWScript

ICS:    http://wiki.overbyte.be/wiki/index.php/ICS_Download
DWScript: http://code.google.com/p/dwscript/

Implementation


Less than 200 Delphi code is required to implement this behavior in an ICS based web application server. The code I will show you below can be plugged in OverbyteIcsWebAppServer demo application you can find in ICS V8 distribution. Two lines must be added to the main file in order to add the feature: add the unit in the uses clause and add a line to map “/DWScript/*” to the TUrlHandler taking care of the script.

Using the above wild card mapping, the TUrlHandler will be invoked for any URL beginning with “/DWScript/”. It will then access the full path to get the script filename. In the above examples, I used a “.pas” file extension for ease, but this is not mandatory at all. You can use any extensions and even no extension if you don’t like to have the user know you are using a DWScript.

In the implementation, I managed to have the DWScript not directly accessible thru an URL. This protects your source code. The user can’t access it. He can just execute it (Note that ICS THttpServer component has an option which allows access to any file, so what I just said maybe wrong).

The script has two objects instances readily available: “Request” and “Response”. They maps to the corresponding Delphi object instances and classes:

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
THttpResponse = class(TPersistent)
private
    FStatus      : String;
    FContentType : String;
public
    DocStream    : TStream;
published
    property Status      : String read FStatus      write FStatus;
    property ContentType : String read FContentType write FContentType;
    procedure Write(const S : String);
end;
 
THttpRequest = class(TPersistent)
public
    Params : String;
    class function ReadTextFile(const FileName : String) : String;
published
    function  GetParamByName(const ParamName: String): String;
    function  CheckParamByName(const ParamName  : String;
                               var   ParamValue : String): Boolean;
end;

When using DWScript ExposeRTTI function, you are exposing a Delphi class. With the options I selected, only the published methods and properties will be exposed to the script.

THttpResponse exposes Status and ContentType properties as well as Write method. The two properties allows the script to select the HTTP status return and the HTTP content type. They default to “200 OK” and “text/html” which are the most common values. You can use anything you need for your application.

The Write method will be used by the script to produce the document part of the HTTP response sent back to the client. Obviously, the document format must match the content type.

THttpRequest exposes the incoming request. Using it you may access the parameters passed thru the URL. One method gets a parameter value when you provides his name while the other return the value as well as a Boolean value telling if the parameter exists or not.

The most important part of the code is a TUrlHandler derived class. I named it TUrlHandlerDWScript. His declaration looks like this:

?
1
2
3
4
5
6
7
8
9
10
11
12
13
TUrlHandlerDWScript = class(TUrlHandler)
protected
    FScript                  : IdwsProgram;
    FCompileMsgs             : String;
    FDelphiWebScript         : TDelphiWebScript;
    FUnit                    : TdwsUnit;
    FExec                    : IdwsProgramExecution;
    FHttpRequest             : THttpRequest;
    FHttpResponse            : THttpResponse;
    procedure ExposeInstancesAfterInitTable(Sender: TObject);
public
    procedure Execute; override;
end;

The five first member variables are required for DWScript operation. You should look at DWScript documentation for help about their use.

The last two member variables are the object instances we talk above. Their published parts are exposed to the script.

There is also an event handler ExposeInstancesAfterInitTable which is required by DWScript engine to expose the Delphi object instances to the script.

Finally, there is a single method which is called by ICS web application server framework to handle the mapped URL. This is where almost everything happens.

?
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
procedure TUrlHandlerDWScript.Execute;
var
    SrcFileName : String;
    Source      : String;
begin
    FDelphiWebScript  := TDelphiWebScript.Create(nil);
    FUnit             := TdwsUnit.Create(nil);
    FHttpResponse     := THttpResponse.Create;
    FHttpRequest      := THttpRequest.Create;
    try
        DocStream.Free;
        DocStream := TMemoryStream.Create;
 
        FHttpResponse.DocStream    := DocStream;
        FHttpResponse.Status       := '200 OK';
        FHttpResponse.ContentType  := 'text/html';
        FHttpRequest.Params        := Params;
 
        FUnit.OnAfterInitUnitTable := ExposeInstancesAfterInitTable;
        FUnit.UnitName             := 'WebPage';
        FUnit.Script               := FDelphiWebScript;
        FUnit.ExposeRTTI(TypeInfo(THttpResponse), [eoNoFreeOnCleanup]);
        FUnit.ExposeRTTI(TypeInfo(THttpRequest),  [eoNoFreeOnCleanup]);
        // In this application, we have placed DWScripts source code in
        // a directory at the same level as the "Template" folder.
        SrcFileName := ExcludeTrailingPathDelimiter(
                           ExtractFilePath(Client.TemplateDir)) +
                       StringReplace(Client.Path, '/', '\', [rfReplaceAll]);
        if not FileExists(SrcFileName) then
            FHttpResponse.Write('Script not found')
        else begin
            Source       := FHttpRequest.ReadTextFile(SrcFileName);
            FScript      := FDelphiWebScript.Compile(Source);
            FCompileMsgs := FScript.Msgs.AsInfo;
            if FScript.Msgs.HasErrors then begin
                FHttpResponse.Write('' + FCompileMsgs + '');
            end
            else begin
                FExec    := FScript.Execute;
            end;
        end;
        AnswerStream(FHttpResponse.Status, FHttpResponse.ContentType, NO_CACHE);
    finally
        FreeAndNil(FUnit);
        FreeAndNil(FDelphiWebScript);
        FreeAndNil(FHttpResponse);
        FreeAndNil(FHttpRequest);
    end;
    Finish;
end;


Basically the code creates all the required object instances, initializes default values, expose Delphi classes, read the script source code from file, compile the script and either create an error message should any compilation fails, or execute the script so that it can produce the document. Finally, the document is sent back and all object instances are destroyed.

Full source code:


The code is available from my website, see
   http://www.overbyte.be/frame_index.html?redirTo=/blog_source_code.html


?
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
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
unit OverbyteIcsWebAppServerDWScriptUrlHandler;
 
interface
 
uses
    Classes, SysUtils, OverbyteIcsHttpAppServer, OverbyteIcsHttpSrv,
    dwsVCLGUIFunctions,
    dwsMagicExprs,
    dwsRTTIExposer,
    dwsFunctions,
    dwsSymbols,
    dwsExprs,
    dwsComp;
 
 
type
    THttpResponse = class(TPersistent)
    private
        FStatus      : String;
        FContentType : String;
    public
        DocStream    : TStream;
    published
        property Status      : String read FStatus      write FStatus;
        property ContentType : String read FContentType write FContentType;
        procedure Write(const S : String);
    end;
 
    THttpRequest = class(TPersistent)
    public
        Params : String;
        class function ReadTextFile(const FileName : String) : String;
    published
        function  GetParamByName(const ParamName: String): String;
        function  CheckParamByName(const ParamName  : String;
                                   var   ParamValue : String): Boolean;
    end;
 
    TUrlHandlerDWScript = class(TUrlHandler)
    protected
        FScript                  : IdwsProgram;
        FCompileMsgs             : String;
        FDelphiWebScript         : TDelphiWebScript;
        FUnit                    : TdwsUnit;
        FExec                    : IdwsProgramExecution;
        FHttpRequest             : THttpRequest;
        FHttpResponse            : THttpResponse;
        procedure ExposeInstancesAfterInitTable(Sender: TObject);
    public
        procedure Execute; override;
    end;
 
implementation
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
 
{ TUrlHandlerDWScript }
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TUrlHandlerDWScript.Execute;
var
    SrcFileName : String;
    Source      : String;
begin
    FDelphiWebScript  := TDelphiWebScript.Create(nil);
    FUnit             := TdwsUnit.Create(nil);
    FHttpResponse     := THttpResponse.Create;
    FHttpRequest      := THttpRequest.Create;
    try
        DocStream.Free;
        DocStream := TMemoryStream.Create;
 
        FHttpResponse.DocStream    := DocStream;
        FHttpResponse.Status       := '200 OK';
        FHttpResponse.ContentType  := 'text/html';
        FHttpRequest.Params        := Params;
 
        FUnit.OnAfterInitUnitTable := ExposeInstancesAfterInitTable;
        FUnit.UnitName             := 'WebPage';
        FUnit.Script               := FDelphiWebScript;
        FUnit.ExposeRTTI(TypeInfo(THttpResponse), [eoNoFreeOnCleanup]);
        FUnit.ExposeRTTI(TypeInfo(THttpRequest),  [eoNoFreeOnCleanup]);
        // In this application, we have placed DWScripts source code in
        // a directory at the same level as the "Template" folder.
        SrcFileName := ExcludeTrailingPathDelimiter(
                           ExtractFilePath(Client.TemplateDir)) +
                       StringReplace(Client.Path, '/', '\', [rfReplaceAll]);
        if not FileExists(SrcFileName) then
            FHttpResponse.Write('Script not found')
        else begin
            Source       := FHttpRequest.ReadTextFile(SrcFileName);
            FScript      := FDelphiWebScript.Compile(Source);
            FCompileMsgs := FScript.Msgs.AsInfo;
            if FScript.Msgs.HasErrors then begin
                FHttpResponse.Write('' + FCompileMsgs + '');
            end
            else begin
                FExec    := FScript.Execute;
            end;
        end;
        AnswerStream(FHttpResponse.Status, FHttpResponse.ContentType, NO_CACHE);
    finally
        FreeAndNil(FUnit);
        FreeAndNil(FDelphiWebScript);
        FreeAndNil(FHttpResponse);
        FreeAndNil(FHttpRequest);
    end;
    Finish;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TUrlHandlerDWScript.ExposeInstancesAfterInitTable(Sender: TObject);
begin
    FUnit.ExposeInstanceToUnit('Response', 'THttpResponse', FHttpResponse);
    FUnit.ExposeInstanceToUnit('Request',  'THttpRequest',  FHttpRequest);
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
 
{ THttpResponse }
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpResponse.Write(const S: String);
var
   Ch : Char;
   B  : Byte;
begin
    for Ch in S do begin
        // We should convert the Unicode string to whatever the document
        // is supposed to be. Here we just convert it, brute force, to ASCII.
        // This won't work eastern character sets.
        B := Ord(AnsiChar(Ch));
        DocStream.Write(B, 1);
    end;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
 
{ THttpRequest }
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function THttpRequest.CheckParamByName(
    const ParamName  : String;
    var   ParamValue : String): Boolean;
begin
    Result := ExtractURLEncodedValue(Params, ParamName, ParamValue);
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function THttpRequest.GetParamByName(const ParamName: String): String;
begin
    ExtractURLEncodedValue(Params, ParamName, Result);
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
class function THttpRequest.ReadTextFile(const FileName : String) : String;
var
    Stream : TFileStream;
    AnsiBuf : AnsiString;
begin
    Stream := TFileStream.Create(FileName, fmOpenRead);
    try
        SetLength(AnsiBuf, Stream.Size);
        Stream.Read(AnsiBuf[1], Stream.Size);
        Result := String(AnsiBuf);
    finally
        FreeAndNil(Stream);
    end;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
 
end.


Download source code from: http://www.overbyte.be/frame_index.html?redirTo=/blog_source_code.html
Follow me on Twitter
Follow me on LinkedIn
Follow me on Google+
Visit my website: http://www.overbyte.be
Posted by at 1 comment:
Labels: , , , , , , , , , , , , ,

June 2, 2013

Installing ICS for FireMonkey in Delphi XE4

Arno Garrels recorded a tutorial video showing the installation steps required to make ICS v8 works with FireMonkey in Delphi XE4.



Full resolution video here (70 MB, zipped)
Download ICS
Follow me on Twitter
Follow me on LinkedIn
Follow me on Google+
Visit my website: http://www.overbyte.be
Posted by at No comments:
Labels: , , , , ,
Subscribe to: Posts (Atom)