source: cprs/branches/tmg-cprs/CPRS-Chart/TMG_Extra/HTMLEdit/EwbCoreTools.pas@ 1493

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

TMG Ver 1.1 Added HTML Support, better demographics editing

File size: 11.4 KB
Line 
1//*************************************************************
2// EwbCoreTools *
3// *
4// Freeware Unit *
5// For Delphi *
6// Developing Team: *
7// Serge Voloshenyuk (SergeV@bsalsa.com) *
8// Eran Bodankin (bsalsa) -(bsalsa@gmail.com) *
9// *
10// Documentation and updated versions: *
11// *
12// http://www.bsalsa.com *
13//*************************************************************
14{LICENSE:
15THIS SOFTWARE IS PROVIDED TO YOU "AS IS" WITHOUT WARRANTY OF ANY KIND,
16EITHER EXPRESSED OR IMPLIED INCLUDING BUT NOT LIMITED TO THE APPLIED
17WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
18YOU ASSUME THE ENTIRE RISK AS TO THE ACCURACY AND THE USE OF THE SOFTWARE
19AND ALL OTHER RISK ARISING OUT OF THE USE OR PERFORMANCE OF THIS SOFTWARE
20AND DOCUMENTATION. BSALSA PRODUCTIONS DOES NOT WARRANT THAT THE SOFTWARE IS ERROR-FREE
21OR WILL OPERATE WITHOUT INTERRUPTION. THE SOFTWARE IS NOT DESIGNED, INTENDED
22OR LICENSED FOR USE IN HAZARDOUS ENVIRONMENTS REQUIRING FAIL-SAFE CONTROLS,
23INCLUDING WITHOUT LIMITATION, THE DESIGN, CONSTRUCTION, MAINTENANCE OR
24OPERATION OF NUCLEAR FACILITIES, AIRCRAFT NAVIGATION OR COMMUNICATION SYSTEMS,
25AIR TRAFFIC CONTROL, AND LIFE SUPPORT OR WEAPONS SYSTEMS. BSALSA PRODUCTIONS SPECIFICALLY
26DISCLAIMS ANY EXPRESS OR IMPLIED WARRANTY OF FITNESS FOR SUCH PURPOSE.
27
28You may use/ change/ modify the component under 3 conditions:
291. In your website, add a link to "http://www.bsalsa.com"
302. In your application, add credits to "Embedded Web Browser"
313. Mail me (bsalsa@gmail.com) any code change in the unit for the benefit
32 of the other users.
334. Please, consider donation in our web site!
34{*******************************************************************************}
35
36
37unit EwbCoreTools;
38
39{$I EWB.inc}
40
41interface
42
43uses
44 Graphics, ActiveX, Mshtml_Ewb, Windows, SysUtils;
45
46function IsWinXPSP2OrLater(): Boolean;
47function ColorToHTML(const Color: TColor): string;
48function WideStringToLPOLESTR(const Source: Widestring): POleStr;
49function XPath4Node(node: IHTMLElement): string;
50function TaskAllocWideString(const S: string): PWChar;
51function AnsiIndexStr(const AText: string; const AValues: array of string): Integer;
52function GetPos(const SubSt, Text: string; StartPos: Integer = -1): Integer;
53function _CharPos(const C: Char; const S: string): Integer;
54function CutString(var Text: string; const Delimiter: string = ' ';
55 const Remove: Boolean = True): string;
56procedure FormatPath(Path: string);
57function GetWinText(WinHandle: THandle): string;
58function GetWinClass(Handle: Hwnd): WideString;
59function GetParentWinByClass(ChildHandle: HWND; const ClassName: string): HWND;
60{$IFDEF DELPHI5}
61function DirectoryExists(const Directory: string): Boolean;
62function VarSupports(const V: Variant; const IID: TGUID; out Intf): Boolean;
63{$ENDIF}
64{$IFNDEF DELPHI12_UP}
65function CharInSet(C: Char; const CharSet: TSysCharSet): Boolean;
66{$ENDIF}
67function AddBackSlash(const S: string): string;
68
69const
70 WM_SETWBFOCUS = $0400 {WM_USER} + $44;
71
72implementation
73
74uses
75 IeConst, EwbAcc;
76
77type
78 {VerifyVersion}
79 fn_VerifyVersionInfo = function(var VersionInformation: OSVERSIONINFOEX;
80 dwTypeMask: DWORD; dwlConditionMask: LONGLONG): BOOL; stdcall;
81 fn_VerSetConditionMask = function(ConditionMask: LONGLONG; TypeMask: DWORD;
82 Condition: Byte): LONGLONG; stdcall;
83
84
85function IsWinXPSP2OrLater(): Boolean;
86var
87 osvi: TOSVersionInfoEx;
88 dwlConditionMask: LONGLONG;
89 op: Integer;
90 hlib: THandle;
91 VerifyVersionInfo: fn_VerifyVersionInfo;
92 VerSetConditionMask: fn_VerSetConditionMask;
93begin
94 Result := False;
95 hLib := GetModuleHandle('kernel32.dll');
96 if hLib = 0 then
97 hLib := LoadLibrary('kernel32.dll');
98 if (hLib <> 0) then
99 begin
100 @VerifyVersionInfo := GetProcAddress(hLib, 'VerifyVersionInfoA');
101 @VerSetConditionMask := GetProcAddress(hLib, 'VerSetConditionMask');
102 if ((@VerifyVersionInfo = nil) or (@VerSetConditionMask = nil)) then Exit;
103
104 dwlConditionMask := 0;
105 op := VER_GREATER_EQUAL;
106
107 // Initialize the OSVERSIONINFOEX structure.
108 ZeroMemory(@osvi, SizeOf(OSVERSIONINFOEX));
109 osvi.dwOSVersionInfoSize := SizeOf(OSVERSIONINFOEX);
110 osvi.dwMajorVersion := 5;
111 osvi.dwMinorVersion := 1;
112 osvi.wServicePackMajor := 2;
113 osvi.wServicePackMinor := 0;
114
115 // Initialize the condition mask.
116 dwlConditionMask := VerSetConditionMask(dwlConditionMask, VER_MAJORVERSION, op);
117 dwlConditionMask := VerSetConditionMask(dwlConditionMask, VER_MINORVERSION, op);
118 dwlConditionMask := VerSetConditionMask(dwlConditionMask, VER_SERVICEPACKMAJOR, op);
119 dwlConditionMask := VerSetConditionMask(dwlConditionMask, VER_SERVICEPACKMINOR, op);
120
121 // Perform the test.
122 Result := VerifyVersionInfo(osvi, VER_MAJORVERSION or VER_MINORVERSION or
123 VER_SERVICEPACKMAJOR or VER_SERVICEPACKMINOR, dwlConditionMask);
124 end;
125end;
126
127function GetParentWinByClass(ChildHandle: HWND; const ClassName: string): HWND;
128var
129 szClass: array[0..255] of Char;
130begin
131 Result := GetParent(ChildHandle);
132 while IsWindow(Result) do
133 begin
134 if (GetClassName(Result, szClass, SizeOf(szClass)) > 0) and
135 (AnsiStrComp(PChar(ClassName), szClass) = 0) then Exit;
136 Result := GetParent(Result);
137 end;
138end;
139
140
141
142{$IFNDEF DELPHI12_UP}
143
144function CharInSet(C: Char; const CharSet: TSysCharSet): Boolean;
145begin
146 Result := C in CharSet;
147end;
148{$ENDIF}
149
150{$IFDEF DELPHI5}
151
152function DirectoryExists(const Directory: string): Boolean;
153var
154 Code: Integer;
155begin
156{$RANGECHECKS OFF}
157 Code := GetFileAttributes(PChar(Directory));
158 Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
159{$RANGECHECKS ON}
160end;
161
162function VarSupports(const V: Variant; const IID: TGUID; out Intf): Boolean;
163begin
164 Result := Supports(V, IID, Intf);
165end;
166{$ENDIF}
167
168function AddBackSlash(const S: string): string;
169begin
170{$IFDEF DELPHI5}
171 Result := IncludeTrailingBackslash(S);
172{$ELSE}
173{$IFDEF DELPHI6UP}
174 Result := IncludeTrailingPathDelimiter(S);
175{$ELSE}
176 if Copy(S, Length(S), 1) = '\' then
177 Result := S
178 else
179 Result := S + '\';
180{$ENDIF}
181{$ENDIF}
182end;
183
184function CutString(var Text: string; const Delimiter: string = ' ';
185 const Remove: Boolean = True): string;
186var
187 IdxPos: Integer;
188begin
189 if Delimiter = #0 then
190 IdxPos := Pos(Delimiter, Text)
191 else
192 IdxPos := AnsiPos(Delimiter, Text);
193
194 if (IdxPos = 0) then
195 begin
196 Result := Text;
197 if Remove then
198 Text := '';
199 end
200 else
201 begin
202 Result := Copy(Text, 1, IdxPos - 1);
203 if Remove then
204 Delete(Text, 1, IdxPos + Length(Delimiter) - 1);
205 end;
206end;
207
208
209function GetPos(const SubSt, Text: string; StartPos: Integer = -1): Integer;
210var
211 i: Integer;
212 LStartPos: Integer;
213 LTokenLen: Integer;
214begin
215 result := 0;
216 LTokenLen := Length(SubSt);
217 if StartPos = -1 then
218 begin
219 StartPos := Length(Text);
220 end;
221 if StartPos < (Length(Text) - LTokenLen + 1) then
222 begin
223 LStartPos := StartPos;
224 end
225 else
226 begin
227 LStartPos := (Length(Text) - LTokenLen + 1);
228 end;
229 for i := LStartPos downto 1 do
230 begin
231 if AnsiSameText(Copy(Text, i, LTokenLen), SubSt) then
232 begin
233 Result := i;
234 Break;
235 end;
236 end;
237end;
238
239function _CharPos(const C: Char; const S: string): Integer;
240begin
241 for Result := 1 to Length(S) do
242 if S[Result] = C then Exit;
243 Result := 0;
244end;
245
246procedure FormatPath(Path: string);
247var
248 i: Integer;
249begin
250 i := 1;
251 while i <= Length(Path) do
252 begin
253 if CharInSet(Path[i], LeadBytes) then
254 Inc(i, 2)
255 else
256 if Path[i] = '\' then
257 begin
258 Path[i] := '/';
259 Inc(i, 1);
260 end
261 else
262 Inc(i, 1);
263 end;
264end;
265
266function AnsiIndexStr(const AText: string; const AValues: array of string): Integer;
267var
268 I: Integer;
269begin
270 Result := -1;
271 for I := Low(AValues) to High(AValues) do
272 if AnsiSameStr(AText, AValues[I]) then
273 begin
274 Result := I;
275 Break;
276 end;
277end;
278
279
280function TaskAllocWideString(const S: string): PWChar;
281var
282 WideLength: integer;
283 Wide: PWideChar;
284begin
285 WideLength := Length(S) + 1;
286 Wide := CoTaskMemAlloc(WideLength * SizeOf(WideChar));
287 StringToWideChar(S, Wide, WideLength);
288 Result := Wide;
289end;
290
291{
292function TaskAllocWideString(const S: string): PWChar;
293var
294 Len: Integer;
295begin
296 Len := Length(S) + 1;
297 Result := CoTaskMemAlloc(2 * Len);
298 StringToWideChar(S, Result, Len);
299end;
300}
301
302function WideStringToLPOLESTR(const Source: Widestring): POleStr;
303var
304 Len: Integer;
305begin
306 Len := Length(Source) * SizeOf(WideChar);
307 Result := CoTaskMemAlloc(Len + 2);
308 FillChar(Result^, Len + 2, 0);
309 Move(Result^, PWideString(Source)^, Len);
310end;
311
312function ColorToHTML(const Color: TColor): string;
313var
314 ColorRGB: LongWord;
315begin
316 ColorRGB := ColorToRGB(Color);
317 FmtStr(Result, '#%0.2X%0.2X%0.2X',
318 [Byte(ColorRGB), Byte(ColorRGB shr 8), Byte(ColorRGB shr 16)]);
319end;
320
321function GetWinText(WinHandle: THandle): string;
322var
323 DlgName: string;
324 TxtLength: Integer;
325begin
326 TxtLength := GetWindowTextLength(WinHandle);
327 SetLength(DlgName, TxtLength + 1);
328 GetWindowText(WinHandle, PChar(DlgName), TxtLength + 1);
329 Result := DlgName;
330end;
331
332
333function GetWinClass(Handle: Hwnd): WideString;
334var
335 pwc: PWideChar;
336const
337 maxbufsize = 32767 * SizeOf(WideChar);
338begin
339 Result := '';
340 if IsWindow(Handle) then
341 begin
342 pwc := GetMemory(maxbufsize);
343 if Assigned(pwc) then
344 try
345 ZeroMemory(pwc, maxbufsize);
346 if GetClassnameW(Handle, pwc, maxbufsize) > 0 then
347 SetString(Result, pwc, lstrlenW(pwc));
348 finally
349 FreeMemory(pwc);
350 end;
351 end;
352end;
353
354{
355function GetWinClass(WinHandle: THANDLE): string;
356begin
357 SetLength(Result, 80);
358 SetLength(Result, GetClassName(WinHandle, PChar(Result), Length(Result)));
359end;
360}
361
362
363function XPath4Node(node: IHTMLElement): string;
364
365 function NodePosition(elem: IHTMLElement): string;
366 var tag: Widestring;
367 Idx: Integer;
368 n: IHTMLElement;
369 cl: IHTMLElementCollection;
370 itm: IDispatch;
371 I, C, mI: Integer;
372 begin
373 Result := '';
374 if (elem.parentElement = nil) or
375 not Supports(elem.parentElement.children, IHTMLElementCollection, cl) then Exit;
376
377 Tag := elem.tagName;
378 Idx := elem.sourceIndex;
379 C := 0;
380 mI := -1;
381
382 for I := 0 to cl.length - 1 do
383 begin
384 itm := cl.item(I, I);
385 if Supports(itm, IHTMLElement, n) then
386 begin
387 if n.tagName = Tag then
388 begin
389 if n.sourceIndex = Idx then mI := C;
390 Inc(C);
391 end;
392 end;
393 end;
394 if (mI > 0) or (C > 1) then Result := Format('[%d]', [mI]);
395 end;
396
397var id: string;
398begin
399 if node <> nil then
400 begin
401 id := node.id;
402 if id <> '' then
403 Result := Format('%s[@id="%s"]', [node.tagName, id])
404 else if node.parentElement = nil then
405 Result := '/' + node.tagName
406 else Result := Format('%s/%s%s',
407 [XPath4Node(node.parentElement), node.tagName, NodePosition(node)]);
408 end else Result := '';
409end;
410
411end.
Note: See TracBrowser for help on using the repository browser.