source: cprs/branches/tmg-cprs/CPRS-Chart/TMG_Extra/HTMLEdit/EwbEventsComp.pas@ 1561

Last change on this file since 1561 was 541, checked in by Kevin Toppenberg, 15 years ago

TMG Ver 1.1 Added HTML Support, better demographics editing

File size: 18.6 KB
Line 
1//*************************************************************
2// EwbEventsComp *
3// *
4// Freeware Component *
5// For Delphi *
6// by *
7// Serge Voloshenyuk *
8// Developing Team: *
9// Serge Voloshenyuk (SergeV@bsalsa.com) *
10// Eran Bodankin (bsalsa) -(bsalsa@gmail.com) *
11// *
12// Documentation and updated versions: *
13// *
14// http://www.bsalsa.com *
15//*************************************************************
16{LICENSE:
17THIS SOFTWARE IS PROVIDED TO YOU "AS IS" WITHOUT WARRANTY OF ANY KIND,
18EITHER EXPRESSED OR IMPLIED INCLUDING BUT NOT LIMITED TO THE APPLIED
19WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
20YOU ASSUME THE ENTIRE RISK AS TO THE ACCURACY AND THE USE OF THE SOFTWARE
21AND ALL OTHER RISK ARISING OUT OF THE USE OR PERFORMANCE OF THIS SOFTWARE
22AND DOCUMENTATION. BSALSA PRODUCTIONS DOES NOT WARRANT THAT THE SOFTWARE IS ERROR-FREE
23OR WILL OPERATE WITHOUT INTERRUPTION. THE SOFTWARE IS NOT DESIGNED, INTENDED
24OR LICENSED FOR USE IN HAZARDOUS ENVIRONMENTS REQUIRING FAIL-SAFE CONTROLS,
25INCLUDING WITHOUT LIMITATION, THE DESIGN, CONSTRUCTION, MAINTENANCE OR
26OPERATION OF NUCLEAR FACILITIES, AIRCRAFT NAVIGATION OR COMMUNICATION SYSTEMS,
27AIR TRAFFIC CONTROL, AND LIFE SUPPORT OR WEAPONS SYSTEMS. BSALSA PRODUCTIONS SPECIFICALLY
28DISCLAIMS ANY EXPRESS OR IMPLIED WARRANTY OF FITNESS FOR SUCH PURPOSE.
29
30You may use/ change/ modify the component under 3 conditions:
311. In your website, add a link to "http://www.bsalsa.com"
322. In your application, add credits to "Embedded Web Browser"
333. Mail me (bsalsa@gmail.com) any code change in the unit for the benefit
34 of the other users.
354. Please, consider donation in our web site!
36{*******************************************************************************}
37//$Id: EwbEventsComp.pas,v 1.1.2.1 2006/11/29 22:13:01 sergev Exp $
38
39unit EwbEventsComp;
40
41interface
42
43{$I EWB.inc}
44
45uses
46{$IFDEF DELPHI6_UP}Variants, {$ENDIF}
47 Windows, Classes, ActiveX, Mshtml_Ewb, EwbAcc, EwbClasses, EwbEvents;
48
49type
50 THtmlListener = class;
51
52 TEventEnum = (
53 eiUnknown,
54 eiOnAbort,
55 eiOnChange,
56 eiOnError,
57 eiOnLoad,
58 eiOnSelect,
59 eiOnSubmit,
60 eiOnUnload,
61 eiOnBounce,
62 eiOnFinish,
63 eiOnStart,
64 eiOnScroll,
65 eiOnReset,
66 eiOnresize,
67 eiOnBeforeUnload,
68 eiOncontextmenu,
69 eiOnBeforePrint,
70 eiOnAfterPrint,
71 eiOnStop,
72 eiOnBeforeEditFocus,
73 eiOnlayoutcomplete,
74 eiOnpage,
75 eiOnmousewheel,
76 eiOnbeforedeactivate,
77 eiOnmove,
78 eiOncontrolselect,
79 eiOnSelectionChange,
80 eiOnmoveStart,
81 eiOnmoveEnd,
82 eiOnresizeStart,
83 eiOnresizeEnd,
84 eiOnmouseEnter,
85 eiOnmouseLeave,
86 eiOnActivate,
87 eiOnDeactivate,
88 eiOnBeforeActivate,
89 eiOnfocusIn,
90 eiOnfocusOut,
91 eiOnClick,
92 eiOnDblClick,
93 eiOnKeyDown,
94 eiOnKeyPress,
95 eiOnKeyUp,
96 eiOnMouseDown,
97 eiOnMouseMove,
98 eiOnMouseUp,
99 eiOnReadyStateChange,
100 eiOnCellChange,
101 eiOnRowsInserted,
102 eiOnRowsDelete,
103 eiOnBeforePaste,
104 eiOnBeforeCopy,
105 eiOnBeforeCut,
106 eiOnPaste,
107 eiOnCopy,
108 eiOnCut,
109 eiOnDrop,
110 eiOnDragLeave,
111 eiOnDragOver,
112 eiOnDragEnter,
113 eiOnDragEnd,
114 eiOnDrag,
115 eiOnPropertyChange,
116 eiOnLoseCapture,
117 eiOnFilterChange,
118 eiOnDatasetComplete,
119 eiOnDataAvailable,
120 eiOnDatasetChanged,
121 eiOnErrorUpdate,
122 eiOnSelectStart,
123 eiOnDragStart,
124 eiOnHelp,
125 eiOnMouseOut,
126 eiOnMouseOver,
127 eiOnRowEnter,
128 eiOnRowExit,
129 eiOnAfterUpdate,
130 eiOnBeforeUpdate,
131 eiOnFocus,
132 eiOnBlur
133 );
134
135 TMSHTMLDelegate = procedure(Sender: TObject; Event: IHTMLEventObj) of object;
136
137 TEventHandlerItem = class(TCollectionItem)
138 private
139 FEventID: TEventEnum;
140 FEvID: TEventID;
141 FOnHandle: TMSHTMLDelegate;
142 procedure setEventID(const Value: TEventEnum);
143 protected
144 procedure AssignTo(Dest: TPersistent); override;
145 function GetDisplayName: string; override;
146 public
147 function GetNamePath: string; override;
148 published
149 property EventID: TEventEnum read FEventID write setEventID;
150 property OnHandle: TMSHTMLDelegate read FOnHandle write FOnHandle;
151 end;
152
153 THandlerCollection = class(TCollection)
154 private
155 FOwner: THtmlListener;
156 function GetItem(Index: Integer): TEventHandlerItem;
157 protected
158 function GetOwner: TPersistent; override;
159 procedure Update(Item: TCollectionItem); override;
160 public
161 constructor Create(AOwner: THtmlListener);
162 function Add: TEventHandlerItem;
163 property Items[Index: Integer]: TEventHandlerItem read GetItem; default;
164 end;
165
166 THtmlListenerLink = class;
167
168 THtmlListener = class(TComponent, IDispatch)
169 private
170 FHandlers: THandlerCollection;
171 FDispList: TList;
172 FSinkKind: TSinkKind;
173 FSinkIID: PGUID;
174 Flink: THtmlListenerLink;
175 procedure setHandlers(const Value: THandlerCollection);
176 procedure setSinkKind(const Value: TSinkKind);
177 protected
178 { IInterface }
179 function QueryInterface(const IID: TGUID; out Obj): HRESULT; override;
180 stdcall;
181 { IDispatch }
182 function GetIDsOfNames(const IID: TGUID; Names: Pointer;
183 NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT; stdcall;
184 function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HRESULT;
185 stdcall;
186 function GetTypeInfoCount(out Count: Integer): HRESULT; stdcall;
187 function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
188 Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HRESULT;
189 stdcall;
190 protected
191 procedure FillDispList;
192 procedure Update(Item: TEventHandlerItem);
193 procedure AddDisp(Item: TEventHandlerItem);
194 function Find(DispID: TEventID; var Index: Integer): Boolean;
195 procedure DispatchEvent(Sender: TObject; DispID: TEventID; Event:
196 IHTMLEventObj);
197 public
198 constructor Create(AOwner: TComponent); override;
199 destructor Destroy; override;
200 procedure Connect(Source: IUnknown); overload;
201 function Connect2(Source: IUnknown; aAgent: TObject = nil): IHubLink;
202 published
203 property Handlers: THandlerCollection read fHandlers write setHandlers;
204 property SinkKind: TSinkKind read FSinkKind write setSinkKind default
205 skElement;
206 end;
207
208 THtmlListenerLink = class(TInterfacedDispatchObject, IHubLink)
209 private
210 FHub: THtmlListener;
211 FCP: IConnectionPoint;
212 FAgent: TObject;
213 FSinkCookies: Integer;
214 protected
215 function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
216 Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HRESULT;
217 override; stdcall;
218 procedure Connect(Source: IUnknown);
219 public
220 constructor Create(aHub: THtmlListener; aAgent: TObject);
221 procedure Disconnect;
222 end;
223
224implementation
225
226uses
227 SysUtils, EwbCoreTools;
228
229const
230 _eventids: array[TEventEnum] of TEventID = (
231 TEventID(0),
232 heOnAbort,
233 heOnChange,
234 heOnError,
235 heOnLoad,
236 heOnSelect,
237 heOnSubmit,
238 heOnUnload,
239 heOnBounce,
240 heOnFinish,
241 heOnStart,
242 heOnScroll,
243 heOnReset,
244 heOnresize,
245 heOnBeforeUnload,
246 heOncontextmenu,
247 heOnBeforePrint,
248 heOnAfterPrint,
249 heOnStop,
250 heOnBeforeEditFocus,
251 heOnlayoutcomplete,
252 heOnpage,
253 heOnmousewheel,
254 heOnbeforedeactivate,
255 heOnmove,
256 heOncontrolselect,
257 heOnSelectionChange,
258 heOnmoveStart,
259 heOnmoveEnd,
260 heOnresizeStart,
261 heOnresizeEnd,
262 heOnmouseEnter,
263 heOnmouseLeave,
264 heOnActivate,
265 heOnDeactivate,
266 heOnBeforeActivate,
267 heOnfocusIn,
268 heOnfocusOut,
269
270 heOnClick,
271 heOnDblClick,
272 heOnKeyDown,
273 heOnKeyPress,
274 heOnKeyUp,
275 heOnMouseDown,
276 heOnMouseMove,
277 heOnMouseUp,
278 heOnReadyStateChange,
279
280 heOnCellChange,
281 heOnRowsInserted,
282 heOnRowsDelete,
283 heOnBeforePaste,
284 heOnBeforeCopy,
285 heOnBeforeCut,
286 heOnPaste,
287 heOnCopy,
288 heOnCut,
289 heOnDrop,
290 heOnDragLeave,
291 heOnDragOver,
292 heOnDragEnter,
293 heOnDragEnd,
294 heOnDrag,
295 heOnPropertyChange,
296 heOnLoseCapture,
297 heOnFilterChange,
298 heOnDatasetComplete,
299 heOnDataAvailable,
300 heOnDatasetChanged,
301 heOnErrorUpdate,
302 heOnSelectStart,
303 heOnDragStart,
304 heOnHelp,
305 heOnMouseOut,
306 heOnMouseOver,
307 heOnRowEnter,
308 heOnRowExit,
309 heOnAfterUpdate,
310 heOnBeforeUpdate,
311 heOnFocus,
312 heOnBlur
313 );
314
315 _eventNames: array[TEventEnum] of string = (
316 '',
317 'OnAbort',
318 'OnChange',
319 'OnError',
320 'OnLoad',
321 'OnSelect',
322 'OnSubmit',
323 'OnUnload',
324 'OnBounce',
325 'OnFinish',
326 'OnStart',
327 'OnScroll',
328 'OnReset',
329 'Onresize',
330 'OnBeforeUnload',
331 'Oncontextmenu',
332 'OnBeforePrint',
333 'OnAfterPrint',
334 'OnStop',
335 'OnBeforeEditFocus',
336 'Onlayoutcomplete',
337 'Onpage',
338 'Onmousewheel',
339 'Onbeforedeactivate',
340 'Onmove',
341 'Oncontrolselect',
342 'OnSelectionChange',
343 'OnmoveStart',
344 'OnmoveEnd',
345 'OnresizeStart',
346 'OnresizeEnd',
347 'OnmouseEnter',
348 'OnmouseLeave',
349 'OnActivate',
350 'OnDeactivate',
351 'OnBeforeActivate',
352 'OnfocusIn',
353 'OnfocusOut',
354
355 'OnClick',
356 'OnDblClick',
357 'OnKeyDown',
358 'OnKeyPress',
359 'OnKeyUp',
360 'OnMouseDown',
361 'OnMouseMove',
362 'OnMouseUp',
363 'OnReadyStateChange',
364
365 'OnCellChange',
366 'OnRowsInserted',
367 'OnRowsDelete',
368 'OnBeforePaste',
369 'OnBeforeCopy',
370 'OnBeforeCut',
371 'OnPaste',
372 'OnCopy',
373 'OnCut',
374 'OnDrop',
375 'OnDragLeave',
376 'OnDragOver',
377 'OnDragEnter',
378 'OnDragEnd',
379 'OnDrag',
380 'OnPropertyChange',
381 'OnLoseCapture',
382 'OnFilterChange',
383 'OnDatasetComplete',
384 'OnDataAvailable',
385 'OnDatasetChanged',
386 'OnErrorUpdate',
387 'OnSelectStart',
388 'OnDragStart',
389 'OnHelp',
390 'OnMouseOut',
391 'OnMouseOver',
392 'OnRowEnter',
393 'OnRowExit',
394 'OnAfterUpdate',
395 'OnBeforeUpdate',
396 'OnFocus',
397 'OnBlur'
398 );
399
400 { TEventHandlerItem }
401
402procedure TEventHandlerItem.AssignTo(Dest: TPersistent);
403begin
404 if Dest is TEventHandlerItem then
405 with TEventHandlerItem(Dest) do
406 begin
407 EventID := Self.EventID;
408 OnHandle := Self.OnHandle;
409 end
410 else
411 inherited AssignTo(Dest);
412end;
413
414function TEventHandlerItem.GetDisplayName: string;
415begin
416 if FEventID = eiUnknown then
417 Result := inherited GetDisplayName
418 else
419 Result := _eventNames[FEventID];
420end;
421
422function TEventHandlerItem.GetNamePath: string;
423begin
424 if Collection <> nil then
425 Result := Collection.GetNamePath + GetDisplayName
426 else
427 Result := ClassName;
428end;
429
430procedure TEventHandlerItem.setEventID(const Value: TEventEnum);
431begin
432 if FEventID <> Value then
433 begin
434 FEventID := Value;
435 FEvID := _eventids[FEventID];
436 try
437 Changed(False);
438 except
439 FEventID := eiUnknown;
440 FEvID := 0;
441 raise;
442 end;
443 end;
444end;
445
446{ THandlerCollection }
447
448function THandlerCollection.Add: TEventHandlerItem;
449begin
450 Result := TEventHandlerItem(inherited Add);
451end;
452
453constructor THandlerCollection.Create(AOwner: THtmlListener);
454begin
455 inherited Create(TEventHandlerItem);
456 FOwner := AOwner;
457end;
458
459function THandlerCollection.GetItem(Index: Integer): TEventHandlerItem;
460begin
461 Result := TEventHandlerItem(inherited GetItem(Index));
462end;
463
464function THandlerCollection.GetOwner: TPersistent;
465begin
466 Result := FOwner;
467end;
468
469procedure THandlerCollection.Update(Item: TCollectionItem);
470begin
471 FOwner.Update(TEventHandlerItem(Item));
472end;
473
474{ THtmlListener }
475
476constructor THtmlListener.Create(AOwner: TComponent);
477begin
478 inherited;
479 FHandlers := THandlerCollection.Create(Self);
480 FSinkKind := skElement;
481 FSinkIID := @DIID_HTMLElementEvents2;
482end;
483
484destructor THtmlListener.Destroy;
485begin
486 FHandlers.Free;
487 FDispList.Free;
488 inherited;
489end;
490
491procedure THtmlListener.Connect(Source: IUnknown);
492var
493 pcpc: IConnectionPointContainer;
494 cp: IConnectionPoint;
495 c: Integer;
496{$IFDEF DELPHI5}
497 SelfIntf: IDispatch;
498{$ENDIF DELPHI5}
499begin
500 if Supports(Source, IConnectionPointContainer, pcpc) and
501 (pcpc.FindConnectionPoint(FSinkIID^, cp) = S_OK) then
502 begin
503{$IFDEF DELPHI5}
504 GetInterFace(IDispatch, SelfIntf);
505 if cp.Advise(SelfIntf, c) <> S_OK then
506{$ELSE}
507 if cp.Advise(Self, c) <> S_OK then
508{$ENDIF}
509 raise Exception.Create('Error on IConnectionPoint.Advise');
510 end
511 else
512{$IFDEF DELPHI6_UP}
513 raise Exception.CreateFmt('Source don''t have connection point for [%s]',
514 [GUIDToString(FSinkIID^)]);
515{$ENDIF}
516end;
517
518
519function THtmlListener.Connect2(Source: IUnknown;
520 aAgent: TObject = nil): IHubLink;
521begin
522 Flink := THtmlListenerLink.Create(Self, aAgent);
523 Flink.Connect(Source);
524 Result := Flink as IHubLink;
525end;
526
527procedure THtmlListener.setHandlers(const Value: THandlerCollection);
528begin
529 FHandlers.Assign(Value);
530end;
531
532procedure THtmlListener.setSinkKind(const Value: TSinkKind);
533begin
534 FSinkKind := Value;
535 FSinkIID := mshtmlEventGUIDs[Value];
536end;
537
538procedure THtmlListener.Update(Item: TEventHandlerItem);
539begin
540 if csDestroying in ComponentState then
541 Exit;
542 if FDispList = nil then
543 FDispList := TList.Create;
544 if Item = nil then
545 FillDispList
546 else
547 begin
548 FDispList.Remove(Item);
549 if Item.EventID <> eiUnknown then
550 AddDisp(Item);
551 end;
552end;
553
554procedure THtmlListener.AddDisp(Item: TEventHandlerItem);
555var
556 I: Integer;
557begin
558 if Find(Item.fEvID, I) then
559 raise Exception.CreateFmt('Handler with EventID = %s already exists.',
560 [_eventNames[Item.EventID]]);
561 FDispList.Insert(I, Item);
562end;
563
564procedure THtmlListener.FillDispList;
565var
566 I: Integer;
567begin
568 FDispList.Clear;
569 FDispList.Capacity := FHandlers.Count;
570 for I := 0 to FHandlers.Count - 1 do
571 if FHandlers[I].EventID <> eiUnknown then
572 AddDisp(FHandlers[I]);
573end;
574
575function THtmlListener.Find(DispID: TEventID; var Index: Integer): Boolean;
576var
577 L, H, I: Integer;
578begin
579 Result := False;
580 if FDispList = nil then
581 Exit;
582
583 L := 0;
584 H := FDispList.Count - 1;
585 while L <= H do
586 begin
587 I := (L + H) shr 1;
588 if TEventHandlerItem(FDispList[I]).FEvID < DispID then
589 L := I + 1
590 else
591 begin
592 H := I - 1;
593 if TEventHandlerItem(FDispList[I]).FEvID = DispID then
594 begin
595 Result := True;
596 Index := I;
597 Exit;
598 end;
599 end;
600 end;
601 Index := L;
602end;
603
604procedure THtmlListener.DispatchEvent(Sender: TObject; DispID: TEventID;
605 Event: IHTMLEventObj);
606var
607 I: Integer;
608begin
609 if Find(DispID, I) then
610 with TEventHandlerItem(FDispList[I]) do
611 if Assigned(OnHandle) then
612 OnHandle(Sender, Event);
613end;
614
615function THtmlListener.QueryInterface(const IID: TGUID; out Obj): HRESULT;
616{$IFDEF DELPHI5}
617var
618 SelfIntf: IDispatch;
619{$ENDIF}
620begin
621 Result := S_OK;
622 if GetInterface(IID, Obj) then
623 Exit;
624 if IsEqualGuid(IID, fSinkIID^) then
625{$IFDEF DELPHI5}
626 begin
627 GetInterface(IDispatch, SelfIntf);
628 IUnknown(Obj) := SelfIntf;
629 end
630{$ELSE}
631 IUnknown(Obj) := Self as IDispatch
632{$ENDIF}
633 else
634 Result := E_NOINTERFACE;
635end;
636
637function THtmlListener.GetIDsOfNames(const IID: TGUID; Names: Pointer;
638 NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT;
639begin
640 Result := E_NOTIMPL;
641end;
642
643function THtmlListener.GetTypeInfo(Index, LocaleID: Integer;
644 out TypeInfo): HRESULT;
645begin
646 Result := DISP_E_BADINDEX;
647end;
648
649function THtmlListener.GetTypeInfoCount(out Count: Integer): HRESULT;
650begin
651 Count := 0;
652 Result := S_OK;
653end;
654
655function THtmlListener.Invoke(DispID: Integer; const IID: TGUID;
656 LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
657 ArgErr: Pointer): HRESULT;
658var
659 Event: IHTMLEventObj;
660begin
661 Result := S_OK;
662 try
663 if Flags and DISPATCH_METHOD <> 0 then
664 begin
665 if (TDispParams(Params).cArgs = 0) or
666 not VarSupports(POleVariant(TDispParams(Params).rgvarg)^, IHTMLEventObj,
667 Event) then
668 Event := nil;
669 DispatchEvent(Self, TEventID(DispID), Event);
670 // if VarResult<>nil then
671 // POleVariant(VarResult)^ := False;
672 end;
673 except
674 on E: Exception do
675 begin
676 Result := DISP_E_EXCEPTION;
677 with PExcepInfo(ExcepInfo)^ do
678 begin
679 wCode := 9999;
680 bstrDescription := E.Message;
681 bstrSource := E.ClassName;
682 dwHelpContext := E.HelpContext;
683 end;
684 end;
685 end;
686end;
687
688
689{ THtmlListenerLink }
690
691constructor THtmlListenerLink.Create(aHub: THtmlListener; aAgent: TObject);
692begin
693 inherited Create;
694 FHub := aHub;
695 FAgent := aAgent;
696end;
697
698procedure THtmlListenerLink.Disconnect;
699begin
700 if FCP <> nil then
701 try
702 FCP.Unadvise(FSinkCookies);
703 finally
704 FCP := nil;
705 end;
706end;
707
708procedure THtmlListenerLink.Connect(Source: IUnknown);
709var
710 pcpc: IConnectionPointContainer;
711begin
712 if Supports(Source, IConnectionPointContainer, pcpc) and
713 (pcpc.FindConnectionPoint(fHub.fSinkIID^, FCP) = S_OK) then
714 begin
715 if FCP.Advise(Self, FSinkCookies) <> S_OK then
716 raise Exception.Create('Error on IConnectionPoint.Advise');
717 end
718 else
719{$IFDEF DELPHI6_UP}
720 raise Exception.CreateFmt('Source don''t have connection point for [%s]',
721 [GUIDToString(FHub.FSinkIID^)]);
722{$ENDIF}
723end;
724
725function THtmlListenerLink.Invoke(DispID: Integer; const IID: TGUID;
726 LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
727 ArgErr: Pointer): HRESULT;
728var
729 Event: IHTMLEventObj;
730begin
731 Result := S_OK;
732 try
733 if Flags and DISPATCH_METHOD <> 0 then
734 begin
735 if (TDispParams(Params).cArgs = 0) or
736 not VarSupports(POleVariant(TDispParams(Params).rgvarg)^, IHTMLEventObj,
737 Event) then
738 Event := nil;
739 FHub.DispatchEvent(FAgent, TEventID(DispID), Event);
740 end;
741 except
742 on E: Exception do
743 begin
744 Result := DISP_E_EXCEPTION;
745 with PExcepInfo(ExcepInfo)^ do
746 begin
747 wCode := 9999;
748 bstrDescription := E.Message;
749 bstrSource := E.ClassName;
750 dwHelpContext := E.HelpContext;
751 end;
752 end;
753 end;
754end;
755
756end.
Note: See TracBrowser for help on using the repository browser.