source: cprs/branches/tmg-cprs/CPRS-Chart/TMG_Extra/HTMLEdit/IEGuid.pas@ 1623

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

TMG Ver 1.1 Added HTML Support, better demographics editing
File size: 15.8 KB
Line 
1//****************************************************
2// IE-Guid *
3// For Delphi *
4// Freeware Component *
5// by *
6// *
7// Per Lindsø Larsen *
8// http://www.euromind.com/iedelphi *
9// *
10// Contributor: *
11// Eran Bodankin (bsalsa) - D2005 update and bug fix *
12// bsalsa@gmail.com *
13// *
14// Documentation and updated versions: *
15// http://www.bsalsa.com *
16//****************************************************
17
18{*******************************************************************************}
19{LICENSE:
20THIS SOFTWARE IS PROVIDED TO YOU "AS IS" WITHOUT WARRANTY OF ANY KIND,
21EITHER EXPRESSED OR IMPLIED INCLUDING BUT NOT LIMITED TO THE APPLIED
22WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
23YOU ASSUME THE ENTIRE RISK AS TO THE ACCURACY AND THE USE OF THE SOFTWARE
24AND ALL OTHER RISK ARISING OUT OF THE USE OR PERFORMANCE OF THIS SOFTWARE
25AND DocUMENTATION. BSALSA PRODUCTIONS DOES NOT WARRANT THAT THE SOFTWARE IS ERROR-FREE
26OR WILL OPERATE WITHOUT INTERRUPTION. THE SOFTWARE IS NOT DESIGNED, INTENDED
27OR LICENSED FOR USE IN HAZARDOUS ENVIRONMENTS REQUIRING FAIL-SAFE CONTROLS,
28INCLUDING WITHOUT LIMITATION, THE DESIGN, CONSTRUCTION, MAINTENANCE OR
29OPERATION OF NUCLEAR FACILITIES, AIRCRAFT NAVIGATION OR COMMUNICATION SystemS,
30AIR TRAFFIC CONTROL, AND LIFE SUPPORT OR WEAPONS SystemS. BSALSA PRODUCTIONS SPECIFICALLY
31DISCLAIMS ANY EXPRESS OR IMPLIED WARRANTY OF FITNESS FOR SUCH PURPOSE.
32
33You may use, change or modify the component under 3 conditions:
341. In your website, add a Link to "http://www.bsalsa.com"
352. In your application, add credits to "Embedded Web Browser"
363. Mail me (bsalsa@gmail.com) any code change in the unit
37 for the benefit of the other users.
384. You may consider donation in our web site!
39{*******************************************************************************}
40//$Id: IEGuid.pas,v 1.2 2006/11/15 21:01:42 sergev Exp $
41
42
43unit IEGuid;
44
45interface
46
47uses
48 Mshtml_Ewb, Clipbrd, Comobj, Activex, Windows, Messages, SysUtils, Classes, Controls, Forms, Dialogs;
49
50type
51
52 TIEGuid = class(TObject)
53 private
54 function LoadList(Fname: string): Integer;
55 public
56 Names: TStringlist;
57 Guids: TStringlist;
58 function NameFromGuid(Guid: TGUID): string;
59 function NameFromGuidStr(GuidStr: string): string;
60 function CopyToClipboard(GuidName: string): HResult;
61 function GetInterfaces(Unk: IUnknown; const S: TStrings): HResult;
62 function GetServices(Unk: IUnknown; rsid: string; const S: TStrings): HResult;
63 function GetConnectionPoints(Unk: IUnknown; const S: TStrings; ShowIDispatch: Boolean): HResult;
64 procedure GetPropertyList(const Obj: IDispatch; const S: TStrings);
65 function GetDispatchFromName(const Disp: IDispatch; const PropertyName: WideString): OleVariant;
66 function GetInterfacesEx(Unk: IUnknown;
67 const S: TStrings; ShowIUnknown, ShowIDispatch, ShowIDispatchEx, ShowDispinterfaces: Boolean): HResult;
68 destructor Destroy; override;
69 constructor Create(const fname: string);
70 end;
71
72function CreateIEGuid(HeadersDir, GuidFile: string): Integer;
73function CreateIEList(Guidfile, IEList: string): Integer;
74
75implementation
76
77{ TIEGuid }
78
79function TIEGuid.GetDispatchFromName(const Disp: IDispatch; const PropertyName: WideString): OleVariant;
80var
81 PName: PWideChar;
82 DispID: Integer;
83 ExcepInfo: TExcepInfo;
84 DispParams: TDispParams;
85 Status: HResult;
86begin
87 Result := disp <> nil;
88 if Result then
89 begin
90 PName := PWideChar(PropertyName);
91 if PName <> 'parentDocument' then
92 begin
93 if PropertyName = '' then
94 Result := DISPID_UNKNOWN
95 else
96 Disp.GetIDsOfNames(GUID_NULL, @PName, 1, GetThreadLocale, @DispID);
97 FillChar(DispParams, SizeOf(DispParams), 0);
98 Status := Disp.Invoke(DispID, GUID_NULL, 0, DISPATCH_PROPERTYGET, DispParams,
99 @Result, @ExcepInfo, nil);
100 if Status <> S_OK then
101 DispatchInvokeError(Status, ExcepInfo);
102 end;
103 end;
104end;
105
106procedure TIEGuid.GetPropertyList(const Obj: IDispatch; const S: TStrings);
107var
108 i: Integer;
109 TI: ITypeInfo;
110 TA: PTypeAttr;
111 FD: PFuncDesc;
112 aName: WideString;
113 vt: Integer;
114begin
115 OleCheck(Obj.GetTypeInfo(0, 0, TI));
116 OleCheck(TI.GetTypeAttr(TA));
117 for i := 0 to TA.cFuncs - 1 do
118 begin
119 OleCheck(TI.GetFuncDesc(i, FD));
120 if (FD.invkind = INVOKE_PROPERTYGET) then
121 begin
122 TI.GetDocumentation(FD.memid, @aName, nil, nil, nil);
123 vt := fd.elemdescFunc.tdesc.vt;
124 if (vt = VT_DISPATCH) or (vt = VT_PTR) then
125 S.add(aName);
126 end;
127 TI.ReleaseFuncDesc(FD);
128 end;
129 TI.ReleaseTypeAttr(TA);
130end;
131
132// Create list of .h-files in Headers directory
133
134function GetFileList(const Path: string; var FileList:
135 TStringList): Boolean;
136var
137 SearchRec: TSearchRec;
138 ff: Integer;
139begin
140 GetFileList := False;
141 ff := FindFirst(Path + '\*.*', faAnyFile, SearchRec);
142 if ff = 0 then
143 begin
144 GetFileList := True;
145 if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
146 begin
147 if (SearchRec.Attr and $10 <> $10)
148 then
149 if Pos('.h', SearchRec.Name) > 0 then
150 FileList.Add(Path + '\' + SearchRec.Name);
151 end;
152 repeat
153 ff := FindNext(SearchRec);
154 if ff = 0 then
155 begin
156 if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
157 begin
158 if (SearchRec.Attr and $10 <> $10) then
159 FileList.Add(Path + '\' + SearchRec.Name);
160 end;
161 end;
162 until ff <> 0;
163 end;
164end;
165
166function FindStr(S: string; I: Integer; Token: string): string;
167var
168 counter, t, t1, t2: Shortint;
169begin
170 S := Token + S + Token;
171 counter := 1;
172 t := 0;
173 while t < I do
174 begin
175 if Copy(S, counter, 1) = Token then
176 Inc(t);
177 inc(counter);
178 end;
179 t1 := counter;
180 if Copy(S, counter, 1) = token then
181 Result := ''
182 else
183 begin
184 Inc(Counter);
185 while Copy(S, counter, 1) <> Token do
186 Inc(counter);
187 t2 := counter - t1;
188 Result := copy(S, t1, t2);
189 end;
190end;
191
192function ExtractDefineGuid(GuidStr: string): string;
193var
194 o, Temp, s, G: string;
195 X: Integer;
196begin
197 GuidStr := Trim(StringReplace(GuidStr, ' ', '', [rfReplaceAll, rfIgnoreCase]));
198 Guidstr := Stringreplace(GuidStr, Chr($09), '', [rfReplaceAll]);
199 g := Copy(GuidStr, 13, Pos(',', GuidStr) - 13);
200 S := Uppercase(Copy(GuidStr, Pos('0x', GuidStr), 255));
201 S := Trim(StringReplace(S, ');', '', [rfReplaceAll, rfIgnoreCase]));
202 S := StringReplace(S, '0x', '', [rfReplaceAll, rfIgnoreCase]);
203 S := StringReplace(S, 'L', '', [rfReplaceAll, rfIgnoreCase]);
204 X := 1;
205 o := '';
206 repeat
207 Temp := Findstr(S, X, ',');
208 if (Length(Temp) = 1) or (Length(temp) = 3) or (Length(temp) = 7) then
209 o := o + '0' + temp
210 else
211 o := o + temp;
212 Inc(x);
213 until Temp = '';
214 s := o;
215 S := StringReplace(S, ',', '', [rfReplaceAll, rfIgnoreCase]);
216 s := Trim('{' + Copy(s, 1, 8) + '-' + Copy(S, 9, 4) + '-' + Copy(s, 13, 4) + '-' + Copy(s, 17, 4) + '-' + Copy(s, 21, 12) + '}');
217 if (Length(s) <> 38) or (Pos('name', g) > 0) or (Pos('DEFINE_', S) > 0) then
218 Result := ''
219 else
220 Result := g + '=' + S;
221end;
222
223//Extract GUIDS Registry: HKEY_CLASSES_ROOT\Interfaces
224
225procedure GetGuidsFromRegistry(Guids: TStringList);
226var
227 dwIndex: DWORD;
228 cb: Integer;
229 szIID: array[0..80] of char;
230 szvalue: array[0..256] of char;
231 hk: HKEY;
232 Str: string;
233begin
234 cb := SizeOf(szValue);
235 RegOpenKey(HKEY_CLASSES_ROOT, 'Interface', hk);
236 dwIndex := 0;
237 while RegEnumKey(hk, dwindex, szIID, SizeOf(szIID)) = ERROR_SUCCESS
238 do
239 begin
240 szValue := '';
241 RegQueryValue(hk, szIID, szvalue, cb);
242 if (szValue <> '') then
243 begin
244 str := string(szvalue) + '=' + szIID;
245 if Guids.IndexOf(str) = -1 then
246 Guids.Add(str);
247 end;
248 inc(dwIndex);
249 end;
250end;
251
252function CreateIEGuid(HeadersDir, GuidFile: string): Integer;
253var
254 files, lines, Guids: TStringlist;
255 S, n, g: string;
256 X, Fcounter, Lcounter: Integer;
257begin
258 Files := TStringlist.Create;
259 Lines := TStringlist.Create;
260 Guids := TStringlist.Create;
261 Guids.Sorted := True;
262 GetFileList(HeadersDir, Files);
263 for FCounter := 0 to Files.Count - 1 do
264 begin
265 Lines.LoadFromFile(Files[FCounter]);
266 for LCounter := 0 to Lines.Count - 1 do
267 begin
268 if Pos('MIDL_INTERFACE("', Lines[LCounter]) > 0 then
269 //(1) Extract GUIDS from MIDL_INTERFACE("... lines in header files
270 begin
271 g := UpperCase('{' + Copy(Trim(Lines[LCounter]), 17, 36) + '}');
272 n := Copy(Trim(Lines[LCounter + 1]), 1, 255);
273 if n = '' then
274 N := Copy(Trim(Lines[LCounter + 2]), 1, 255);
275 n := Copy(n, 1, Pos(' ', n) - 1);
276 S := n + '=' + g;
277 if (Guids.IndexOf(S) < 0) and (n <> '') then
278 Guids.Add(S);
279 end
280 else
281 if Pos('DEFINE_GUID(', Trim(Lines[LCounter])) = 1 then
282 begin
283 //(2) Extract GUIDS from DEFINE_GUID("... lines in header files
284 n := Lines[LCounter];
285 x := LCounter;
286 while (pos(');', n) = 0) and (x < lines.count) do
287 begin
288 Inc(x);
289 n := n + Lines[x];
290 end;
291 S := ExtractDefineGuid(n);
292 if s <> '' then
293 if Guids.IndexOf(s) < 0 then
294 Guids.Add(s);
295 end
296 else
297 if (pos('__declspec(uuid("', Lines[LCounter]) > 0) and (Pos(';', Lines[LCounter]) > 0) then
298 begin
299 // (3) Extract GUIDS from __declspec(uuid("... lines in header files
300 g := Copy(Lines[LCOunter], Pos('declspec(uuid("', Lines[LCounter]) + 15, 255);
301 n := '{' + Copy(G, 1, Pos('"', G) - 1) + '}';
302 g := Copy(g, Pos(' ', g), 255);
303 g := Trim(StringReplace(g, ';', '', [rfReplaceAll]));
304 S := g + '=' + Uppercase(n);
305 if Guids.IndexOf(S) < 0 then
306 Guids.Add(S);
307 end;
308 end;
309 end;
310 Files.Free;
311 Lines.Free;
312 GetGuidsFromRegistry(Guids);
313 Result := Guids.Count;
314 Guids.SaveToFile(GuidFile);
315 Guids.Free;
316end;
317
318function CreateIEList(GuidFile, Ielist: string): Integer;
319var
320 S: string;
321 i: Integer;
322 Temp: TStringlist;
323 Guids: TStringlist;
324begin
325 Temp := TStringlist.Create;
326 Guids := TStringlist.Create;
327 Guids.LoadFromFile(GuidFile);
328 for I := 0 to Guids.Count - 1 do
329 begin
330 s := Uppercase(Guids[i]);
331
332 if (pos('DISP', S) = 1) or (pos('HTML', S) = 1) or (pos('SID_', S) = 1) or
333 (pos('DWEB', S) = 1) or (pos('CGID', S) = 1) or ((pos('I', S) = 1) and (pos('IID_', S) = 0))
334 then
335 Temp.Add(Guids[i])
336 else
337 if (pos('IID_I', S) = 1) and (Guids.IndexOf(Copy(S, 5, 255)) = -1) then
338 Temp.add(copy(guids[i], 5, 255));
339
340 end;
341 if Temp.IndexOf('CGID_MSHTML={DE4BA900-59CA-11CF-9592-444553540000}') = -1 then
342 Temp.Add('CGID_MSHTML={DE4BA900-59CA-11CF-9592-444553540000}');
343
344 Temp.SaveToFile(IEList);
345 Result := Temp.Count;
346 Temp.Free;
347 Guids.Free;
348end;
349
350function TIEGuid.LoadList(Fname: string): Integer;
351var
352 X: Integer;
353 Temp: TStringlist;
354begin
355 Guids.Clear;
356 Names.Clear;
357 Temp := TStringlist.Create;
358 try
359 Temp.LoadFromFile(FName);
360 for x := 0 to Temp.Count - 1 do
361 begin
362 Guids.Add(Copy(Temp[x], Pos('=', Temp[x]) + 1, 255));
363 Names.Add(Copy(Temp[x], 1, Pos('=', Temp[x]) - 1));
364 end;
365 Result := Guids.Count;
366 finally
367 Temp.Free;
368 end;
369end;
370
371destructor TIEGuid.Destroy;
372begin
373 if Names <> nil then
374 Names.Free;
375 if Guids <> nil then
376 Guids.Free;
377 inherited;
378end;
379
380constructor TIEGuid.Create(const fname: string);
381begin
382 inherited Create;
383 if FileExists(fname) then
384 begin
385 Names := TStringlist.Create;
386 Guids := TStringlist.Create;
387 loadlist(Fname);
388 end;
389end;
390
391function TIEGuid.NameFromGuidStr(GuidStr: string): string;
392var
393 i: Integer;
394begin
395 i := Guids.IndexOf(GuidStr);
396 if i > -1 then
397 Result := Names[i]
398 else
399 Result := GuidStr;
400end;
401
402function TIEGuid.CopyToClipboard(GuidName: string): HResult;
403var
404 // s: string;
405 x: Integer;
406begin
407 x := Names.IndexOf(guidname);
408 if x > -1 then
409 begin
410 ClipBoard.SetTextBuf(Pchar(Names[x] + ' : TGUID = ''' + Guids[x] + ''';'));
411 Result := S_OK;
412 end
413 else
414 Result := S_FALSE;
415end;
416
417function TIEGuid.NameFromGuid(Guid: TGUID): string;
418var
419 s: string;
420 i: Integer;
421begin
422 s := GuidToString(Guid);
423 i := Guids.IndexOf(s);
424 if i > -1 then
425 Result := Names[i]
426 else
427 Result := S;
428end;
429
430function TIEGuid.GetServices(Unk: IUnknown; rsid: string; const S: TStrings): HResult;
431var
432 Isp: IServiceprovider;
433 x: Integer;
434 i: IUnknown;
435 G, N: string;
436begin
437 Result := S_FALSE;
438 x := Names.IndexOf(rsid);
439 if ((rsid <> '') and (x = -1)) or not Assigned(unk) then
440 Exit;
441 if x > -1 then
442 begin
443 G := Guids[x];
444 n := Names[x];
445 end;
446 if Succeeded(Unk.QueryInterface(IServiceprovider, isp))
447 then
448 for x := 0 to Guids.Count - 1 do
449 begin
450 if rsid = '' then
451 begin
452 G := Guids[x];
453 N := Names[x];
454 end;
455 try
456 if isp.QueryService(StringtoGuid(G), StringtoGuid(Guids[x]), i) = S_OK
457 then
458 S.Add(Names[x]);
459 except
460 ShowMessage('Invalid GUID: ' + Names[x]);
461 end;
462 Result := S_OK;
463 end;
464end;
465
466function TIEGuid.GetInterfaces(Unk: IUnknown;
467 const S: TStrings): HResult;
468var
469 i: IUnknown;
470 x: Integer;
471begin
472 Result := S_OK;
473 if not Assigned(unk) then
474 begin
475 Result := S_FALSE;
476 Exit;
477 end
478 else
479 for x := 0 to Guids.count - 1 do
480 try
481 if Succeeded(unk.QueryInterface(StringToGuid(Guids[x]), i)) then
482 S.Add(Names[x]);
483 except
484 ShowMessage('Invalid GUID: ' + Names[x]);
485 end;
486end;
487
488function TIEGuid.GetInterfacesEx(Unk: IUnknown;
489 const S: TStrings; ShowIUnknown, ShowIDispatch, ShowIDispatchEx, ShowDispinterfaces: Boolean): HResult;
490var
491 I: IUnknown;
492 // Show: Boolean;
493 x: Integer;
494begin
495 Result := S_OK;
496 if not Assigned(unk) then
497 begin
498 Result := S_FALSE;
499 Exit;
500 end
501 else
502 for x := 0 to Guids.count - 1 do
503 try
504 if Succeeded(unk.QueryInterface(StringToGuid(Guids[x]), i)) then
505 if ((not ShowIdispatch and (UpperCase(Names[x]) = 'IDISPATCH')) or
506 (not ShowIdispatchEx and (UpperCase(Names[x]) = 'IDISPATCHEX')) or
507 (not ShowIUnknown and (UpperCase(Names[x]) = 'IUNKNOWN'))) or
508 (not ShowDispInterfaces and (Pos('DISP', UpperCase(Names[x])) = 1)) then
509 else
510 S.Add(Names[x]);
511 except
512 ShowMessage('Invalid GUID for: ' + Names[x]);
513 end;
514end;
515
516function TIEGuid.GetConnectionPoints(Unk: IUnknown; const S: TStrings; ShowIDispatch: Boolean): HResult;
517var
518 IID: TGuid;
519 CPC: IConnectionPointContainer;
520 iecp: IEnumConnectionPoints;
521 cp: IConnectionPoint;
522 Fetched: Integer;
523begin
524 Result := S_FALSE;
525 if Assigned(unk) then
526 begin
527 if Succeeded(Unk.QueryInterface(IConnectionPointContainer, CPC)) then
528 begin
529 CPC.EnumConnectionPoints(iecp);
530 iecp.Next(1, cp, @Fetched);
531 repeat
532 cp.GetConnectionInterface(iid);
533 if (Uppercase(NameFromGuid(IID)) = 'IDISPATCH') and not ShowIdispatch
534 then else
535 S.Add(NameFromGuid(IID));
536 iecp.Next(1, cp, @Fetched);
537 until fetched = 0;
538 Result := S_OK
539 end;
540 end;
541end;
542
543end.
544
Note: See TracBrowser for help on using the repository browser.