source: cprs/branches/tmg-cprs/CPRS-Chart/TMG_Extra/HTMLEdit/EmbeddedED/KS_Lib.pas@ 1139

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

TMG Ver 1.1 Added HTML Support, better demographics editing

File size: 10.0 KB
Line 
1{ ******************************************** }
2{ KS_lib ver 1.11 (Jan. 19, 2004) }
3{ }
4{ For Delphi 4, 5 and 6 }
5{ }
6{ Copyright (C) 1999-2003, Kurt Senfer. }
7{ All Rights Reserved. }
8{ }
9{ Support@ks.helpware.net }
10{ }
11{ Documentation and updated versions: }
12{ }
13{ http://KS.helpware.net }
14{ }
15{ ******************************************** }
16{
17 This library is free software; you can redistribute it and/or
18 modify it under the terms of the GNU Lesser General Public
19 License as published by the Free Software Foundation; either
20 version 2.1 of the License, or (at your option) any later version.
21
22 This library is distributed in the hope that it will be useful,
23 but WITHOUT ANY WARRANTY; without even the implied warranty of
24 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
25 Lesser General Public License for more details.
26
27 You should have received a copy of the GNU Lesser General Public
28 License along with this library; if not, write to the Free Software
29 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
30}
31
32
33unit KS_lib;
34
35 {$I KSED.INC} //Compiler version directives
36
37interface
38
39uses
40 Windows, Messages, SysUtils, Classes, Controls,
41 //ktMSHTML_TLB,
42 MSHTML_EWB,
43 Activex;
44
45 procedure SafeYield;
46
47 //function GetDocTypeTag(DOC: IHTMLDocument2): String;
48 function GetHTMLtext(DOC: IHTMLDocument2): String;
49 function GetDocHTML(DOC: IHTMLDocument2): String;
50 function IsFilePath(Url: String; var FilePath: string): HResult;
51 function GetParentElemetType(aTag: IHTMLElement; aType: string; var ParentElement: IHTMLElement): boolean;
52
53const
54 aFilter: string = 'HTML file (*.htm / *.html)|*.htm;*.html|All Files|*.*';
55 AboutBlank: string = 'about:blank';
56 cNormal: String = 'Normal';
57 //cDIV : String = 'DIV';
58 cBODY: string = 'BODY';
59 cTABLE: string = 'TABLE';
60 cTD: string = 'TD';
61 cTH: string = 'TH';
62 cTR: string = 'TR';
63
64
65var
66 FLastError: String;
67
68type
69 CmdID = TOleEnum;
70
71implementation
72
73uses {$IFDEF D6D7} variants, {$ENDIF} AXCtrls, KS_Procs;
74
75
76//------------------------------------------------------------------------------
77function GetParentElemetType(aTag: IHTMLElement; aType: string; var ParentElement: IHTMLElement): boolean;
78begin
79 result := false;
80
81 ParentElement := aTag;
82 if assigned(ParentElement)
83 then begin
84 while (not AnsiSameText(ParentElement.tagName, aType)) and
85 (not SameText(ParentElement.tagName, cBODY)) do
86 begin
87 ParentElement := ParentElement.parentElement;
88 if not assigned(ParentElement)
89 then exit;
90 end;
91
92 result := AnsiSameText(ParentElement.tagName, aType);
93 end;
94
95end;
96//------------------------------------------------------------------------------
97function IsFilePath(Url: String; var FilePath: string): HResult;
98
99 //-----------------------------------------------------
100 function IsFilePath(URN: string): HResult;
101 begin
102 if (length(URN) > 0) and ((copy(URN, 1, 2) = '\\') or (URN[2] = ':'))
103 then begin
104 result := S_OK;
105 FilePath := URN;
106 end
107 else result := S_FALSE;
108 end;
109 //-----------------------------------------------------
110begin
111 //asm int 3 end; //trap
112 { we can have a file path:
113 file://sie01/ksdata/kvalsys/..... or
114 file:///G:/kvalsys/......
115 or a http path and other posibilitys }
116
117 //IsValidURL
118 //CoInternetParseUrl
119 //if(IsValidURL(nil,PWideChar(WideString(aUrl)),0)=S_OK)
120
121 //asm int 3 end; //trap
122
123 result := IsFilePath(URL);
124 if result = S_OK
125 then exit;
126
127 result := S_false;
128
129 if Pos('file:', LowerCase(URL)) = 1
130 then begin
131 FilePath := Copy(URL, 6, Length(URL));
132 if FilePath[1] = '/'
133 then FilePath := StringReplace(FilePath, '/', '\', [rfReplaceAll])
134 else if FilePath[1] <> '\'
135 then exit; //somthings rotten
136
137 if Copy(FilePath, 1, 3) = '\\\' //we have a drive letter type path
138 then delete(FilePath, 1, 3);
139
140 (*
141 //we have to get ried of the first tree \
142 for I := 1 to 3 do
143 Delete(FilePath, 1, pos('\', FilePath));
144 *)
145 result := IsFilePath(FilePath);
146 end;
147end;
148//------------------------------------------------------------------------------
149procedure SafeYield;
150// Make room for other processes
151var
152 Msg : TMsg;
153begin
154 //asm int 3 end; //trap - not used
155 if PeekMessage(Msg, 0, 0, 0, PM_REMOVE)
156 then begin
157 if Msg.Message = wm_Quit
158 then PostQuitMessage(Msg.WParam) //Tell main message loop to terminate
159 else begin
160 TranslateMessage(Msg);
161 DispatchMessage(Msg);
162 end;
163 end;
164end;
165//------------------------------------------------------------------------------
166function GetDocTypeTag(DOC: IHTMLDocument2): String;
167var
168 aElementCollection: IHTMLElementCollection;
169 HTMLElement: IHTMLElement;
170begin
171 //get the <!DOCTYPE tag as the first tag in a collection
172 aElementCollection := (DOC as IHTMLDocument3).getElementsByTagName('!') as IHTMLElementCollection;
173 if aElementCollection.Length > 0
174 then begin
175 HTMLElement := aElementCollection.item(0, null) as IHTMLElement;
176 if (HTMLElement <> Nil) and
177 (pos('<!DOCTYPE', HTMLElement.OuterHTML) = 1)
178 then Result := HTMLElement.OuterHTML
179 else Result := ''; //no <!DOCTYPE tag in this document
180 end
181 else Result := ''; //no <!DOCTYPE tag in this document
182
183end;
184//------------------------------------------------------------------------------
185function GetHTMLtext(DOC: IHTMLDocument2): String;
186//GetHTMLtext takes app. 80 millisec. and GetDocumentHTML app. 70 milisec.
187var
188 aElementCollection: IHTMLElementCollection;
189 HTMLElement: IHTMLElement;
190begin
191 //asm int 3 end; //trap
192
193 if DOC = nil
194 then begin
195 result := '';
196 exit;
197 end;
198
199 //first get the <!DOCTYPE tag - if any
200 result := GetDocTypeTag(DOC);
201
202
203 //get the HTML tag (as a collection of one element)
204 aElementCollection := (DOC as IHTMLDocument3).getElementsByTagName('HTML') as IHTMLElementCollection;
205 if aElementCollection.Length = 1
206 then begin
207 HTMLElement := aElementCollection.item(0, null) as IHTMLElement;
208 if HTMLElement <> Nil
209 //add the HTML tag to the <!DOCTYPE tag (if any)
210 then Result := Result + HTMLElement.OuterHTML
211 else Result := ''; //this is wrong
212 end
213 else Result := ''; //this is wrong
214end;
215//------------------------------------------------------------------------------
216function GetDocHTML(DOC: IHTMLDocument2): String;
217//GetHTMLtext takes app. 80 millisec. and GetDocumentHTML app. 70 milisec.
218
219var
220 aStream: TStringStream;
221 P: PWideChar;
222begin
223 //asm int 3 end; //trap
224
225 if DOC = nil
226 then Result := ''
227 else begin
228 aStream := TStringStream.Create('');
229 try
230
231 { PersistStream.save returns the DHTML tree in the last rendered version
232 Non visible changes isent nessasarely returned
233 PersistFile.Save always returns a rendered document }
234
235 //ForceRendering;
236 //PersistStream.save(TStreamAdapter.Create(AStream), false);
237 //result := aStream.DataString;
238 //S := GetHTMLtext;
239 //waitWhileDocIsBusy;
240 //InsertNewTag2(Doc);
241
242 //waitWhileDocIsBusy;
243 //result := aStream.DataString;
244 //aStream.free;
245 //aStream := TStringStream.Create('');
246
247 (*
248 I := GetTickCount;
249
250 CmdSet(IDM_PERSISTSTREAMSYNC);
251 i := GetTickCount -i;
252 *)
253
254
255 if S_OK = (DOC as IPersistStreamInit).save(TStreamAdapter.Create(AStream), false)
256 then begin
257 //WaitForDocComplete;
258 {this is what DHTMLEDIT does when it is not in preserve Source mode }
259 if aStream.Size = 0 //just in case
260 then begin
261 result := '';
262 exit;
263 end;
264
265 if aStream.DataString[1] = '<'
266 then result := aStream.DataString
267 else begin
268 P := PWideChar(@aStream.DataString[1]) ;
269 result := OleStrToString(P);
270
271 //the aStream.DataString returns a ? in front of the source
272 if (Length(result) > 0) and (Result[1] <> '<')
273 then delete(Result, 1, 1);
274 end;
275 end;
276 finally
277 aStream.free;
278 end;
279 end;
280end;
281//------------------------------------------------------------------------------
282Function ReadRegString(MainKey: HKey; SubKey, ValName: String): String;
283 // NB default value is read if subkey isent ended with a backslash
284Var
285 Key: HKey;
286 C: Array[0..1023] of Char;
287 D: Cardinal; //value type
288 D2: Cardinal; //buffer size
289Begin
290 //asm int 3 end; //trap
291 result := '';
292
293 if RegOpenKeyEx(MainKey, Pchar(NoEndBackSlash(SubKey)), 0, KEY_READ, Key) = ERROR_SUCCESS
294 then begin
295 try
296 C := '';
297 D2 := SizeOf(C);
298 if (RegQueryValueEx(Key, Pchar(ValName), Nil, @D, @C, @D2) = ERROR_SUCCESS) and
299 ((D = REG_EXPAND_SZ) or (D = REG_SZ))
300 then result := C
301 else result := '';
302 finally
303 RegCloseKey(Key);
304 end;
305 end;
306End;
307//------------------------------------------------------------------------------
308end.
Note: See TracBrowser for help on using the repository browser.