source: cprs/branches/tmg-cprs/CPRS-Chart/TMG_Extra/HTMLEdit/IEAddress.pas@ 697

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

TMG Ver 1.1 Added HTML Support, better demographics editing
File size: 57.6 KB
Line 
1{*******************************************************}
2{ IEAddress Component }
3{ STAGE 3 }
4{ For Delphi 5, 6, 7, 2005, 2006 }
5{ Freeware Component }
6{ }
7{ CONTRIBUTORS: }
8{ Eran Bodankin (bsalsa) bsalsa@gmail.com }
9{ Per Lindsø Larsen }
10{ Peter Morris (Pete@StuckIndoors.com) }
11{ Thomas Stutz (aka smot) }
12{ }
13{ Enjoy! }
14{ UPDATES: }
15{ http://www.bsalsa.com }
16{*******************************************************************************}
17{LICENSE:
18THIS SOFTWARE IS PROVIDED TO YOU "AS IS" WITHOUT WARRANTY OF ANY KIND,
19EITHER EXPRESSED OR IMPLIED INCLUDING BUT NOT LIMITED TO THE APPLIED
20WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
21YOU ASSUME THE ENTIRE RISK AS TO THE ACCURACY AND THE USE OF THE SOFTWARE
22AND ALL OTHER RISK ARISING OUT OF THE USE OR PERFORMANCE OF THIS SOFTWARE
23AND DOCUMENTATION. BSALSA PRODUCTIONS DOES NOT WARRANT THAT THE SOFTWARE IS ERROR-FREE
24OR WILL OPERATE WITHOUT INTERRUPTION. THE SOFTWARE IS NOT DESIGNED, INTENDED
25OR LICENSED FOR USE IN HAZARDOUS ENVIRONMENTS REQUIRING FAIL-SAFE CONTROLS,
26INCLUDING WITHOUT LIMITATION, THE DESIGN, CONSTRUCTION, MAINTENANCE OR
27OPERATION OF NUCLEAR FACILITIES, AIRCRAFT NAVIGATION OR COMMUNICATION SYSTEMS,
28AIR TRAFFIC CONTROL, AND LIFE SUPPORT OR WEAPONS SYSTEMS. BSALSA PRODUCTIONS SPECIFICALLY
29DISCLAIMS ANY EXPRESS OR IMPLIED WARRANTY OF FITNESS FOR SUCH PURPOSE.
30
31You may use, change or modify the component under 4 conditions:
321. In your website, add a link to "http://www.bsalsa.com"
332. In your application, add credits to "Embedded Web Browser"
343. Mail me (bsalsa@gmail.com) any code change in the unit
35 for the benefit of the other users.
364. Please consider donation in our web site!
37{*******************************************************************************}
38//$Id: IEAddress.pas,v 1.6 2006/12/07 11:27:31 bsalsa Exp $
39
40{ Remove the dot from the define below to enable support for TFlatComboBox.
41 (FlatStyle Components, All Components look like MS Money und MS Encarta)
42 http://www.torry.net/vcl/packs/interfacemiddle/flatstyl.zip}
43
44{.$DEFINE USE_TFlatComboBox}
45
46unit IEAddress;
47
48interface
49
50{$I EWB.inc}
51{$I EWB.inc}
52
53uses
54 ActiveX, ComCtrls, ShlObj, Windows, Messages, Classes, Controls, StdCtrls,
55 Graphics, EmbeddedWB, Dialogs{$IFDEF USE_TFlatComboBox}, TFlatComboBoxUnit{$ENDIF}; //By Smot
56
57type
58 IObjMgr = interface(IUnknown)
59 ['{00BB2761-6A77-11D0-A535-00C04FD7D062}']
60 function Append(punk: IUnknown): HResult; stdcall;
61 function Remove(punk: IUnknown): HResult; stdcall;
62 end;
63
64 IACList = interface(IUnknown)
65 ['{77A130B0-94FD-11D0-A544-00C04FD7d062}']
66 function Expand(pszExpand: POLESTR): HResult; stdcall;
67 end;
68
69 IACList2 = interface(IACList)
70 ['{470141a0-5186-11d2-bbb6-0060977b464c}']
71 function SetOptions(dwFlag: DWORD): HResult; stdcall;
72 function GetOptions(var pdwFlag: DWORD): HResult; stdcall;
73 end;
74 IAutoComplete = interface(IUnknown)
75 ['{00bb2762-6a77-11d0-a535-00c04fd7d062}']
76 function Init(hwndEdit: HWND; const punkACL: IUnknown; pwszRegKeyPath,
77 pwszQuickComplete: POLESTR): HResult; stdcall;
78 function Enable(fEnable: BOOL): HResult; stdcall;
79 end;
80type
81 IAutoComplete2 = interface(IAutoComplete)
82 ['{EAC04BC0-3791-11d2-BB95-0060977B464C}']
83 function SetOptions(dwFlag: DWORD): HResult; stdcall;
84 function GetOptions(out pdwFlag: DWORD): HResult; stdcall;
85 end;
86
87 TEnumString = class(TInterfacedObject, IEnumString)
88 private
89 FStrings: TStringList;
90 FCurrIndex: integer;
91 public
92 {IEnumString}
93 function Next(celt: Longint; out elt; pceltFetched: PLongint): HResult; stdcall;
94 function Skip(celt: Longint): HResult; stdcall;
95 function Reset: HResult; stdcall;
96 function Clone(out enm: IEnumString): HResult; stdcall;
97 {VCL}
98 constructor Create;
99 destructor Destroy; override;
100 end;
101
102 TAutoComplete2Option = (acoNone, acoAutoSuggest, acoAutoAppend, acoSearch, acoFilterPrefix,
103 acoUseTab, acoUpDownKeyDropList, acoRtlReading, acoWordFilter,
104 acoNoPrefixFiltering);
105 TAutoComplete2Options = set of TAutoComplete2Option;
106 TACSource = (acsList, acsHistory, acsMRU, acsShell);
107 TAutoComplete2Source = set of TACSource;
108 TAComp = (AutoComplete1, AutoComplete2);
109 TAutoCompleteOption = (acAutoSuggest, acAutoAppend, acFileSystem, acUrlHistory,
110 acUrlMRU, acUrlAll, acUseTab);
111 TAutoCompleteOptions = set of TAutoCompleteOption;
112 TIEAddressState = set of (csButtonPressed, csMouseCaptured);
113 TThemes = (tmNone, tmXP, tmSilver, tmSoil);
114 TGUI = (gsCombobox, gsThemes);
115 TTypedUrlsMethod = (tuCommon, tuExtended);
116 TTextAfterNav = (anLocationUrl, anLocationName);
117 TTextOnLoad = (tlIELastVisited, tlIEHomePage, tlBlank, tlUserDefine);
118 TOnUrlSelectedEvent = procedure(Sender: TObject; Url: WideString; var Cancel: boolean) of object;
119 TOnGetFaviconEvent = procedure(Sender: TObject; Favicon, SiteUrl: WideString; var Cancel: boolean; Icon: TIcon) of object;
120 TOnGetAppIconEvent = procedure(Sender: TObject; var Cancel: boolean; Icon: TIcon) of object;
121 TOnGetIconEvent = procedure(Sender: TObject; Ext: string; hIco: hIcon) of object;
122 TOnUpdateRegistryEvent = procedure(Sender: TObject; Url: WideString; var Cancel: boolean) of object;
123 TOnUpdateTextEvent = procedure(Sender: TObject; OldUrl, NewUrl: WideString; var Cancel: boolean) of object;
124 TOnPaintEvent = procedure(Sender: TObject; var Continue: boolean) of object;
125
126type
127{$IFDEF USE_TFlatComboBox} //By Smot
128 TComboBoxType = TFlatComboBox;
129{$ELSE}
130 TComboBoxType = TCustomComboBox;
131{$ENDIF}
132
133type
134 TCustomIEAddress = class(TComboBoxType)
135 private
136 dllVer: Extended;
137 FAbout: string;
138 FArrowColor: TColor;
139 FBorderColor: TColor;
140 FButtonColor: TColor;
141 FButtonPressedColor: TColor;
142 FButtonWidth: Integer;
143 FCanvas: TControlCanvas;
144 FCustomProperty: string;
145 FEditState: TIEAddressState;
146 FEmbeddedWB: TEmbeddedWB;
147 FFlat: Boolean;
148 FGUI: TGUI;
149 FHasBorder: Boolean;
150 FHasDropDown: Boolean;
151 FHintColor: TColor;
152 FIconLeft: Integer;
153 FIconTop: Integer;
154 FImageIndex: Integer;
155 FImageList: TImageList;
156 FImageSize: Integer;
157 FModified: Boolean;
158 FMouseActive: Boolean;
159 FNavOnDblClk: Boolean;
160 FNavOnEnterKey: Boolean;
161 FNavOnLoad: Boolean;
162 FNavOnSelected: Boolean;
163 FOldBGColor: TColor;
164 FOldHintColor: TColor;
165 FOnGetAppIcon: TOnGetAppIconEvent;
166 FOnGetFavicon: TOnGetFaviconEvent;
167 FOnGetIcon: TOnGetIconEvent;
168 FOnPaint: TOnPaintEvent;
169 FOnUpdateRegistry: TOnUpdateRegistryEvent;
170 FOnUpdateText: TOnUpdateTextEvent;
171 FOnUrlSelected: TOnUrlSelectedEvent;
172 FSecureSiteBG: TColor;
173 FSelImageIndex: Integer;
174 FShowFavicons: Boolean;
175 FShowSiteHint: Boolean;
176 FTextAfterNav: TTextAfterNav;
177 FTextOnLoad: TTextOnLoad;
178 FTextOnShow: WideString;
179 FThemes: TThemes;
180 FTypedUrlsMethod: TTypedUrlsMethod;
181 FUAfterNav: Boolean;
182 FUpdateRegistry: Boolean;
183 FUseAppIcon: Boolean;
184 FUseSecureSiteBGColor: Boolean;
185 FAutoComplete2Source: TAutoComplete2Source;
186 FAutoComplete: IAutoComplete;
187 FAutoCompleteOptions: TAutoCompleteOptions;
188 FAutoComplete2Options: TAutoComplete2Options;
189 FAComp: TAComp;
190 function AddFaviconToImageList: integer;
191 function GetImageIndex(aUrl: string; IntoLV: Boolean): Integer;
192 function GrabFavicon(URL: string; dest: string): Boolean;
193 function RemovePrefix(UrlIn, Prefix: WideString): WideString;
194 function FixUrl(Url: string): string;
195 function GetModified: Boolean;
196 procedure SetModified(Value: Boolean);
197 procedure GetTypedURLs;
198 procedure InsertTextToList;
199 procedure RegistryUpdate;
200 procedure RepaintIEAddress(MouseActive: Boolean);
201 procedure SetAbout(Value: string);
202 procedure SetDropDown(const Value: Boolean);
203 procedure SetTextPosition;
204 procedure SetFlat(const Value: Boolean);
205 procedure SetHasBorder(const Value: Boolean);
206 procedure SetSiteHint;
207 procedure SetTextOnLd;
208 procedure SetTheme;
209 procedure SetAutoCompleteOptions(const Value: TAutoCompleteOptions);
210 procedure SetAutoComplete2Source(const Value: TAutoComplete2Source);
211 procedure SetACOptions(const Value: TAutoComplete2Options);
212 procedure TextUpdate;
213 procedure UpdateIAutoComplete2;
214 procedure UpdateAutoComplete;
215 protected
216 procedure CalculateRGN;
217 procedure Change; override;
218 procedure CheckButtonState(X, Y: Integer);
219 procedure Click; override;
220 procedure CreateParams(var Params: TCreateParams); override;
221 procedure CreateWindowHandle(const Params: TCreateParams); override;
222 procedure CreateWnd; override;
223 procedure DblClick; override;
224 procedure DestroyWnd; override;
225 procedure DrawIEAddress(MouseInControl, DroppedDown: boolean);
226 procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
227 procedure KeyDown(var Key: Word; Shift: TShiftState); override;
228 procedure Loaded; override;
229 procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
230 procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
231 procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
232 procedure WndProc(var Message: TMessage); override;
233 public
234 constructor Create(AOwner: TComponent); override;
235 destructor Destroy; override;
236 function IsValidURL(const URL: WideString): Boolean;
237 function GetDllVersion(const ADll: string): Extended;
238 procedure DragOver(Source: TObject; X, Y: Integer;
239 State: TDragState; var Accept: Boolean); override;
240 procedure DragDrop(Source: TObject; X, Y: Integer); override;
241 procedure CheckSecureSite;
242 procedure ClearList;
243 procedure AddToList;
244{$IFDEF DELPHI6_UP}
245 procedure DeleteSelected; override;
246{$ENDIF}
247 procedure LoadFromFile(FileName: WideString);
248 procedure SaveToFile(FileName: WideString);
249 procedure SetBounds(Left, Top, Width, Height: Integer); override;
250 {published}
251 property AutoCompleteVersion: TAComp read FAComp write FAComp default AutoComplete2;
252 property AutoComplete2Source: TAutoComplete2Source read FAutoComplete2Source
253 write SetAutoComplete2Source default [acsList, acsHistory, acsMRU, acsShell];
254 property AutoComplete2Options: TAutoComplete2Options read FAutoComplete2Options
255 write FAutoComplete2Options default [acoAutoSuggest, acoAutoAppend, acoSearch];
256 property AutoCompleteOptions: TAutoCompleteOptions read FAutoCompleteOptions
257 write SetAutoCompleteOptions default [acAutoAppend, acUrlHistory];
258 property About: string read FAbout write SetAbout;
259 property ArrowColor: Tcolor read FArrowColor write FArrowColor default clblack;
260 property AutoNavigateOnDblClk: Boolean read FNavOnDblClk write FNavOnDblClk default True;
261 property AutoNavigateOnEnterKey: Boolean read FNavOnEnterKey write FNavOnEnterKey default True;
262 property AutoNavigateOnLoad: Boolean read FNavOnLoad write FNavOnLoad default True;
263 property AutoNavigateOnSelected: Boolean read FNavOnSelected write FNavOnSelected default True;
264 property BorderColor: Tcolor read FBorderColor write FBorderColor default clblack;
265 property ButtonColor: Tcolor read FButtonColor write FButtonColor default clBtnFace;
266 property ButtonPressedColor: Tcolor read FButtonPressedColor write FButtonPressedColor default clBtnFace;
267 property ButtonWidth: integer read FButtonWidth;
268 property DropDownCount;
269 property EmbeddedWB: TEmbeddedWB read FEmbeddedWB write FEmbeddedWB;
270 property Flat: Boolean read FFlat write SetFlat default False;
271 property GUI: TGUI read FGUI write FGUI default gsThemes;
272 property HasBorder: Boolean read FHasBorder write SetHasBorder default True;
273 property HasDropDown: Boolean read FHasDropDown write SetDropDown default True;
274 property HintColor: Tcolor read FHintColor write FHintColor default clInfoBK;
275 property IconLeft: Integer read FIconLeft write FIconLeft;
276 property IconTop: Integer read FIconTop write FIconTop;
277 property Modified: Boolean read GetModified write SetModified;
278 property OnGetAppIcon: TOnGetAppIconEvent read FOnGetAppIcon write FOnGetAppIcon;
279 property OnGetFavicon: TOnGetFaviconEvent read FOnGetFavicon write FOnGetFavicon;
280 property OnGetIcon: TOnGetIconEvent read FOnGetIcon write FOnGetIcon;
281 property OnUpdateRegistry: TOnUpdateRegistryEvent read FOnUpdateRegistry write FOnUpdateRegistry;
282 property OnUpdateText: TOnUpdateTextEvent read FOnUpdateText write FOnUpdateText;
283 property OnUrlSelected: TOnUrlSelectedEvent read FOnUrlSelected write FOnUrlSelected;
284 property SecureSiteBG: TColor read FSecureSiteBG write FSecureSiteBG default clInfobk;
285 property ShowFavicon: Boolean read FShowFavicons write FShowFavicons default False;
286 property ShowSiteToolTip: Boolean read FShowSiteHint write FShowSiteHint default True;
287 property TextAfterNav: TTextAfterNav read FTextAfterNav write FTextAfterNav default anLocationUrl;
288 property TextOnLoad: TTextOnLoad read FTextOnLoad write FTextOnLoad default tlIEHomepage;
289 property TextOnShow: WideString read FTextOnShow write FTextOnShow;
290 property Themes: TThemes read FThemes write FThemes default tmNone;
291 property UpdateItemsToRegistry: Boolean read FUpdateRegistry write FUpdateRegistry default True;
292 property UpdateTextAfterNav: Boolean read FUAfterNav write FUAfterNav default True;
293 property UseAppIcon: Boolean read FUseAppIcon write FUseAppIcon default False;
294 property UseSecureSiteBGColor: Boolean read FUseSecureSiteBGColor write FUseSecureSiteBGColor default True;
295 end;
296
297 TIEAddress = class(TCustomIEAddress)
298 published
299 property Style; //Apparently this must be published first (see VCL);
300 //New stuff-----------------------------------------------------------------
301 property AutoComplete2Source default [acsList, acsHistory, acsMRU, acsShell];
302 property AutoComplete2Options default [acoAutoSuggest, acoAutoAppend, acoSearch];
303 property AutoCompleteOptions default [acAutoAppend, acUrlHistory];
304 property AutoNavigateOnDblClk default True;
305 property AutoNavigateOnEnterKey default True;
306 property AutoNavigateOnLoad default True;
307 property AutoNavigateOnSelected default True;
308 property AutoCompleteVersion default AutoComplete2;
309 property About;
310 property Align;
311 property Anchors;
312 property ArrowColor;
313 property BiDiMode;
314 property BorderColor;
315 property ButtonColor;
316 property ButtonPressedColor;
317 property Color;
318 property Constraints;
319 property Cursor;
320 property DragCursor;
321 property DragKind;
322 property DragMode;
323 property DropDownCount;
324 property EmbeddedWB;
325 property Enabled;
326 property Flat;
327 property Font;
328 property GUI;
329 property HasBorder;
330 property HasDropDown;
331 property HelpContext;
332 property Hint;
333 property HintColor;
334 property IconLeft;
335 property IconTop;
336 property ImeMode;
337 property ImeName;
338 property ItemHeight;
339 property MaxLength;
340 property OnChange;
341 property OnClick;
342 property OnContextPopup;
343 property OnDblClick;
344 property OnDragDrop;
345 property OnDragOver;
346 property OnDrawItem;
347 property OnDropDown;
348 property OnEndDock;
349 property OnEndDrag;
350 property OnEnter;
351 property OnExit;
352 property OnGetAppIcon;
353 property OnGetFavicon;
354 property OnGetIcon;
355 property OnKeyDown;
356 property OnKeyPress;
357 property OnKeyUp;
358 property OnMeasureItem;
359 property OnStartDock;
360 property OnStartDrag;
361 property OnUpdateRegistry;
362 property OnUpdateText;
363 property OnUrlSelected;
364 property ParentBiDiMode default False;
365 property ParentColor;
366 property ParentFont;
367 property ParentShowHint default False;
368 property PopupMenu;
369 property SecureSiteBG;
370 property ShowFavicon;
371 property ShowHint default True;
372 property ShowSiteToolTip;
373 property Sorted;
374 property TabOrder;
375 property TabStop;
376 property Text;
377 property TextAfterNav;
378 property TextOnLoad;
379 property TextOnShow;
380 property Themes;
381 property UpdateTextAfterNav default True;
382 property UseAppIcon;
383 property UseSecureSiteBGColor;
384 property Visible;
385 property Items; //And this must be published last
386 end;
387
388implementation
389
390uses
391 ComObj, UrlMon, ImgList, ShellAPI, Forms, SysUtils, Registry, IEConst, EwbCoreTools;
392
393function TEnumString.Clone(out enm: IEnumString): HResult;
394begin
395 Result := E_NOTIMPL;
396 pointer(enm) := nil;
397end;
398
399constructor TEnumString.Create;
400begin
401 inherited Create;
402 FStrings := TStringList.Create;
403 FCurrIndex := 0;
404end;
405
406destructor TEnumString.Destroy;
407begin
408 FStrings.Free;
409 inherited;
410end;
411
412function TEnumString.Next(celt: Integer; out elt; pceltFetched: PLongint): HResult;
413var
414 I: Integer;
415 wStr: WideString;
416begin
417 I := 0;
418 while (I < celt) and (FCurrIndex < FStrings.Count) do
419 begin
420 wStr := FStrings[FCurrIndex];
421 TPointerList(elt)[I] := PWideChar(WideString(wStr));
422 /// TPointerList(elt)[I] := CoTaskMemAlloc(2 * (Length(wStr) + 1));
423 StringToWideChar(wStr, TPointerList(elt)[I], 2 * (Length(wStr) + 1));
424 Inc(I);
425 Inc(FCurrIndex);
426 end;
427 if pceltFetched <> nil then
428 pceltFetched^ := I;
429 if I = celt then
430 Result := S_OK
431 else
432 Result := S_FALSE;
433end;
434
435function TEnumString.Reset: HResult;
436begin
437 FCurrIndex := 0;
438 Result := S_OK;
439end;
440
441function TEnumString.Skip(celt: Integer): HResult;
442begin
443 if (FCurrIndex + celt) <= FStrings.Count then
444 begin
445 Inc(FCurrIndex, celt);
446 Result := S_OK;
447 end
448 else
449 begin
450 FCurrIndex := FStrings.Count;
451 Result := S_FALSE;
452 end;
453end;
454
455//Accesories--------------------------------------------------------------------
456
457function SHAutoComplete(hwndEdit: HWND; dwFlags: DWORD): HRESULT; stdcall; external 'shlwapi.dll';
458{$R-}
459
460function GetExtension(Url: WideString): string;
461var
462 st: string;
463begin
464 st := LowerCase(Trim(ExtractFileExt(Url)));
465 if (AnsiPos('.xml', st) <> 0) or (AnsiPos('.txt', st) <> 0) or (AnsiPos('.doc', st) <> 0)
466 or (AnsiPos('.bmp', st) <> 0) or (AnsiPos('.zip', st) <> 0) or (AnsiPos('.rar', st) <> 0)
467 or (AnsiPos('.jpg', st) <> 0) or (AnsiPos('.gif', st) <> 0) or (AnsiPos('.jpeg', st) <> 0) then
468 Result := st
469 else
470 Result := '*.htm';
471end;
472
473function GetCacheFolder: WideString;
474var
475 Reg: TRegistry;
476begin
477 Result := '';
478 Reg := TRegistry.Create;
479 with Reg do
480 try
481 begin
482 RootKey := HKEY_CURRENT_USER;
483 if OpenKey('Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', False) then
484 Result := ReadString('Cache') + '\';
485 end;
486 finally
487 CloseKey;
488 Free;
489 end;
490end;
491
492function StrToCase(StringOf: string; CasesList: array of string): Integer;
493var
494 Idx: integer;
495begin
496 Result := -1;
497 for Idx := 0 to Length(CasesList) - 1 do
498 begin
499 if CompareText(StringOf, CasesList[Idx]) = 0 then
500 begin
501 Result := Idx;
502 Break;
503 end;
504 end;
505end;
506
507function GetSpecialFolderNo(bUrl: WideString): Cardinal;
508var
509 Url: string;
510begin
511 Result := 3000;
512 Url := AnsiUpperCase(Trim(bUrl));
513 case StrToCase(Url, ['DESKTOP', 'INTERNET', 'PROGRAMS', 'CONTROL PANEL', 'PRINTERS',
514 'MY DOCUMENTS', 'FAVORITES', 'STARTUP', 'RECENT', 'SENDTO',
515 'RECYCLE BIN', 'STARTMENU', 'DESKTOP DIRECTORY', 'MY COMPUTER',
516 'NETWORK NEIGHBORHOOD', 'NETHOOD', 'FONTS', 'TEMPLATES', 'START MENU',
517 'COMMON PROGRAMS', 'COMMON STARTUP', 'COMMON DESKTOP', 'APPDATA',
518 'PRINTHOOD', 'APPLICATION DATA', 'TEMPORARY INTERNET FILES',
519 'COOKIES', 'HISTORY', 'USERPROFILE', 'DIAL UP CONNECTIONS',
520 'MY MUSIC', 'MY PICTURES', 'MY VIDEO', 'CD BURNING',
521 'COMPUTERS NEAR ME', 'PROFILES']) of
522 0: Result := CSIDL_DESKTOP;
523 1: Result := CSIDL_INTERNET;
524 2: Result := CSIDL_PROGRAMS;
525 3: Result := CSIDL_CONTROLS;
526 4: Result := CSIDL_PRINTERS;
527 5: Result := CSIDL_PERSONAL;
528 6: Result := CSIDL_FAVORITES;
529 7: Result := CSIDL_STARTUP;
530 8: Result := CSIDL_RECENT;
531 9: Result := CSIDL_SENDTO;
532 10: Result := CSIDL_BITBUCKET;
533 11: Result := CSIDL_STARTMENU;
534 12: Result := CSIDL_DESKTOPDIRECTORY;
535 13: Result := CSIDL_DRIVES;
536 14: Result := CSIDL_NETWORK;
537 15: Result := CSIDL_NETHOOD;
538 16: Result := CSIDL_FONTS;
539 17: Result := CSIDL_TEMPLATES;
540 18: Result := CSIDL_COMMON_STARTMENU;
541 19: Result := CSIDL_COMMON_PROGRAMS;
542 20: Result := CSIDL_COMMON_STARTUP;
543 21: Result := CSIDL_COMMON_DESKTOPDIRECTORY;
544 22: Result := CSIDL_APPDATA;
545 23: Result := CSIDL_PRINTHOOD;
546{$IFDEF DELPHI9_UP}
547 24: Result := CSIDL_LOCAL_APPDATA;
548 25: Result := CSIDL_INTERNET_CACHE;
549 26: Result := CSIDL_COOKIES;
550 27: Result := CSIDL_HISTORY;
551 28: Result := CSIDL_PROFILE;
552 29: Result := CSIDL_CONNECTIONS;
553 30: Result := CSIDL_COMMON_MUSIC;
554 31: Result := CSIDL_COMMON_PICTURES;
555 32: Result := CSIDL_COMMON_VIDEO;
556 33: Result := CSIDL_CDBURN_AREA;
557 34: Result := CSIDL_COMPUTERSNEARME;
558 35: Result := CSIDL_PROFILES
559{$ENDIF}
560 end;
561end;
562
563function TCustomIEAddress.GetDllVersion(const ADll: string): Extended;
564type //by Fabio Lucarelli
565 DLLVERSIONINFO = packed record
566 cbSize: DWORD;
567 dwMajorVersion: DWORD;
568 dwMinorVersion: DWORD;
569 dwBuildNumber: DWORD;
570 dwPlatformID: DWORD;
571 end;
572 DLLGETVERSIONPROC = function(var pdvi: DLLVERSIONINFO): HRESULT; stdcall;
573var
574 hinstDll: THANDLE;
575 pBuffer: POINTER;
576 dvi: DLLVERSIONINFO;
577 pDllGetVersion: DLLGETVERSIONPROC;
578begin
579 hinstDll := LoadLibrary(PChar(ADll));
580 if hinstDll = 0 then
581 Result := 0
582 else
583 try
584 pBuffer := GetProcAddress(hinstDll, 'DllGetVersion');
585 if Assigned(pBuffer) then
586 begin
587 ZeroMemory(@dvi, SizeOf(dvi));
588 dvi.cbSize := SizeOf(dvi);
589 pDllGetVersion := DLLGETVERSIONPROC(pBuffer);
590 if pDllGetVersion(dvi) = NOERROR then
591 begin
592 Result := (dvi.dwMajorVersion + dvi.dwMinorVersion);
593 end
594 else
595 Result := 0;
596 end
597 else
598 Result := 0;
599 finally
600 FreeLibrary(hinstDll);
601 end;
602end;
603
604function TCustomIEAddress.GetModified: Boolean;
605begin
606 Result := FModified;
607 if HandleAllocated then
608 Result := SendMessage(EditHandle, EM_GETMODIFY, 0, 0) <> 0;
609end;
610
611function TCustomIEAddress.IsValidURL(const URL: WideString): Boolean;
612begin
613 if UrlMon.IsValidURL(nil, PWideChar(URL), 0) = S_OK then
614 Result := True
615 else
616 Result := False;
617end;
618
619function TCustomIEAddress.RemovePrefix(UrlIn, Prefix: WideString): WideString;
620var
621 i, j: integer;
622begin
623 i := Length(Prefix);
624 j := AnsiPos(Prefix, UPPERCASE(URLIn));
625 if j <> 0 then
626 System.delete(UrlIn, j, i);
627 Result := UrlIn;
628end;
629
630procedure TCustomIEAddress.ClearList;
631begin
632 Items.Clear;
633end;
634
635{$IFDEF DELPHI6_UP}
636
637procedure TCustomIEAddress.DeleteSelected;
638begin
639 if ItemIndex <> -1 then
640 Items.Delete(ItemIndex);
641end;
642{$ENDIF}
643
644procedure TCustomIEAddress.AddToList;
645begin
646 if not (csDesigning in ComponentState) then
647 begin
648 Text := FixUrl(Text);
649 RegistryUpdate;
650 CheckSecureSite;
651 TextUpdate;
652 InsertTextToList;
653 SetSiteHint;
654 AddFaviconToImageList;
655 end;
656end;
657
658procedure TCustomIEAddress.CheckButtonState(X, Y: Integer);
659var
660 ARect: TRect;
661begin
662 SetRect(ARect, ClientWidth - FButtonWidth, 0, ClientWidth, ClientHeight);
663 if (csButtonPressed in FEditState) and not PtInRect(ARect, Point(X, Y)) then
664 begin
665 Exclude(FEditState, csButtonPressed);
666 RepaintIEAddress(True);
667 end;
668end;
669
670function TCustomIEAddress.FixUrl(Url: string): string;
671
672
673 function AnsiEndsStr(const ASubText, AText: string): Boolean;
674 var
675 SubTextLocation: Integer;
676 begin
677 SubTextLocation := Length(AText) - Length(ASubText) + 1;
678 if (SubTextLocation > 0) and (ASubText <> '') and
679 (ByteType(AText, SubTextLocation) <> mbTrailByte) then
680 Result := AnsiStrComp((PChar(ASubText)), Pointer(@AText[SubTextLocation])) = 0
681 else
682 Result := False;
683 end;
684
685var
686 DotPos, ipos: Integer;
687begin
688 Result := Url;
689 if not AnsiEndsStr('/', Url) then
690 begin
691 ipos := LastDelimiter('/', Url);
692 DotPos := LastDelimiter('.', Url);
693 if DotPos < ipos then
694 Result := Url + '/';
695 end;
696end;
697
698procedure TCustomIEAddress.InsertTextToList;
699var
700 i: integer;
701 Found: boolean;
702begin
703 Found := False;
704 for i := 0 to Items.Count do
705 begin
706 if Text = Items.Strings[i] then
707 Found := True;
708 end;
709 if Items.Count = 0 then
710 Found := False;
711 if not Found then
712 Items.Insert(0, Text);
713end;
714
715procedure TCustomIEAddress.CheckSecureSite;
716
717 function AnsiStartsStr(const ASubText, AText: WideString): Boolean;
718 begin
719 Result := AnsiSameStr(ASubText, Copy(AText, 1, Length(ASubText)));
720 end;
721begin
722 if FUseSecureSiteBGColor then
723 begin
724 if AnsiStartsStr('https', Text) then
725 Color := FSecureSiteBG
726 else
727 Color := FOldBGColor;
728 end;
729end;
730
731procedure TCustomIEAddress.LoadFromFile(FileName: WideString);
732begin
733 Clear;
734 try
735 Items.LoadFromFile(FileName);
736 finally
737 end;
738end;
739
740procedure TCustomIEAddress.SaveToFile(FileName: WideString);
741begin
742 try
743 Items.SaveToFile(FileName);
744 finally
745 end;
746end;
747
748procedure TCustomIEAddress.TextUpdate;
749var
750 st: WideString;
751 bCancel: Boolean;
752begin
753 if Assigned(FEmbeddedWB) then
754 begin
755 st := Text;
756 bCancel := False;
757 if FUAfterNav then
758 begin
759 try
760 if FEmbeddedWB.HandleAllocated then
761 while (FEmbeddedWB.ReadyState <> READYSTATE_COMPLETE) do
762 begin
763 Forms.Application.ProcessMessages;
764 end;
765 case FTextAfterNav of
766 anLocationUrl: st := FEmbeddedWB.LocationURL;
767 anLocationName: st := FEmbeddedWB.LocationName;
768 end;
769 if Assigned(FOnUpdateText) then
770 FOnUpdateText(Self, Text, st, bCancel);
771 if not bCancel then
772 Text := st;
773 except
774 end;
775 end;
776 end;
777end;
778
779//End of Accesories-------------------------------------------------------------
780
781//Graphical interface----------------------------------------------------------
782
783procedure TCustomIEAddress.DrawIEAddress(MouseInControl, DroppedDown: boolean);
784var
785 CanvasCtrl: TControlCanvas;
786 Rect: TRect;
787 Position, RectT: integer;
788begin
789 case FGUI of
790 gsThemes:
791 begin
792 CanvasCtrl := TControlCanvas.Create;
793 try
794 CanvasCtrl.Control := Self;
795 Rect := ClientRect;
796 CanvasCtrl.Brush.Style := bsClear; //bsSolid;
797 with CanvasCtrl do
798 begin
799 if BorderColor <> clNone then
800 begin
801 Brush.Color := BorderColor;
802 if FHasBorder then
803 begin
804 FrameRect(Rect);
805 end;
806 end
807 else
808 begin
809 Brush.Color := Color;
810 if FHasBorder then
811 begin
812 FrameRect(Rect);
813 end;
814 end;
815 end;
816 Rect.Left := Rect.Right - GetSystemMetrics(SM_CXHTHUMB) - 3;
817 Dec(Rect.Right);
818 InflateRect(Rect, 0, -1);
819 if DroppedDown then
820 with CanvasCtrl do
821 begin
822 Brush.Color := FButtonPressedColor;
823 FillRect(Rect);
824 Rect.Right := Rect.Left + 6;
825 Brush.Color := Color;
826 FillRect(Rect);
827 end
828 else
829 with CanvasCtrl do
830 begin
831 Brush.Color := ButtonColor;
832 FillRect(Rect);
833 Rect.Right := Rect.Left + 6;
834 Brush.Color := Color;
835 FillRect(Rect);
836 end;
837 if BorderColor <> clNone then
838 begin
839 Dec(Rect.Right);
840 with CanvasCtrl do
841 begin
842 Pen.Color := BorderColor;
843 MoveTo(Rect.Right, Rect.Top);
844 LineTo(Rect.Right, Rect.Bottom);
845 end;
846 end;
847 CanvasCtrl.Pen.Color := ArrowColor;
848 Rect := ClientRect;
849 Position := Rect.Right - 10;
850 RectT := Rect.Top;
851 with CanvasCtrl do
852 begin
853 Moveto(Position + 0, RectT + 10);
854 LineTo(Position + 5, RectT + 10);
855 MoveTo(Position + 1, RectT + 11);
856 LineTo(Position + 4, RectT + 11);
857 MoveTo(Position + 2, RectT + 12);
858 LineTo(Position + 3, RectT + 12);
859 end;
860 finally
861 CanvasCtrl.Free;
862 end;
863 end;
864 end;
865end;
866
867procedure TCustomIEAddress.RepaintIEAddress(MouseActive: Boolean);
868var
869 Bool: boolean;
870begin
871 Bool := True;
872 if Assigned(FonPaint) then
873 FOnPaint(Self, Bool);
874 try
875 if not Bool then
876 begin
877 ValidateRect(EditHandle, nil);
878 Refresh;
879 Exit;
880 end;
881 if not (csDesigning in ComponentState) then
882 DrawIEAddress(FMouseActive, DroppedDown);
883 finally
884 end;
885end;
886
887procedure TCustomIEAddress.CalculateRGN;
888var
889 BorderRGN, DropDownRGN: HRGN;
890 BorderWidth, W: Integer;
891begin
892 if Parent = nil then
893 Exit;
894 BorderRGN := CreateRectRGN(0, 0, Width, Height);
895 BorderWidth := GetSystemMetrics(SM_CXDLGFRAME);
896 if not FHasDropDown and not (Style in [csSimple]) then
897 begin
898 W := GetSystemMetrics(SM_CXVSCROLL);
899 Invalidate;
900 DropDownRGN := CreateRectRGN(Width - W - BorderWidth, 0, Width, Height);
901 CombineRgn(BorderRGN, BorderRGN, DropDownRGN, RGN_XOR);
902 DeleteObject(DropDownRGN);
903 end;
904 SetWindowRGN(Handle, BorderRGN, True);
905end;
906
907procedure TCustomIEAddress.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
908var
909 ImageIndex: Integer;
910 Bitmap: TBitmap;
911 Offset: Integer;
912begin
913 Offset := 16;
914 if not (csDesigning in ComponentState) and DroppedDown then
915 begin
916 ImageIndex := GetImageIndex(Items[Index], True); //ListV
917 if (odSelected in State) then
918 FImageIndex := ImageIndex;
919 Bitmap := TBitMap.Create();
920 with Canvas do
921 begin
922 FillRect(Rect);
923 if Index < Items.Count then
924 begin
925 FImageList.GetBitmap(ImageIndex, Bitmap);
926 if Assigned(Bitmap) then
927 begin
928 Bitmap.Canvas.Brush.Style := bsClear;
929 BrushCopy(Bounds(Rect.Left + 4, (Rect.Top + Rect.Bottom - Bitmap.Height) div 2,
930 Bitmap.Width, Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height),
931 Bitmap.Canvas.Pixels[0, Bitmap.Height - 1]);
932 Offset := Bitmap.Width + 6;
933 end;
934 TextOut(Rect.Left + OffSet, Rect.Top, Items[Index]);
935 end;
936 end;
937 BitMap.free;
938 end;
939end;
940//End of Graphical interface----------------------------------------------------
941
942//Icons Section-----------------------------------------------------------------
943
944function TCustomIEAddress.GetImageIndex(aUrl: string; IntoLV: Boolean): Integer;
945var
946 Malloc: Imalloc;
947 SpecialFolder: Cardinal;
948 sfi: TShFileInfo;
949 pidl: PItemIDList;
950 ImgIdx: integer;
951 Ext: string;
952 bCancel: Boolean;
953 Icon: TIcon;
954begin
955 Result := -1;
956 try
957 ShGetMalloc(Malloc);
958 //If its a MS special folder
959 SpecialFolder := GetSpecialFolderNo(aUrl);
960 if (SUCCEEDED(SHGetSpecialFolderLocation(Handle, SpecialFolder, Pidl))) then
961 begin
962 ShGetFileInfo(PChar(pidl), 0, sfi, sizeof(sfi), SHGFI_ICON or SHGFI_PIDL);
963 Result := sfi.iIcon;
964 end
965 else
966 begin //If its a local file
967 if FileExists(aUrl) or (AnsiCompareText(Copy(aURL, 1, 7), 'file://') = 0) then
968 begin
969 ShGetFileInfo(PChar(aUrl), FILE_ATTRIBUTE_NORMAL, sfi, sizeOf(sfi),
970 SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES or SHGFI_SMALLICON);
971 Result := sfi.iIcon;
972 end
973 // If its a folder
974 else
975 if DirectoryExists(aUrl) then
976 begin
977 ShGetFileInfo(PChar(aUrl), FILE_ATTRIBUTE_DIRECTORY, sfi, SHGFI_EXETYPE,
978 SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES or SHGFI_SMALLICON);
979 Result := sfi.iIcon;
980 end
981 // if its a a url (File/internet Address or Shortcut). so, lets start ;)
982 else
983 if aURL <> '' then
984 begin
985 Ext := GetExtension(aUrl);
986 if Ext = '*.htm' then
987 begin
988 if (not (DroppedDown)) and FShowFavicons then
989 begin //Get Favicon
990 ImgIdx := AddFaviconToImageList;
991 if ImgIdx > -1 then
992 begin
993 sfi.iIcon := AddFaviconToImageList;
994 Result := sfi.iIcon;
995 DestroyIcon(sfi.iIcon);
996 Malloc.Free(pidl);
997 Exit;
998 end;
999 end;
1000 if FUseAppIcon then
1001 begin //Get app icon
1002 icon := Forms.Application.Icon;
1003 if Assigned(FOnGetAppIcon) then
1004 FOnGetAppIcon(Self, bCancel, Icon);
1005 if not bCancel then
1006 begin
1007 ImgIdx := FImageList.AddIcon(Icon);
1008 sfi.iIcon := ImgIdx;
1009 Result := sfi.iIcon;
1010 end;
1011 end
1012 else
1013 begin //Get icon for internet shortcuts and addresses
1014 ShGetFileInfo('*.htm', FILE_ATTRIBUTE_NORMAL, sfi, sizeOf(sfi),
1015 SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES or SHGFI_SMALLICON);
1016 if Assigned(FOnGetIcon) then
1017 FOnGetIcon(Self, 'htm', sfi.hIcon);
1018 Result := sfi.iIcon;
1019 end
1020 end
1021 else
1022 begin //Get all the rest system icons
1023 ShGetFileInfo(Pchar(Ext), FILE_ATTRIBUTE_NORMAL, sfi, sizeOf(sfi),
1024 SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES or SHGFI_SMALLICON);
1025 Result := sfi.iIcon;
1026 end;
1027 end;
1028 end;
1029 finally
1030 try
1031 if Result <> -1 then
1032 DestroyIcon(sfi.iIcon)
1033 else
1034 Result := 0;
1035 finally
1036 end;
1037 Malloc.Free(pidl);
1038 end;
1039end;
1040
1041function TCustomIEAddress.GrabFavicon(URL: string; dest: string): Boolean;
1042var
1043 i: Integer;
1044 St: string;
1045 bCancel: Boolean;
1046begin
1047 Result := False;
1048 try
1049 bCancel := False;
1050 St := RemovePrefix(URL, 'HTTP://');
1051 I := AnsiPos('/', RemovePrefix(St, 'HTTP://'));
1052 if I > 0 then
1053 St := 'http://' + System.Copy(St, 1, I);
1054 if Assigned(FOnGetFavicon) then
1055 FOnGetFavicon(Self, (GetCacheFolder + 'favicon.ico'), Text, bCancel, nil);
1056 if not bCancel then
1057 try
1058 Result := UrlDownloadToFile(nil, PChar(St + 'favicon.ico'), PChar(dest), 0, nil) = 0;
1059 except
1060 Result := False;
1061 end;
1062 finally
1063 end;
1064end;
1065
1066function TCustomIEAddress.AddFaviconToImageList: integer;
1067var
1068 ImgIdx: integer;
1069 Icon: TIcon;
1070 bCancel: Boolean;
1071 st: WideString;
1072begin
1073 Result := -1;
1074 bCancel := False;
1075 if FShowFavicons and (not DroppedDown) and IsValidURL(Text) and
1076 (not (csDesigning in ComponentState)) then
1077 begin
1078 st := GetCacheFolder + 'favicon.ico';
1079 if GrabFavIcon(Text, st) then
1080 begin
1081 ImgIdx := -1;
1082 Icon := TIcon.Create();
1083 try
1084 Icon.LoadFromFile(st);
1085 except
1086 end;
1087{$IFDEF DELPHI10_UP}
1088 Icon.SetSize(16, 16);
1089{$ELSE}
1090 Icon.Height := 16;
1091 Icon.Width := 16;
1092{$ENDIF}
1093 if Assigned(FOnGetFavicon) then
1094 FOnGetFavicon(Self, st, Text, bCancel, Icon);
1095 if not bCancel then
1096 try
1097 ImgIdx := FImageList.AddIcon(Icon)
1098 except
1099 end;
1100 if ImgIdx > 0 then
1101 begin
1102 Result := ImgIdx;
1103 if not bCancel then
1104 FImageList.Draw(FCanvas, IconLeft, IConTop, ImgIdx, True);
1105 end;
1106 Icon.Free;
1107 end;
1108 end;
1109end;
1110
1111//End of Icons section----------------------------------------------------------
1112
1113// Registry Section ------------------------------------------------------------
1114
1115procedure TCustomIEAddress.GetTypedURLs;
1116var
1117 Counter: Integer;
1118 S: WideString;
1119 GetTextTmp: PChar;
1120begin
1121 Items.Clear;
1122 with TRegistry.Create do
1123 try
1124 RootKey := HKEY_CURRENT_USER;
1125 if FTypedUrlsMethod = tuCommon then
1126 begin
1127 if OpenKey('Software\Microsoft\Internet Explorer\TypedURLs', False) then
1128 begin
1129 for Counter := 1 to 25 do
1130 begin
1131 if ValueExists('Url' + IntToStr(Counter)) then
1132 begin
1133 S := ReadString('Url' + IntToStr(Counter));
1134 GetTextTmp := Items.GetText;
1135 if (AnsiPos(S, GetTextTmp) = 0) and (Trim(S) <> '') then
1136 Items.Add(Trim(S));
1137 StrDispose(GetTextTmp);
1138 end;
1139 end;
1140 CloseKey;
1141 end;
1142 end;
1143 if FTypedUrlsMethod = tuExtended then
1144 begin
1145 if OpenKey('Software\Microsoft\Internet Explorer\TypedAddress', False) then
1146 begin
1147 for Counter := 1 to 25 do
1148 begin
1149 if ValueExists('Url' + IntToStr(Counter)) then
1150 begin
1151 S := ReadString('Url' + IntToStr(Counter));
1152 GetTextTmp := Items.GetText;
1153 if (Ansipos(S, GetTextTmp) = 0) and (Trim(S) <> '') then
1154 Items.Add(S);
1155 StrDispose(GetTextTmp);
1156 end;
1157 end;
1158 CloseKey;
1159 end;
1160 end;
1161 finally
1162 Free;
1163 end;
1164 if not Assigned(FEmbeddedWB) and (TextOnLoad <> tlUserDefine) then
1165 if Items.Count <> 0 then
1166 Text := Trim(Items[0])
1167 else
1168 Text := '';
1169end;
1170
1171procedure TCustomIEAddress.RegistryUpdate;
1172var
1173 MaxItems, Counter: Integer;
1174 Name, SName: WideString;
1175 Reg: TRegistry;
1176 bCancel: Boolean;
1177begin
1178 if (Trim(Text) <> '') and FUpdateRegistry then
1179 begin
1180 Reg := TRegistry.Create;
1181 bCancel := False;
1182 try
1183 with Reg do
1184 begin
1185 if Assigned(FOnUpdateRegistry) then
1186 FOnUpdateRegistry(Self, Text, bCancel);
1187 if not bCancel then
1188 begin
1189 RootKey := HKEY_CURRENT_USER;
1190 if FTypedUrlsMethod = tuCommon then
1191 begin
1192 if OpenKey('Software\Microsoft\Internet Explorer\TypedURLs', True) then
1193 begin
1194 if Items.Count < 24 then
1195 MaxItems := Items.Count + 1
1196 else
1197 MaxItems := 25;
1198 for Counter := 0 to MaxItems - 1 do
1199 begin
1200 Name := 'Url' + IntToStr(Counter);
1201 if items[Counter - 1] <> '' then
1202 WriteString(Name, items[Counter - 1]);
1203 end;
1204 end;
1205 CloseKey;
1206 end;
1207 if FTypedUrlsMethod = tuExtended then
1208 begin
1209 if OpenKey('Software\Microsoft\Internet Explorer\TypedAddress', True) then
1210 begin
1211 if Items.Count < 24 then
1212 MaxItems := Items.Count + 1
1213 else
1214 MaxItems := 25;
1215 for Counter := 0 to MaxItems - 1 do
1216 begin
1217 Name := 'Url' + IntToStr(Counter);
1218 if items[Counter - 1] <> '' then
1219 begin
1220 if Assigned(FEmbeddedWB) then
1221 begin
1222 FEmbeddedWB.Wait;
1223 SName := items[Counter - 1] + ' SiteName:' +
1224 FEmbeddedWB.LocationName;
1225 WriteString(Name, SName);
1226 end;
1227 end;
1228 end;
1229 end;
1230 end;
1231 CloseKey;
1232 end;
1233 end;
1234 finally
1235 Reg.Free;
1236 end;
1237 end;
1238end;
1239// End of Registry Section -----------------------------------------------------
1240
1241// Set--------------------------------------------------------------------------
1242
1243procedure TCustomIEAddress.SetAbout(Value: string);
1244begin
1245 Exit;
1246end;
1247
1248procedure TCustomIEAddress.SetBounds(Left, Top, Width, Height: Integer);
1249begin
1250 inherited SetBounds(Left, Top, Width, Height);
1251 SetTextPosition;
1252 CalculateRGN;
1253end;
1254
1255procedure TCustomIEAddress.SetDropDown(const Value: Boolean);
1256begin
1257 FHasDropDown := Value;
1258 CalculateRGN;
1259end;
1260
1261procedure TCustomIEAddress.SetFlat(const Value: Boolean);
1262begin
1263 if Value <> FFlat then
1264 begin
1265 FFlat := Value;
1266 Ctl3D := not Value;
1267 FHasBorder := False;
1268 Invalidate;
1269 end;
1270end;
1271
1272procedure TCustomIEAddress.SetTextPosition;
1273begin
1274 SetWindowPos(EditHandle, 0, FImageSize + 7, 5, Width - 46, Height - 7, 0);
1275end;
1276
1277procedure TCustomIEAddress.SetHasBorder(const Value: Boolean);
1278begin
1279 FHasBorder := Value;
1280 Invalidate;
1281 CalculateRGN;
1282 DrawIEAddress(FMouseActive, DroppedDown);
1283end;
1284
1285procedure TCustomIEAddress.SetSiteHint;
1286begin
1287 if Assigned(FEmbeddedWB) and FShowSiteHint then
1288 begin
1289 if FEmbeddedWB.HandleAllocated then
1290 while (FEmbeddedWB.ReadyState <> READYSTATE_COMPLETE) do
1291 Forms.Application.ProcessMessages;
1292 ShowHint := True;
1293 Application.HintColor := FHintColor;
1294 if FEmbeddedWB.LocationUrl = Text then
1295 Hint := FEmbeddedWB.LocationName;
1296 end;
1297end;
1298
1299procedure TCustomIEAddress.SetTheme;
1300begin
1301 case FGUI of
1302 gsThemes:
1303 begin
1304 case FThemes of
1305 tmNone:
1306 begin
1307 FBorderColor := clblack;
1308 FArrowColor := clblack;
1309 FButtonPressedColor := clBtnShadow;
1310 FButtonColor := clBtnFace;
1311 end;
1312 tmXP:
1313 begin
1314 FBorderColor := clInactiveCaptionText;
1315 FArrowColor := clNavy;
1316 FButtonColor := $F0CAA6;
1317 FButtonPressedColor := clInactiveCaptionText;
1318 end;
1319 tmSilver:
1320 begin
1321 FBorderColor := clGray;
1322 FArrowColor := cl3DDKShadow;
1323 FButtonColor := clSilver;
1324 FButtonPressedColor := clActiveBorder;
1325 end;
1326 tmSoil:
1327 begin
1328 FBorderColor := clMaroon;
1329 FArrowColor := clMaroon;
1330 FButtonColor := clInfoBk;
1331 FButtonPressedColor := cl3DLight;
1332 end;
1333 end;
1334 RepaintIEAddress(True);
1335 end;
1336 end;
1337end;
1338
1339procedure TCustomIEAddress.SetTextOnLd();
1340begin
1341 if Assigned(FEmbeddedWB) then
1342 begin
1343 case FTextOnLoad of
1344 tlIELastVisited: ;
1345 tlIEHomePage: Text := FEmbeddedWB.GetIEHomePage;
1346 tlBlank: FEmbeddedWB.AssignEmptyDocument;
1347 tlUserDefine: Text := FTextOnShow;
1348 end;
1349 if FNavOnLoad then
1350 FEmbeddedWB.Go(Text);
1351 end;
1352end;
1353
1354procedure TCustomIEAddress.SetModified(Value: Boolean);
1355begin
1356 if HandleAllocated then
1357 PostMessage(EditHandle, EM_SETMODIFY, Byte(Value), 0)
1358 else
1359 FModified := Value;
1360end;
1361
1362procedure TCustomIEAddress.SetAutoCompleteOptions(const Value: TAutoCompleteOptions);
1363begin
1364 if FAutoCompleteOptions <> Value then
1365 begin
1366 FAutoCompleteOptions := Value;
1367 case FAComp of
1368 AutoComplete1: UpdateAutoComplete;
1369 AutoComplete2: Exit;
1370 end;
1371
1372 end;
1373end;
1374
1375procedure TCustomIEAddress.SetACOptions(const Value: TAutoComplete2Options);
1376const
1377 IID_IAutoComplete2: TGUID = '{EAC04BC0-3791-11d2-BB95-0060977B464C}';
1378 Options: array[TAutoComplete2Option] of integer =
1379 ($0000, $0001, $0002, $0004, $0008, $0010, $0020, $0040, $0080, $0100);
1380var
1381 Option: TAutoComplete2Option;
1382 Opt: DWORD;
1383 AC2: IAutoComplete2;
1384begin
1385 if (FAutoComplete <> nil) then
1386 begin
1387 if S_OK = FAutoComplete.QueryInterface(IID_IAutoComplete2, AC2) then
1388 begin
1389 Opt := ACO_NONE;
1390 for Option := Low(Options) to High(Options) do
1391 begin
1392 if (Option in FAutoComplete2Options) then
1393 Opt := Opt or DWORD(Options[Option]);
1394 end;
1395 AC2.SetOptions(Opt);
1396 end;
1397 end;
1398 FAutoComplete2Options := Value;
1399end;
1400
1401procedure TCustomIEAddress.SetAutoComplete2Source(const Value: TAutoComplete2Source);
1402begin
1403 if FAutoComplete2Source <> Value then
1404 begin
1405 FAutoComplete2Source := Value;
1406 RecreateWnd;
1407 end;
1408end;
1409
1410// End of Set-------------------------------------------------------------------
1411
1412//events------------------------------------------------------------------
1413
1414constructor TCustomIEAddress.Create(AOwner: TComponent);
1415var
1416 sfi: TShFileInfo;
1417 aHandle: Cardinal;
1418begin
1419 inherited Create(AOwner);
1420 ControlStyle := ControlStyle + [csOpaque] - [csSetCaption];
1421 DoubleBuffered := True;
1422 FAbout := 'TIEAddress. ' + WEB_SITE;
1423 FButtonWidth := GetSystemMetrics(SM_CXVSCROLL);
1424 FButtonColor := clBtnFace;
1425 FButtonPressedColor := clBtnFace;
1426 AutoComplete2Options := [acoAutoSuggest, acoAutoAppend, acoSearch];
1427 AutoComplete2Source := [acsList, acsHistory, acsMRU, acsShell];
1428 AutoCompleteOptions := [acAutoAppend, acUrlHistory];
1429 AutoCompleteVersion := AutoComplete2;
1430 AutoNavigateOnDblClk := True;
1431 AutoNavigateOnEnterKey := True;
1432 AutoNavigateOnLoad := True;
1433 AutoNavigateOnSelected := True;
1434 FCustomProperty := '';
1435 FGUI := gsThemes;
1436 FHasBorder := True;
1437 FHasDropDown := True;
1438 FHintColor := clInfoBK;
1439 FImageIndex := -1;
1440 FImageSize := 16;
1441 FMouseActive := False;
1442 ShowHint := True;
1443 FSecureSiteBG := clInfobk;
1444 FSelImageIndex := -1;
1445 FShowFavicons := False;
1446 FShowSiteHint := True;
1447 FTextOnLoad := tlIEHomePage;
1448 FTypedUrlsMethod := tuCommon;
1449 FUAfterNav := True;
1450 FUpdateRegistry := True;
1451 FUseAppIcon := False;
1452 FUseSecureSiteBGColor := True;
1453 Height := 22;
1454 IconLeft := 4;
1455 IconTop := 3;
1456 ItemHeight := 16;
1457 Sorted := False;
1458 Style := csDropDown;
1459 TabOrder := 0;
1460 Width := 145;
1461 FImageList := TImageList.Create(self);
1462 FImageList.DrawingStyle := dsNormal;
1463 FImageList.ShareImages := True;
1464 FImageList.Height := 16;
1465 FImageList.Width := 16;
1466 FCanvas := TControlCanvas.Create;
1467 FCanvas.Control := Self;
1468 FCanvas.Brush.Style := bsClear;
1469 FCanvas.Handle := EditHandle;
1470 dllVer := GetDllVersion('Shlwapi.dll');
1471 aHandle := ShGetFileInfo('', 0, sfi, sizeOf(sfi), SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
1472 if (aHandle <> 0) then
1473 FImageList.Handle := aHandle;
1474end;
1475
1476destructor TCustomIEAddress.Destroy;
1477begin
1478 Application.HintColor := FOldHintColor;
1479 Color := FOldBGColor;
1480 FImageList.free;
1481 FCanvas.free; //Ray
1482 inherited Destroy;
1483end;
1484
1485procedure TCustomIEAddress.Loaded;
1486begin
1487 inherited;
1488 FOldBGColor := Self.Color;
1489 FOldHintColor := Application.HintColor;
1490 DoubleBuffered := True;
1491 Modified := False;
1492 if not (csDesigning in ComponentState) then
1493 begin
1494 case FGUI of
1495 gsThemes:
1496 begin
1497 BevelEdges := [];
1498 BevelInner := bvnone;
1499 BevelKind := bkFlat;
1500 BevelOuter := BVNone;
1501 BiDiMode := bdLeftToRight;
1502 Ctl3D := False;
1503 ParentBiDiMode := False;
1504 ParentCtl3D := False;
1505 ImeMode := imDontCare;
1506 ImeName := '';
1507 SetTheme;
1508 end;
1509 end;
1510 CalculateRGN;
1511 GetTypedURLs;
1512 Text := FixUrl(Text);
1513 CheckSecureSite;
1514 TextUpdate;
1515 SetSiteHint;
1516 AddFaviconToImageList;
1517 SetTextOnLd();
1518 end;
1519end;
1520
1521procedure TCustomIEAddress.CreateParams(var Params: TCreateParams);
1522begin
1523 inherited CreateParams(Params);
1524 Params.Style := Params.Style or cbs_OwnerDrawFixed or ES_MULTILINE;
1525end;
1526
1527procedure TCustomIEAddress.CreateWindowHandle(const Params: TCreateParams);
1528begin
1529 inherited CreateWindowHandle(Params);
1530 SetTextPosition;
1531end;
1532
1533procedure TCustomIEAddress.CreateWnd;
1534begin
1535 inherited CreateWnd;
1536 case FAComp of
1537 AutoComplete1: UpdateAutoComplete;
1538 AutoComplete2:
1539 if (GetDllVersion('Shlwapi.dll') > 4.72) then
1540 UpdateIAutoComplete2
1541 else
1542 UpdateAutoComplete;
1543 end;
1544end;
1545
1546procedure TCustomIEAddress.UpdateAutoComplete;
1547var
1548 SelOptions: DWORD;
1549begin
1550 SelOptions := 0;
1551 if acAutoSuggest in FAutoCompleteOptions then
1552 SelOptions := SelOptions or SHACF_AUTOSUGGEST_FORCE_ON
1553 else
1554 SelOptions := SelOptions or SHACF_AUTOSUGGEST_FORCE_OFF;
1555 if acAutoAppend in FAutoCompleteOptions then
1556 SelOptions := SelOptions or SHACF_AUTOAPPEND_FORCE_ON
1557 else
1558 SelOptions := SelOptions or SHACF_AUTOAPPEND_FORCE_OFF;
1559 if acFileSystem in FAutoCompleteOptions then
1560 SelOptions := SelOptions or SHACF_FILESYSTEM
1561 else
1562 SelOptions := SelOptions or SHACF_FILESYSTEM;
1563 if acUrlHistory in FAutoCompleteOptions then
1564 SelOptions := SelOptions or SHACF_URLHISTORY
1565 else
1566 SelOptions := SelOptions or SHACF_URLHISTORY;
1567 if acUrlMRU in FAutoCompleteOptions then
1568 SelOptions := SelOptions or SHACF_URLMRU
1569 else
1570 SelOptions := SelOptions or SHACF_URLMRU;
1571 if acUrlAll in FAutoCompleteOptions then
1572 SelOptions := SelOptions or SHACF_URLALL
1573 else
1574 SelOptions := SelOptions or SHACF_URLALL;
1575 if acUseTab in FAutoCompleteOptions then
1576 SelOptions := SelOptions or SHACF_USETAB
1577 else
1578 SelOptions := SelOptions or SHACF_USETAB;
1579 SHAutoComplete(EditHandle, SelOptions);
1580end;
1581
1582procedure TCustomIEAddress.UpdateIAutoComplete2;
1583const
1584 IID_IAutoComplete: TGUID = '{00bb2762-6a77-11d0-a535-00c04fd7d062}';
1585 CLSID_IAutoComplete: TGUID = '{00BB2763-6A77-11D0-A535-00C04FD7D062}';
1586 CLSID_ACLHistory: TGUID = (D1: $00BB2764; D2: $6A77; D3: $11D0; D4: ($A5, $35, $00, $C0, $4F, $D7, $D0, $62));
1587 CLSID_ACListISF: TGUID = (D1: $03C036F1; D2: $A186; D3: $11D0; D4: ($82, $4A, $00, $AA, $00, $5B, $43, $83));
1588 CLSID_ACLMRU: TGUID = (D1: $6756A641; D2: $DE71; D3: $11D0; D4: ($83, $1B, $00, $AA, $00, $5B, $43, $83));
1589var
1590 Uk: IUnknown;
1591 ACInterface: IEnumString;
1592begin
1593 try
1594 Uk := CreateComObject(CLSID_IAutoComplete);
1595 if (Uk <> nil) and (Uk.QueryInterface(IID_IAutoComplete, FAutoComplete) = S_OK) then
1596 begin
1597 if acsHistory in FAutoComplete2Source then
1598 ACInterface := CreateComObject(CLSID_ACLHistory) as IEnumString
1599 else
1600 if acsMRU in FAutoComplete2Source then
1601 ACInterface := CreateComObject(CLSID_ACLMRU) as IEnumString
1602 else
1603 if acsShell in FAutoComplete2Source then
1604 ACInterface := CreateComObject(CLSID_ACListISF) as IEnumString;
1605 ACInterface := CreateComObject(CLSID_ACLHistory) as IEnumString;
1606 SetACOptions(FAutoComplete2Options);
1607 FAutoComplete.Init(Edithandle, ACInterface, nil, nil)
1608 end;
1609 except
1610 end;
1611end;
1612
1613procedure TCustomIEAddress.DestroyWnd;
1614begin
1615 FModified := Modified;
1616 inherited DestroyWnd;
1617end;
1618
1619procedure TCustomIEAddress.WndProc(var Message: TMessage);
1620begin
1621 inherited;
1622 case Message.Msg of
1623 CBN_DropDown or CB_ShowDropDown: SetTextPosition;
1624 CM_MouseEnter: RepaintIEAddress(True);
1625
1626 WM_MOUSEACTIVATE:
1627 begin
1628 if not DroppedDown then
1629 Exit;
1630 Message.Result := MA_NOACTIVATE;
1631 SetWindowPos(Parent.Handle, HWND_TOP, 0, 0, 0, 0, SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);
1632 if (GetActiveWindow <> Parent.Handle) then
1633 SetActiveWindow(Parent.Handle);
1634 end;
1635
1636 WM_Paint:
1637 begin
1638 if not (csReading in ComponentState) then
1639 begin
1640 ControlStyle := ControlStyle + [csOpaque];
1641 RepaintIEAddress(False);
1642 SetTextPosition;
1643 FImageList.Draw(FCanvas, IconLeft, IconTop,
1644 GetImageIndex(Text, False), True);
1645 end;
1646 end;
1647 end;
1648end;
1649
1650procedure TCustomIEAddress.MouseMove(Shift: TShiftState; X, Y: Integer);
1651begin
1652 CheckButtonState(-1, -1);
1653 inherited;
1654end;
1655
1656procedure TCustomIEAddress.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
1657begin
1658 if DroppedDown then
1659 begin
1660 Include(FEditState, csButtonPressed);
1661 Include(FEditState, csMouseCaptured);
1662 end;
1663 inherited;
1664end;
1665
1666procedure TCustomIEAddress.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
1667begin
1668 CheckButtonState(-1, -1);
1669 inherited;
1670end;
1671
1672procedure TCustomIEAddress.Change;
1673// var
1674// Key: Word;
1675begin
1676 PostMessage(Handle, CB_SHOWDROPDOWN, 0, 0);
1677 FImageList.Draw(FCanvas, IconLeft, IconTop, GetImageIndex(Text, False), True);
1678// key := VK_RETURN;
1679// KeyDown(key, []);
1680end;
1681
1682procedure TCustomIEAddress.Click;
1683var
1684 Rec: TRect;
1685 pt: TPoint;
1686 bCancel: Boolean;
1687begin
1688 inherited;
1689 if not (csDesigning in ComponentState) then
1690 begin
1691 bCancel := False;
1692 GetCursorPos(pt);
1693 PostMessage(Handle, CB_GETDROPPEDCONTROLRECT, 0, longint(@rec));
1694 if ((pt.x >= Rec.Left) and (pt.x <= Rec.Right)
1695 and (pt.y >= Rec.Top) and (pt.y <= Rec.Bottom)) then
1696 begin
1697 if Assigned(FOnUrlSelected) then
1698 FOnUrlSelected(Self, Text, bCancel);
1699 if not bCancel then
1700 begin
1701 FSelImageIndex := FImageIndex;
1702 FImageList.Draw(FCanvas, 4, 3, FSelImageIndex, True);
1703 if FNavOnSelected and Assigned(FEmbeddedWB) then
1704 FEmbeddedWB.Go(Text);
1705 AddToList;
1706 end;
1707 end;
1708 // PostMessage(EditHandle, EM_SETREADONLY, 0, 0);
1709 // PostMessage(EditHandle, EM_SETSEL, 0, -1);
1710 end;
1711end;
1712
1713procedure TCustomIEAddress.DblClick;
1714var
1715 Rec: TRect;
1716 pt: TPoint;
1717begin
1718 inherited;
1719 GetCursorPos(pt);
1720 PostMessage(Handle, CB_GETDROPPEDCONTROLRECT, 0, longint(@rec));
1721 if ((pt.x >= Rec.Left) and (pt.x <= Rec.Right)
1722 and (pt.y >= Rec.Top) and (pt.y <= Rec.Bottom)) then
1723 begin
1724 fSelImageIndex := FImageIndex;
1725 fImageList.Draw(FCanvas, 4, 3, fSelImageIndex, True);
1726 AddToList;
1727 if FNavOnDblClk and Assigned(FEmbeddedWB) then
1728 FEmbeddedWB.Go(Text);
1729 end;
1730 PostMessage(EditHandle, EM_SETREADONLY, 0, 0);
1731 PostMessage(EditHandle, EM_SETSEL, 0, -1);
1732end;
1733
1734procedure TCustomIEAddress.KeyDown(var Key: Word; Shift: TShiftState);
1735var
1736 FListIndex: integer;
1737 bCancel: Boolean;
1738begin
1739 inherited;
1740 bCancel := False;
1741 if (DroppedDown) then
1742 begin
1743 if (Key = VK_RETURN) then
1744 begin
1745 if Assigned(FOnUrlSelected) then
1746 FOnUrlSelected(Self, Text, bCancel);
1747 if not bCancel then
1748 begin
1749 Key := VK_CLEAR;
1750 FListIndex := SendMessage(Handle, CB_GETCURSEL, 0, 0);
1751 if FListIndex > 0 then
1752 Items.Move(FListIndex, 0);
1753 Text := Items[0];
1754 PostMessage(Handle, CB_SHOWDROPDOWN, 0, 0);
1755 PostMessage(handle, CB_SETCURSEL, 0, 0);
1756 PostMessage(EditHandle, EM_SETREADONLY, 0, 0);
1757 PostMessage(EditHandle, EM_SETSEL, 0, -1);
1758 AddToList;
1759 if Assigned(FEmbeddedWB) then
1760 begin
1761 if FNavOnEnterKey then
1762 FEmbeddedWB.Go(Text);
1763 if FNavOnSelected then
1764 FEmbeddedWB.Go(Text);
1765 end;
1766 FSelImageIndex := FImageIndex;
1767 if Modified then
1768 FImageList.Draw(FCanvas, 4, 3, FSelImageIndex, True);
1769 end;
1770 end
1771 else
1772 if ((ssAlt in Shift) and ((Key = VK_DOWN) or (Key = VK_UP))) or
1773 (Key = VK_ESCAPE) then
1774 begin
1775 Key := VK_CLEAR;
1776 PostMessage(Handle, CB_SHOWDROPDOWN, 0, 0);
1777 PostMessage(EditHandle, EM_SETREADONLY, 0, 0);
1778 PostMessage(EditHandle, EM_SETSEL, 0, -1);
1779 end
1780 else
1781 if (not (ssAlt in Shift)) and (Key = VK_DOWN) then
1782 begin
1783 Key := VK_CLEAR;
1784 FListIndex := SendMessage(Handle, CB_GETCURSEL, 0, 0);
1785 if FListIndex >= 24 then
1786 Exit;
1787 PostMessage(Handle, CB_SETCURSEL, (FListIndex + 1), 0);
1788 PostMessage(EditHandle, EM_SETSEL, -1, 0);
1789 FSelImageIndex := FImageIndex;
1790 FImageList.Draw(FCanvas, 4, 3, FSelImageIndex, True);
1791 if FNavOnSelected and Assigned(FEmbeddedWB) then
1792 FEmbeddedWB.Go(Text);
1793 end
1794 else
1795 if (not (ssAlt in Shift)) and (Key = VK_UP) then
1796 begin
1797 Key := VK_CLEAR;
1798 FListIndex := SendMessage(Handle, CB_GETCURSEL, 0, 0);
1799 if FListIndex <= 0 then
1800 Exit;
1801 PostMessage(Handle, CB_SETCURSEL, (FListIndex - 1), 0);
1802 PostMessage(EditHandle, EM_SETSEL, -1, 0);
1803 FSelImageIndex := FImageIndex;
1804 FImageList.Draw(FCanvas, 4, 3, FSelImageIndex, True);
1805 if Assigned(FEmbeddedWB) and FNavOnSelected then
1806 FEmbeddedWB.Go(Text);
1807 end;
1808 end
1809 else //Not Droped Down
1810 begin
1811 if (Key = VK_RETURN) then
1812 begin
1813 if Text <> '' then
1814 begin
1815 if Assigned(FOnUrlSelected) then
1816 FOnUrlSelected(Self, Text, bCancel);
1817 if not BCancel then
1818 begin
1819 if FNavOnEnterKey and Assigned(FEmbeddedWB) then
1820 FEmbeddedWB.Go(Text);
1821 AddToList;
1822 end;
1823 end;
1824 end
1825 else
1826 if (Key = VK_DOWN) or ((ssAlt in Shift) and (Key = VK_DOWN)) then
1827 begin
1828 Key := VK_CLEAR;
1829 PostMessage(Handle, CB_GETCURSEL, 0, 0);
1830 // PostMessage(EditHandle, EM_SETREADONLY, 1, 0);
1831 PostMessage(EditHandle, EM_SETSEL, -1, 0);
1832 PostMessage(Handle, CB_SHOWDROPDOWN, 1, 0);
1833 if FNavOnSelected and Assigned(FEmbeddedWB) then
1834 FEmbeddedWB.Go(Text);
1835 end
1836 else
1837 if (Key = VK_UP) then
1838 begin
1839 Key := VK_CLEAR;
1840 Exit;
1841 end
1842 end
1843end;
1844
1845procedure TCustomIEAddress.DragDrop(Source: TObject; X, Y: Integer);
1846begin
1847 inherited;
1848end;
1849
1850procedure TCustomIEAddress.DragOver(Source: TObject; X, Y: Integer;
1851 State: TDragState; var Accept: Boolean);
1852begin
1853 inherited;
1854end;
1855
1856initialization //Must have for ShGetFileInfo
1857 OleInitialize(nil);
1858
1859finalization
1860 OleUninitialize;
1861end.
1862
Note: See TracBrowser for help on using the repository browser.