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