1 | { ******************************************** }
|
---|
2 | { KS_Procs ver 1.2 (Jan. 16, 2004) }
|
---|
3 | { }
|
---|
4 | { For Delphi 4, 5 and 6 }
|
---|
5 | { }
|
---|
6 | { Copyright (C) 1999-2004, 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 | unit KS_Procs;
|
---|
33 |
|
---|
34 | interface
|
---|
35 |
|
---|
36 | uses
|
---|
37 | Windows, ShellAPI, Messages, SysUtils, math, classes ;
|
---|
38 |
|
---|
39 | Var
|
---|
40 | ActualAppName: string = '';
|
---|
41 | ShowDeveloperMessages: boolean = false;
|
---|
42 | DeveloperMessagesCanceled: boolean = false;
|
---|
43 | DeveloperMessagesLog: string = '';
|
---|
44 | ActualWinDir: string = '';
|
---|
45 |
|
---|
46 | const
|
---|
47 | NoShowError: Boolean = False; // NoShowError, NoCache, NoHtmlFile
|
---|
48 | ShowError: Boolean = true;
|
---|
49 | NoCache: Boolean = true;
|
---|
50 | NoHtmlFile: Boolean = true;
|
---|
51 |
|
---|
52 | const
|
---|
53 | { several important ASCII codes }
|
---|
54 | // NULL = #0;
|
---|
55 | BACKSPACE = #8;
|
---|
56 | TAB = #9;
|
---|
57 | LF = #10;
|
---|
58 | CR = #13;
|
---|
59 | EOF_ = #26;
|
---|
60 | ESC = #27;
|
---|
61 | Space = #32;
|
---|
62 | BlackSpace = [#33..#255];
|
---|
63 | CrLf: String = #13+#10;
|
---|
64 | DblCrLf: String = #13+#10+#13+#10;
|
---|
65 |
|
---|
66 | const
|
---|
67 | { digits as chars }
|
---|
68 | ZERO = '0';
|
---|
69 | ONE = '1';
|
---|
70 | TWO = '2';
|
---|
71 | THREE = '3';
|
---|
72 | FOUR = '4';
|
---|
73 | FIVE = '5';
|
---|
74 | SIX = '6';
|
---|
75 | SEVEN = '7';
|
---|
76 | EIGHT = '8';
|
---|
77 | NINE = '9';
|
---|
78 | DIGITS: set of Char = [ZERO..NINE];
|
---|
79 |
|
---|
80 | cSilent: boolean = true;
|
---|
81 | cNotSilent: boolean = false;
|
---|
82 |
|
---|
83 |
|
---|
84 | type
|
---|
85 | TMonth = (NoneMonth, January, February, March, April, May, June, July,
|
---|
86 | August, September, October, November, December);
|
---|
87 |
|
---|
88 | type
|
---|
89 | TDayOfWeek = (Sunday, Monday, Tuesday, Wednesday, Thursday, Friday, Saturday);
|
---|
90 |
|
---|
91 | type
|
---|
92 | TBit = 0..31;
|
---|
93 |
|
---|
94 | type
|
---|
95 | TFileTimeComparision = (ftError, ftFileOneIsOlder, ftFileTimesAreEqual, ftFileTwoIsOlder);
|
---|
96 |
|
---|
97 | type
|
---|
98 | TTimeOfWhat = (ftCreationTime, ftLastAccessTime, ftLastWriteTime);
|
---|
99 |
|
---|
100 | type
|
---|
101 | TDriveType = (dtUnknown, dtNoDrive, dtFloppy, dtFixed, dtNetwork, dtCDROM, dtRAM);
|
---|
102 |
|
---|
103 |
|
---|
104 | type
|
---|
105 | TVolumeInfo = record
|
---|
106 | Name: string;
|
---|
107 | SerialNumber: DWORD;
|
---|
108 | MaxComponentLength: DWORD;
|
---|
109 | FileSystemFlags: DWORD;
|
---|
110 | FileSystemName: string;
|
---|
111 | end; // TVolumeInfo
|
---|
112 |
|
---|
113 | type
|
---|
114 | PFixedFileInfo = ^TFixedFileInfo;
|
---|
115 | TFixedFileInfo = record
|
---|
116 | dwSignature: Cardinal;
|
---|
117 | dwStrucVersion: Cardinal;
|
---|
118 | wFileVersionMS: WORD; // Minor Version
|
---|
119 | wFileVersionLS: WORD; // Major Version
|
---|
120 | wProductVersionMS: WORD; // Build Number
|
---|
121 | wProductVersionLS: WORD; // Release Version
|
---|
122 | dwFileFlagsMask: Cardinal;
|
---|
123 | dwFileFlags: Cardinal;
|
---|
124 | dwFileOS: Cardinal;
|
---|
125 | dwFileType: Cardinal;
|
---|
126 | dwFileSubtype: Cardinal;
|
---|
127 | dwFileDateMS: Cardinal;
|
---|
128 | dwFileDateLS: Cardinal;
|
---|
129 | end; // TFixedFileInfo
|
---|
130 |
|
---|
131 | procedure KSProcessMessages;
|
---|
132 | procedure KSWait(aTime: Cardinal);
|
---|
133 |
|
---|
134 | function CopyCursor(cur: HCURSOR): HCURSOR;
|
---|
135 | function _GetExeOpen(const Ext: string; var Exefil: string; sielent: boolean = true): Boolean;
|
---|
136 | Function GetModuleName(aFile: string = ''): String;
|
---|
137 | Function GetFileDateTime(aFile: string): String;
|
---|
138 | Function GetShortDateTime(aTime: TDateTime; Seconds: boolean = false): String;
|
---|
139 | function GetAbsolutePath(ActualPath: string; var RelativePath: string): boolean;
|
---|
140 | function KSMessage(aMessage: string; aBoxHead: string; Params: integer): integer;
|
---|
141 | function KSQuestion(aMessage: string; aBoxHead: string = ''; Params: integer = MB_ICONQUESTION or MB_YESNO): integer;
|
---|
142 | Procedure KSMessageW(aMessage: string; aBoxHead: string = '');
|
---|
143 | Procedure KSMessageE(aMessage: string; aBoxHead: string = '');
|
---|
144 | Procedure KSMessageQ(aMessage: string; aBoxHead: string = '');
|
---|
145 | Procedure KSMessageI(aMessage: string; aBoxHead: string = '');
|
---|
146 | Procedure KSMessageT(aMessage: string; aBoxHead: string = '');
|
---|
147 | procedure DeveloperMessage(aMessage: string);
|
---|
148 | function CloseDeveloperMessagesLog(afile: string): boolean;
|
---|
149 | function SaveDeveloperMessagesLog(afile: string): boolean;
|
---|
150 | procedure OpenDeveloperMessagesLog;
|
---|
151 |
|
---|
152 | function IsAlNum(C: char): bool;
|
---|
153 | function RegisterAxLib(FileName: string; Unreg: Boolean = False): boolean;
|
---|
154 | procedure SearchForFiles(path, mask: AnsiString; var Value: TStringList; Recurse: Boolean = False);
|
---|
155 |
|
---|
156 | function StringIsInteger(Const S: String): boolean;
|
---|
157 | function _StringIsInteger(Const S: String; var I: Integer): boolean;
|
---|
158 | function KSDelete(var S: String; DeleteString: String; All: Boolean = False): boolean;
|
---|
159 | {Deletes one or more instances of S}
|
---|
160 |
|
---|
161 | function GetFileDateAsString(aFile: string): String;
|
---|
162 | function DosLocalTimeToDosUTCTime(aDosFileTime: Integer): Integer;
|
---|
163 | function GetUTCFileDateAsString(aFile: string): String;
|
---|
164 | function UTCFileAge(const FileName: string): Integer;
|
---|
165 | function KSSetCurrentDir(const Dir: string): Boolean;
|
---|
166 | function KSEmptyDir( aDir: string): Boolean;
|
---|
167 | function DelDir(aDir: string): boolean;
|
---|
168 | function Squish(const Search: string): string;
|
---|
169 | {squish() returns a string with all whitespace not inside single
|
---|
170 | quotes deleted.}
|
---|
171 | function Before(const Search, Find: string): string;
|
---|
172 | {before() returns everything before the first occurance of Find
|
---|
173 | in Search. If Find does not occur in Search, Search is returned.}
|
---|
174 | function beforeX(const Search, Find: string): string;
|
---|
175 | {before() returns everything before the first occurance of Find
|
---|
176 | in Search. If Find does not occur in Search, An empty string is returned.}
|
---|
177 | function After(const Search, Find: string): string;
|
---|
178 | {after() returns everything after the first occurance of Find
|
---|
179 | in Search. If Find does not occur in Search, a null string is returned.}
|
---|
180 | function RPos(const Find, Search: string): Integer;
|
---|
181 | {RPos() returns the index of the first character of the last occurance
|
---|
182 | of Find in Search. Returns 0 if Find does not occur in Search.
|
---|
183 | Like Pos() but searches in reverse.}
|
---|
184 |
|
---|
185 | function LastChar(const Search: string; const Find: char): Integer;
|
---|
186 | {LastChar() returns the index of the last character of Find in Search.
|
---|
187 | Returns 0 if Find does not occur in Search.}
|
---|
188 |
|
---|
189 | function AfterLastToken(const StrInd, Token: string): string;
|
---|
190 |
|
---|
191 | function KsSameText(S1, S2: string; MaxLen: Cardinal): boolean;
|
---|
192 | //same as AnsiSameText but the string are only compared up to MaxLen
|
---|
193 |
|
---|
194 | function BeforLastToken(const StrIn, Token: string): string;
|
---|
195 | function BeforeFirstToken(const S: string; Token: Char): string;
|
---|
196 | //Returnerer alt før Token som Result
|
---|
197 |
|
---|
198 | function strMake(C: Char; Len: Integer): string;
|
---|
199 | //Returns a string with a specified number of a specified Char
|
---|
200 | function strPadChL(const S: string; C: Char; Len: Integer): string;
|
---|
201 | //Fills leading Char's into a string up to a specified length
|
---|
202 |
|
---|
203 | //Fills leading Zeroes into a string up to a specified length
|
---|
204 | function strPosAfter(const aSubstr, S: string; aOfs: Integer): Integer;
|
---|
205 | //Returns the posision of the first occurence of a substring in a string after a specified offset
|
---|
206 | function strChange(var S: string; const Src, Dest: string): boolean;
|
---|
207 | //Changes every ocuranc of a text in a string with new text
|
---|
208 | function strEndSlash(const S: string): string;
|
---|
209 | //Returns a string with a trailing slash (\)
|
---|
210 | function strEndSlashX(const S: string): string;
|
---|
211 | //returns a string with a trailing slash (/)
|
---|
212 | function NoEndBackSlash(const S: string): string;
|
---|
213 | //Returns a string without a traling slash (\)
|
---|
214 |
|
---|
215 | function NoStartSlash(const S: string): string;
|
---|
216 | //Returns a string without a leading slash (/)
|
---|
217 |
|
---|
218 | function SplitAtToken(var S: string; Token: Char): string;
|
---|
219 | function SplitAtTokenStr(var S: string; Token: string): string;
|
---|
220 | //returnerer alt før Token som Result, og alt efter Token i S
|
---|
221 | function strTokenCount(S: string; Token: Char): Integer;
|
---|
222 | //Returnerer antal token i S
|
---|
223 | function AfterTokenNr(const S: string; Token: Char; Nr: Integer): string;
|
---|
224 | //Returns the right part of an string after token (Char) Nr.
|
---|
225 | function BeforeTokenNr(const S: string; Token: Char; Nr: Integer): string;
|
---|
226 | //Returns the left part of an string before token (Char) Nr.
|
---|
227 |
|
---|
228 | function strLastCh(const S: string): string;
|
---|
229 | //Returns the last char in a string
|
---|
230 |
|
---|
231 | type { Search and Replace options }
|
---|
232 | TSROption = (srWord, srCase, srAll);
|
---|
233 | TSROptions = set of TsrOption;
|
---|
234 |
|
---|
235 | function DropLastDir(path: string): string;
|
---|
236 | //fjerner sidste directory fra stien i path
|
---|
237 |
|
---|
238 | type
|
---|
239 | TCharSet = set of Char;
|
---|
240 |
|
---|
241 |
|
---|
242 | { Integer functions }
|
---|
243 | function intMax(a, b: Integer): Integer;
|
---|
244 | //Returns the highest value
|
---|
245 | function intMin(a, b: Integer): Integer;
|
---|
246 | //Returns the lowest value
|
---|
247 |
|
---|
248 | { date functions }
|
---|
249 | Function DateStrToDateTime(aDate: string): TDateTime;
|
---|
250 | Function TimeStrToDateTime(aDateTime: string): TDateTime;
|
---|
251 | //function dateYear(D: TDateTime): Integer;
|
---|
252 |
|
---|
253 | function fileSizeEx(const Filename: string): Longint;
|
---|
254 | //returns the size of a file in bytes
|
---|
255 |
|
---|
256 | function KSForceDirectories(Dir: string): Boolean;
|
---|
257 |
|
---|
258 | function GetShareFromURN(const URN: string; var Share: string; aPath: string = ''): boolean;
|
---|
259 |
|
---|
260 | function ExecuteFile(handle: HWND; const FileName, Params, DefaultDir: string; ShowCmd: Integer; Silent: boolean = true): THandle;
|
---|
261 | //run an exefile
|
---|
262 |
|
---|
263 | function fileCopy(const SourceFile, TargetFile: string): Boolean;
|
---|
264 | //copy a file (with date info)
|
---|
265 | function fileMove(const SourceFile, TargetFile: string): Boolean;
|
---|
266 | function fileTemp(const aExt: string = ''): string;
|
---|
267 | //Returns a unique temparary filename
|
---|
268 | function fileTempEx(const aName: string): string;
|
---|
269 | //Returns a unique temparary filename based on the suplied filename
|
---|
270 |
|
---|
271 | function KSGetCurrentDirectory: string;
|
---|
272 | //Returns the current directory for the current process
|
---|
273 |
|
---|
274 | function DirExists(const Name: string): Boolean;
|
---|
275 | function GetLogicalPathFromUNC(var aUNC :string): Boolean;
|
---|
276 | //returns a normal filepath fore a UNC-filepath
|
---|
277 | Function GetFirstNetworkDrive: string;
|
---|
278 | //returns the UNC-filepath fore the first network-drive
|
---|
279 | function KSGetTempPath: string;
|
---|
280 | //Returns the path of the directory designated for temporary files
|
---|
281 | function KSGetLogicalDrives: string;
|
---|
282 | //Returns a string that contains the currently available disk drives
|
---|
283 | function GetFirstAviableDriveLetter: string;
|
---|
284 |
|
---|
285 | function KSGetFileTime(const FileName: string; ComparisonType: TTimeOfWhat): TFileTime;
|
---|
286 | // Returns the date and time that a file was created, last accessed, or last modified
|
---|
287 |
|
---|
288 | function KSCompareFileTime(const FileNameOne, FileNameTwo: string; ComparisonType: TTimeOfWhat): TFileTimeComparision;
|
---|
289 | //Compares two files timestamps
|
---|
290 | function FileDifferent(const Sourcefile: string; TargetPath: string): Boolean;
|
---|
291 | //Returnere true hvis de to filer har forskellig dato eller størrelse
|
---|
292 | function KSFileGetDateTime(const aFile: string): TDateTime;
|
---|
293 | //Returnere TdateTime for en fils dato
|
---|
294 | function GetFileTimeEx(const FileName: string; ComparisonType: TTimeOfWhat): TDateTime;
|
---|
295 | // Returns the date and time that a file was created, last accessed, or last modified as TDateTime
|
---|
296 |
|
---|
297 | Function GetFreeDiskSize(TheDrive: String):Int64;
|
---|
298 | //Returns the amount of free space on the specified disk
|
---|
299 | function ShortFileNameToLFN(ShortName: String): String;
|
---|
300 | function GetFullPathNameEx(const Path: string): string;
|
---|
301 | //Returns the full path and filename of a specified file
|
---|
302 | function fileExec(const aCmdLine: string; const aAppName: string = ''; aHide: Boolean = True;
|
---|
303 | aWait: Boolean = False; bWait: Boolean = False): Boolean;
|
---|
304 | //Executes a file and wait as specified
|
---|
305 |
|
---|
306 | { system functions }
|
---|
307 | function GetWindir: string;
|
---|
308 | //Returns the windows directory
|
---|
309 | procedure WinExecError(iErr: Word; const sCmdLine: string);
|
---|
310 | //Returns a dialogbox with the explanation of an WinExecError
|
---|
311 |
|
---|
312 | procedure PrintWordDoc(const fil: string; handle: HWND);
|
---|
313 |
|
---|
314 | {System Information }
|
---|
315 | function KSGetUserName(Uppercase: boolean = true): string;
|
---|
316 | function GetNetUserName(const aResource: string = ''): string;
|
---|
317 | function KSGetNetUserName(const aResource: string = '?'): string;
|
---|
318 | function GetUserCookie: string;
|
---|
319 | //returns current username
|
---|
320 | Function GetFileAsText(const afile: String): String;
|
---|
321 | function SaveTextAsFile(const afile, Text: String): Boolean;
|
---|
322 |
|
---|
323 | function KSGetSystemDirectory: string;
|
---|
324 | //Returns system directory
|
---|
325 |
|
---|
326 | // Time Functions
|
---|
327 | function KSGetSystemTime: string;
|
---|
328 | //returns date and time
|
---|
329 |
|
---|
330 | function GetWindowFromText(const WindowText: string): Hwnd;
|
---|
331 | {returnere en handle til vinduet hvis det findes}
|
---|
332 |
|
---|
333 |
|
---|
334 | function CtrlDown: Boolean;
|
---|
335 |
|
---|
336 |
|
---|
337 | function GetSystemErrorMessage(var aFmtStr: String; ErrorAccept: Integer = ERROR_SUCCESS): boolean;
|
---|
338 | function GetErrorString(var aFmtStr: String; ErrorCode: Integer): boolean;
|
---|
339 |
|
---|
340 | function GetLastErrorStr: string;
|
---|
341 | function ShowLastErrorIfAny(anError: Integer; Handle: Hwnd = 0): Boolean;
|
---|
342 |
|
---|
343 | implementation
|
---|
344 |
|
---|
345 | uses RegFuncs;
|
---|
346 |
|
---|
347 | //------------------------------------------------------------------------------
|
---|
348 | function CopyCursor(cur: HCURSOR): HCURSOR;
|
---|
349 | begin
|
---|
350 | result := HCURSOR(CopyIcon(HICON(cur)));
|
---|
351 | { The typecasts are actually not necessary in Delphi since all handle type
|
---|
352 | are compatible with each other, since they all are aliases for DWORD }
|
---|
353 | end;
|
---|
354 | //------------------------------------------------------------------------------
|
---|
355 | function _StringIsInteger(Const S: String; var I: Integer): boolean;
|
---|
356 | {
|
---|
357 | var
|
---|
358 | Err: Integer;
|
---|
359 | begin
|
---|
360 | Val(S, I, Err);
|
---|
361 | Result := (Err = 0); This raises an error i debugging
|
---|
362 | end;
|
---|
363 | }
|
---|
364 |
|
---|
365 | var a: Integer;
|
---|
366 | begin
|
---|
367 | //asm int 3 end; //trap
|
---|
368 | result := FALSE;
|
---|
369 | I := 0;
|
---|
370 |
|
---|
371 | if (length(s) > 0) and (s[1] in ['+','-','0'..'9'])
|
---|
372 | then begin
|
---|
373 | for a := 2 to length(s) do
|
---|
374 | if not (s[a] in ['0'..'9'])
|
---|
375 | then begin
|
---|
376 | if (a > 3) or //min two good numbers before the trird that is bad
|
---|
377 | ((a = 2) and (not (s[1] in ['+','-']))) //first number is good
|
---|
378 | then I := StrToInt(Copy(S, 1, a -1));
|
---|
379 | exit;
|
---|
380 | end;
|
---|
381 |
|
---|
382 | result := true;
|
---|
383 | I := StrToInt(S);
|
---|
384 | end;
|
---|
385 | end;
|
---|
386 | //------------------------------------------------------------------------------
|
---|
387 | function StringIsInteger(Const S: String): boolean;
|
---|
388 | var
|
---|
389 | I: Integer;
|
---|
390 | begin
|
---|
391 | //asm int 3 end; //trap
|
---|
392 | result := _StringIsInteger(S, I);
|
---|
393 | end;
|
---|
394 | //------------------------------------------------------------------------------
|
---|
395 | { bit manipulating }
|
---|
396 |
|
---|
397 | //------------------------------------------------------------------------------
|
---|
398 | function strMake(C: Char; Len: Integer): string;
|
---|
399 | //Returns a string with a specified number of a specified Char
|
---|
400 | begin
|
---|
401 | //asm int 3 end; //KS trap
|
---|
402 | Result := strPadChL('', C, Len);
|
---|
403 | end;
|
---|
404 | //------------------------------------------------------------------------------
|
---|
405 | function strPadChL(const S: string; C: Char; Len: Integer): string;
|
---|
406 | //Fills leading Char's into a string up to a specified length
|
---|
407 | begin
|
---|
408 | //asm int 3 end; //KS trap
|
---|
409 | Result := S;
|
---|
410 | while Length(Result) < Len
|
---|
411 | do Result := C + Result;
|
---|
412 | end;
|
---|
413 | //------------------------------------------------------------------------------
|
---|
414 | function strEndSlash(const S: string): string;
|
---|
415 | //returns a string with a trailing slash (\)
|
---|
416 | begin
|
---|
417 | //asm int 3 end; //trap
|
---|
418 | Result := S;
|
---|
419 | if strLastCh(Result) <> '\'
|
---|
420 | then Result := Result + '\';
|
---|
421 | end;
|
---|
422 | //------------------------------------------------------------------------------
|
---|
423 | function strEndSlashX(const S: string): string;
|
---|
424 | //returns a string with a trailing slash (/)
|
---|
425 | begin
|
---|
426 | //asm int 3 end; //trap
|
---|
427 | Result := S;
|
---|
428 | if strLastCh(Result) <> '/'
|
---|
429 | then Result := Result + '/';
|
---|
430 | end;
|
---|
431 | //------------------------------------------------------------------------------
|
---|
432 | function NoEndBackSlash(const S: string): string;
|
---|
433 | //Returns a string without a traling slash (\)
|
---|
434 | begin
|
---|
435 | //asm int 3 end; //trap
|
---|
436 | Result := S;
|
---|
437 | if strLastCh(Result) = '\'
|
---|
438 | then Delete(Result, Length(Result), 1);
|
---|
439 | end;
|
---|
440 | //------------------------------------------------------------------------------
|
---|
441 | function NoStartSlash(const S: string): string;
|
---|
442 | //Returns a string without a leading slash (/)
|
---|
443 | begin
|
---|
444 | //asm int 3 end; //KS trap
|
---|
445 | Result := S;
|
---|
446 | if (length(Result) > 0) and (Result[1] = '/')
|
---|
447 | then Delete(Result, 1, 1);
|
---|
448 | end;
|
---|
449 | //------------------------------------------------------------------------------
|
---|
450 | function SplitAtToken(var S: string; Token: Char): string;
|
---|
451 | //Splits up a string at a specified substring
|
---|
452 | //Returnerer alt før Token som Result, og alt efter Token i S
|
---|
453 | var
|
---|
454 | I: Word;
|
---|
455 | begin
|
---|
456 | //asm int 3 end; //trap
|
---|
457 | I := Pos(Token, S);
|
---|
458 | if I <> 0
|
---|
459 | then begin
|
---|
460 | Result := System.Copy(S, 1, I - 1);
|
---|
461 | System.Delete(S, 1, I);
|
---|
462 | end
|
---|
463 | else begin //der er ingen token
|
---|
464 | Result := S;
|
---|
465 | S := '';
|
---|
466 | end;
|
---|
467 | end;
|
---|
468 | //------------------------------------------------------------------------------
|
---|
469 | function BeforeFirstToken(const S: string; Token: Char): string;
|
---|
470 | //Returnerer alt før Token som Result
|
---|
471 | var
|
---|
472 | I: Word;
|
---|
473 | begin
|
---|
474 | //asm int 3 end; //trap
|
---|
475 | I := Pos(Token, S);
|
---|
476 | if I <> 0
|
---|
477 | then Result := System.Copy(S, 1, I - 1)
|
---|
478 | else Result := S; //der er ingen token
|
---|
479 | end;
|
---|
480 | //------------------------------------------------------------------------------
|
---|
481 | function SplitAtTokenStr(var S: string; Token: string): string;
|
---|
482 | //Splits up a string at a specified substring
|
---|
483 | //Returnerer alt før Token som Result, og alt efter Token i S
|
---|
484 | var
|
---|
485 | I: Word;
|
---|
486 | begin
|
---|
487 | //asm int 3 end; //trap
|
---|
488 | I := Pos(Token, S);
|
---|
489 | if I <> 0
|
---|
490 | then begin
|
---|
491 | Result := System.Copy(S, 1, I - 1);
|
---|
492 | System.Delete(S, 1, I + length(Token)-1);
|
---|
493 | end
|
---|
494 | else begin //der er ingen token
|
---|
495 | Result := S;
|
---|
496 | S := '';
|
---|
497 | end;
|
---|
498 | end;
|
---|
499 | //------------------------------------------------------------------------------
|
---|
500 | function strTokenCount(S: string; Token: Char): Integer;
|
---|
501 | //Returns the number of Char in S
|
---|
502 | var
|
---|
503 | //s1: string;
|
---|
504 | i: Integer;
|
---|
505 | begin
|
---|
506 | //asm int 3 end; //trap
|
---|
507 | Result := 0;
|
---|
508 | I := pos(Token, S);
|
---|
509 | if i = 0
|
---|
510 | then exit;
|
---|
511 |
|
---|
512 | repeat
|
---|
513 | Inc(Result);
|
---|
514 | s := copy(S, i + 1, length(s));
|
---|
515 | I := pos(Token, S);
|
---|
516 | if i = 0
|
---|
517 | then break;
|
---|
518 | until false;
|
---|
519 |
|
---|
520 | end;
|
---|
521 | //------------------------------------------------------------------------------
|
---|
522 | function AfterTokenNr(const S: string; Token: Char; Nr: Integer): string;
|
---|
523 | //Returns the right part of an string after token (Char) Nr.
|
---|
524 | var
|
---|
525 | j, i: Integer;
|
---|
526 | begin
|
---|
527 | //asm int 3 end; //KS trap
|
---|
528 | Result := '';
|
---|
529 | j := 1;
|
---|
530 | i := 0;
|
---|
531 |
|
---|
532 | while (i <= Nr) and (j <= Length(S))
|
---|
533 | do begin
|
---|
534 | if S[j] = Token
|
---|
535 | then begin
|
---|
536 | Inc(i);
|
---|
537 | if i = Nr
|
---|
538 | then break;
|
---|
539 | end;
|
---|
540 | Inc(j);
|
---|
541 | end; //while
|
---|
542 |
|
---|
543 | Result := copy(s, j + 1, length(S));
|
---|
544 | end;
|
---|
545 | //------------------------------------------------------------------------------
|
---|
546 | function BeforeTokenNr(const S: string; Token: Char; Nr: Integer): string;
|
---|
547 | //Returns the left part of an string before token (Char) Nr.
|
---|
548 | var
|
---|
549 | j, i: Integer;
|
---|
550 | begin
|
---|
551 | //asm int 3 end; //KS trap
|
---|
552 | Result := '';
|
---|
553 | j := 1;
|
---|
554 | i := 0;
|
---|
555 |
|
---|
556 | while (i <= Nr) and (j <= Length(S))
|
---|
557 | do begin
|
---|
558 | if S[j] = Token
|
---|
559 | then begin
|
---|
560 | Inc(i);
|
---|
561 | if i = Nr
|
---|
562 | then break;
|
---|
563 | end;
|
---|
564 | Inc(j);
|
---|
565 | end; //while
|
---|
566 |
|
---|
567 | Result := copy(s, 0, j - 1);
|
---|
568 |
|
---|
569 | end;
|
---|
570 | //------------------------------------------------------------------------------
|
---|
571 | function strPosAfter(const aSubstr, S: string; aOfs: Integer): Integer;
|
---|
572 | //Returns the posision of the first occurence of a substring in a string
|
---|
573 | //after a specified offset
|
---|
574 | begin
|
---|
575 | //asm int 3 end; //trap
|
---|
576 | Result := Pos(aSubStr, Copy(S, aOfs, (Length(S) - aOfs) + 1));
|
---|
577 | if (Result > 0) and (aOfs > 1)
|
---|
578 | then Inc(Result, aOfs - 1);
|
---|
579 | end;
|
---|
580 | //------------------------------------------------------------------------------
|
---|
581 | function strChange(var S: string; const Src, Dest: string): boolean;
|
---|
582 | //Changes every ocuranc of a text in a string with new text
|
---|
583 | var
|
---|
584 | Org: String;
|
---|
585 | begin
|
---|
586 | //asm int 3 end; //trap
|
---|
587 | Org := S;
|
---|
588 | S := StringReplace(S, Src, Dest, [rfReplaceAll]);
|
---|
589 | result := not AnsiSameText(Org, S);
|
---|
590 | end;
|
---|
591 | //------------------------------------------------------------------------------
|
---|
592 | function strLastCh(const S: string): string;
|
---|
593 | //Returns the last char in a string
|
---|
594 | var
|
---|
595 | i: integer;
|
---|
596 | begin
|
---|
597 | //asm int 3 end; //trap
|
---|
598 | i := Length(S);
|
---|
599 | if i > 0
|
---|
600 | then Result := S[Length(S)]
|
---|
601 | else Result := '';
|
---|
602 | end;
|
---|
603 | //------------------------------------------------------------------------------
|
---|
604 | { Integer stuff }
|
---|
605 | //------------------------------------------------------------------------------
|
---|
606 | function IntMax(a, b: Integer): Integer;
|
---|
607 | //Returns the highest value
|
---|
608 | begin
|
---|
609 | //asm int 3 end; //trap
|
---|
610 | if a > b
|
---|
611 | then Result := a
|
---|
612 | else Result := b;
|
---|
613 | end;
|
---|
614 | //------------------------------------------------------------------------------
|
---|
615 | function IntMin(a, b: Integer): Integer;
|
---|
616 | //Returns the lowest value
|
---|
617 | begin
|
---|
618 | //asm int 3 end; //KS trap
|
---|
619 | if a < b
|
---|
620 | then Result := a
|
---|
621 | else Result := b;
|
---|
622 | end;
|
---|
623 | //------------------------------------------------------------------------------
|
---|
624 | function ExecuteFile(handle: HWND; const FileName, Params, DefaultDir: string; ShowCmd: Integer; Silent: boolean = true): THandle;
|
---|
625 | begin
|
---|
626 | //asm int 3 end; //trap
|
---|
627 | {a caling procedure can normally get a hanle like this: Application.MainForm.Handle }
|
---|
628 | Result := ShellExecute(handle, nil,
|
---|
629 | Pchar(FileName), Pchar(Params), Pchar(DefaultDir), ShowCmd);
|
---|
630 |
|
---|
631 | if (Result < 32) and (ShowDeveloperMessages or (not silent))
|
---|
632 | then WinExecError(Result, Filename);
|
---|
633 | end;
|
---|
634 | //------------------------------------------------------------------------------
|
---|
635 | function fileCopy(const SourceFile, TargetFile: string): Boolean;
|
---|
636 | begin
|
---|
637 | //asm int 3 end; //trap
|
---|
638 | Result := CopyFile(Pchar(SourceFile), Pchar(TargetFile), False);
|
---|
639 | // Existing file Copy of file
|
---|
640 | end;
|
---|
641 | //------------------------------------------------------------------------------
|
---|
642 | function fileMove(const SourceFile, TargetFile: string): Boolean;
|
---|
643 | begin
|
---|
644 | //asm int 3 end; //KS trap
|
---|
645 | Result := MoveFile(Pchar(SourceFile), Pchar(TargetFile));
|
---|
646 | // Existing file New file
|
---|
647 | end;
|
---|
648 | //------------------------------------------------------------------------------
|
---|
649 | function fileTemp(const aExt: string = ''): string;
|
---|
650 | //Returns a unique temparary filename
|
---|
651 | var
|
---|
652 | Buffer: array[0..1023] of Char;
|
---|
653 | aFile: string;
|
---|
654 | begin
|
---|
655 |
|
---|
656 | //asm int 3 end; //KS trap
|
---|
657 | GetTempPath(Sizeof(Buffer) - 1, Buffer);
|
---|
658 | GetTempFileName(Buffer, 'TMP', 0, Buffer);
|
---|
659 | SetString(aFile, Buffer, StrLen(Buffer));
|
---|
660 |
|
---|
661 | if length(aExt) > 0
|
---|
662 | then begin
|
---|
663 | Result := ChangeFileExt(aFile, aExt);
|
---|
664 | RenameFile(aFile, Result);
|
---|
665 | end
|
---|
666 | else result := aFile;
|
---|
667 | end;
|
---|
668 | //------------------------------------------------------------------------------
|
---|
669 | function fileTempEx(const aName: string): string;
|
---|
670 | //Returns a unique temparary filename based on the suplied filename
|
---|
671 | var
|
---|
672 | Buffer: array[0..1023] of Char;
|
---|
673 | aFile: string;
|
---|
674 | aPath: string;
|
---|
675 | aExt: string;
|
---|
676 | begin
|
---|
677 | //asm int 3 end; //KS trap
|
---|
678 | aPath := ExtractFilePath(aName);
|
---|
679 | if length(aPath) = 0
|
---|
680 | then begin
|
---|
681 | GetTempPath(Sizeof(Buffer) - 1, Buffer);
|
---|
682 | aPath := Buffer;
|
---|
683 | end;
|
---|
684 |
|
---|
685 | aExt := ExtractFileName(aName);
|
---|
686 | aFile := SplitAtToken(aExt, '.');
|
---|
687 |
|
---|
688 | while true do
|
---|
689 | begin
|
---|
690 | GetTempFileName(Pchar(aPath), '_', 0, Buffer);
|
---|
691 | result := aPath + aFile + ChangeFileExt(ExtractFileName(Buffer), '.'+aExt);
|
---|
692 | if not FileExists(result)
|
---|
693 | then break;
|
---|
694 | end;
|
---|
695 | end;
|
---|
696 | //------------------------------------------------------------------------------
|
---|
697 | function fileExec(const aCmdLine: string; const aAppName: string = ''; aHide: Boolean = True;
|
---|
698 | aWait: Boolean = False; bWait: Boolean = False): Boolean;
|
---|
699 | //Executes a file and wait as specified
|
---|
700 | //aWait = vent på inputidle, bWait = vent på at programmet stopper igen
|
---|
701 | var
|
---|
702 | StartupInfo: TStartupInfo;
|
---|
703 | ProcessInfo: TProcessInformation;
|
---|
704 | dwI : Cardinal;
|
---|
705 | dwCreationFlags: Cardinal;
|
---|
706 | S, S1: string;
|
---|
707 | //lpExitCode: DWORD;
|
---|
708 | //Msg: TMsg;
|
---|
709 | begin
|
---|
710 | //asm int 3 end; //trap
|
---|
711 | result := false;
|
---|
712 |
|
---|
713 | //dont try to start a non existing program - can cause troubles
|
---|
714 | if (Length(aCmdLine) = 0) and (Length(aAppName) = 0)
|
---|
715 | then exit;
|
---|
716 |
|
---|
717 | if not (fileExists(aCmdLine) or fileExists(aAppName))
|
---|
718 | then begin
|
---|
719 | //try to get rid og params in aCmdLine
|
---|
720 | if Length(aCmdLine) > 0
|
---|
721 | then begin
|
---|
722 | S1 := aCmdLine;
|
---|
723 | if S1[1] = '"'
|
---|
724 | then begin
|
---|
725 | S := SplitAtTokenStr(S1, '" ');
|
---|
726 | delete(S, 1, 1);//drop leading "
|
---|
727 | end
|
---|
728 | else S := SplitAtToken(S1, ' ');
|
---|
729 |
|
---|
730 | if not fileExists(S)
|
---|
731 | then exit;
|
---|
732 | end
|
---|
733 | else exit;
|
---|
734 | end;
|
---|
735 |
|
---|
736 | {setup the startup information for the application }
|
---|
737 | FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
|
---|
738 | with StartupInfo
|
---|
739 | do begin
|
---|
740 | cb := SizeOf(TStartupInfo);
|
---|
741 | dwFlags := STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK;
|
---|
742 |
|
---|
743 | if aHide
|
---|
744 | then wShowWindow := SW_HIDE
|
---|
745 | else wShowWindow := SW_SHOWNORMAL;
|
---|
746 | end;
|
---|
747 | //prevents delphi from locking the app but also from starting the app
|
---|
748 | //dwCreationFlags := DEBUG_ONLY_THIS_PROCESS or NORMAL_PRIORITY_CLASS or CREATE_NEW_PROCESS_GROUP;
|
---|
749 | //dwCreationFlags := NORMAL_PRIORITY_CLASS or CREATE_NEW_PROCESS_GROUP;
|
---|
750 | //dwCreationFlags := CREATE_DEFAULT_ERROR_MODE + NORMAL_PRIORITY_CLASS;
|
---|
751 | dwCreationFlags := CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS;
|
---|
752 | //dwCreationFlags := NORMAL_PRIORITY_CLASS;
|
---|
753 | try
|
---|
754 | if aAppName = ''
|
---|
755 | then Result := CreateProcess(nil, PChar(aCmdLine), nil, nil, False, dwCreationFlags, nil, nil, StartupInfo, ProcessInfo)
|
---|
756 | else Result := CreateProcess(PChar(aAppName), PChar(aCmdLine), nil, nil, False, dwCreationFlags, nil, nil, StartupInfo, ProcessInfo);
|
---|
757 |
|
---|
758 | if not result
|
---|
759 | then exit;
|
---|
760 |
|
---|
761 | if aWait
|
---|
762 | then begin
|
---|
763 | dwI := WaitForInputIdle(ProcessInfo.hProcess, INFINITE);
|
---|
764 | if dwI = $FFFFFFFF
|
---|
765 | then GetExitCodeProcess(ProcessInfo.hProcess, dwI)
|
---|
766 | else begin
|
---|
767 | if bWait
|
---|
768 | then while WaitForSingleObject(ProcessInfo.hProcess,100) = WAIT_TIMEOUT do
|
---|
769 | KSProcessMessages;
|
---|
770 | end;
|
---|
771 | end;
|
---|
772 | finally
|
---|
773 | CloseHandle(ProcessInfo.hProcess); //close handles or we get a mem-leak !
|
---|
774 | CloseHandle(ProcessInfo.hThread);
|
---|
775 | end;
|
---|
776 | end;
|
---|
777 | //------------------------------------------------------------------------------
|
---|
778 | { date calculations }
|
---|
779 |
|
---|
780 | type
|
---|
781 | TDateOrder = (doMDY, doDMY, doYMD);
|
---|
782 |
|
---|
783 | function CurrentYear: Word;
|
---|
784 | var
|
---|
785 | SystemTime: TSystemTime;
|
---|
786 | begin
|
---|
787 | //asm int 3 end; //KS trap
|
---|
788 | GetLocalTime(SystemTime);
|
---|
789 | Result := SystemTime.wYear;
|
---|
790 | end;
|
---|
791 | //------------------------------------------------------------------------------
|
---|
792 | function GetDateOrder(const DateFormat: string): TDateOrder;
|
---|
793 | var
|
---|
794 | I: Integer;
|
---|
795 | begin
|
---|
796 | //asm int 3 end; //KS trap
|
---|
797 | Result := doMDY;
|
---|
798 | I := 1;
|
---|
799 | while I <= Length(DateFormat) do
|
---|
800 | begin
|
---|
801 | case Chr(Ord(DateFormat[I]) and $DF) of
|
---|
802 | 'E': Result := doYMD;
|
---|
803 | 'Y': Result := doYMD;
|
---|
804 | 'M': Result := doMDY;
|
---|
805 | 'D': Result := doDMY;
|
---|
806 | else
|
---|
807 | Inc(I);
|
---|
808 | Continue;
|
---|
809 | end;
|
---|
810 | Exit;
|
---|
811 | end;
|
---|
812 | Result := doMDY;
|
---|
813 | end;
|
---|
814 | //------------------------------------------------------------------------------
|
---|
815 | procedure ScanToNumber(const S: string; var Pos: Integer);
|
---|
816 | begin
|
---|
817 | //asm int 3 end; //KS trap
|
---|
818 | while (Pos <= Length(S)) and not (S[Pos] in ['0'..'9']) do
|
---|
819 | begin
|
---|
820 | if S[Pos] in LeadBytes then Inc(Pos);
|
---|
821 | Inc(Pos);
|
---|
822 | end;
|
---|
823 | end;
|
---|
824 | //------------------------------------------------------------------------------
|
---|
825 | function GetEraYearOffset(const Name: string): Integer;
|
---|
826 | var
|
---|
827 | I: Integer;
|
---|
828 | begin
|
---|
829 | //asm int 3 end; //KS trap
|
---|
830 | Result := 0;
|
---|
831 | for I := Low(EraNames) to High(EraNames) do
|
---|
832 | begin
|
---|
833 | if EraNames[I] = '' then Break;
|
---|
834 | if AnsiStrPos(PChar(EraNames[I]), PChar(Name)) <> nil then
|
---|
835 | begin
|
---|
836 | Result := EraYearOffsets[I];
|
---|
837 | Exit;
|
---|
838 | end;
|
---|
839 | end;
|
---|
840 | end;
|
---|
841 | //------------------------------------------------------------------------------
|
---|
842 | procedure ScanBlanks(const S: string; var Pos: Integer);
|
---|
843 | var
|
---|
844 | I: Integer;
|
---|
845 | begin
|
---|
846 | //asm int 3 end; //KS trap
|
---|
847 | I := Pos;
|
---|
848 | while (I <= Length(S)) and (S[I] = ' ') do Inc(I);
|
---|
849 | Pos := I;
|
---|
850 | end;
|
---|
851 | //------------------------------------------------------------------------------
|
---|
852 | function ScanNumber(const S: string; var Pos: Integer;
|
---|
853 | var Number: Word; var CharCount: Byte): Boolean;
|
---|
854 | var
|
---|
855 | I: Integer;
|
---|
856 | N: Word;
|
---|
857 | begin
|
---|
858 | //asm int 3 end; //KS trap
|
---|
859 | Result := False;
|
---|
860 | CharCount := 0;
|
---|
861 | ScanBlanks(S, Pos);
|
---|
862 | I := Pos;
|
---|
863 | N := 0;
|
---|
864 | while (I <= Length(S)) and (S[I] in ['0'..'9']) and (N < 1000) do
|
---|
865 | begin
|
---|
866 | N := N * 10 + (Ord(S[I]) - Ord('0'));
|
---|
867 | Inc(I);
|
---|
868 | end;
|
---|
869 | if I > Pos then
|
---|
870 | begin
|
---|
871 | CharCount := I - Pos;
|
---|
872 | Pos := I;
|
---|
873 | Number := N;
|
---|
874 | Result := True;
|
---|
875 | end;
|
---|
876 | end;
|
---|
877 | //------------------------------------------------------------------------------
|
---|
878 | function ScanString(const S: string; var Pos: Integer;
|
---|
879 | const Symbol: string): Boolean;
|
---|
880 | begin
|
---|
881 | //asm int 3 end; //KS trap
|
---|
882 | Result := False;
|
---|
883 | if Symbol <> '' then
|
---|
884 | begin
|
---|
885 | ScanBlanks(S, Pos);
|
---|
886 | if AnsiCompareText(Symbol, Copy(S, Pos, Length(Symbol))) = 0 then
|
---|
887 | begin
|
---|
888 | Inc(Pos, Length(Symbol));
|
---|
889 | Result := True;
|
---|
890 | end;
|
---|
891 | end;
|
---|
892 | end;
|
---|
893 | //------------------------------------------------------------------------------
|
---|
894 | function ScanChar(const S: string; var Pos: Integer; Ch: Char): Boolean;
|
---|
895 | begin
|
---|
896 | //asm int 3 end; //KS trap
|
---|
897 | Result := False;
|
---|
898 | ScanBlanks(S, Pos);
|
---|
899 | if (Pos <= Length(S)) and (S[Pos] = Ch) then
|
---|
900 | begin
|
---|
901 | Inc(Pos);
|
---|
902 | Result := True;
|
---|
903 | end;
|
---|
904 | end;
|
---|
905 | //------------------------------------------------------------------------------
|
---|
906 | function DoEncodeDate(Year, Month, Day: Word; var Date: TDateTime): Boolean;
|
---|
907 | var
|
---|
908 | I: Integer;
|
---|
909 | DayTable: PDayTable;
|
---|
910 | begin
|
---|
911 | //asm int 3 end; //KS trap
|
---|
912 | Result := False;
|
---|
913 | DayTable := @MonthDays[IsLeapYear(Year)];
|
---|
914 | if (Year >= 1) and (Year <= 9999) and (Month >= 1) and (Month <= 12) and
|
---|
915 | (Day >= 1) and (Day <= DayTable^[Month]) then
|
---|
916 | begin
|
---|
917 | for I := 1 to Month - 1 do Inc(Day, DayTable^[I]);
|
---|
918 | I := Year - 1;
|
---|
919 | Date := I * 365 + I div 4 - I div 100 + I div 400 + Day - DateDelta;
|
---|
920 | Result := True;
|
---|
921 | end;
|
---|
922 | end;
|
---|
923 | //------------------------------------------------------------------------------
|
---|
924 | function ScanDate(const S: string; var Pos: Integer;
|
---|
925 | var Date: TDateTime): Boolean;
|
---|
926 | var
|
---|
927 | DateOrder: TDateOrder;
|
---|
928 | N1, N2, N3, Y, M, D: Word;
|
---|
929 | L1, L2, L3, YearLen: Byte;
|
---|
930 | EraName : string;
|
---|
931 | EraYearOffset: Integer;
|
---|
932 | CenturyBase: Integer;
|
---|
933 |
|
---|
934 | function EraToYear(Year: Integer): Integer;
|
---|
935 | begin
|
---|
936 | if SysLocale.PriLangID = LANG_KOREAN then
|
---|
937 | begin
|
---|
938 | if Year <= 99 then
|
---|
939 | Inc(Year, (CurrentYear + Abs(EraYearOffset)) div 100 * 100);
|
---|
940 | if EraYearOffset > 0 then
|
---|
941 | EraYearOffset := -EraYearOffset;
|
---|
942 | end
|
---|
943 | else
|
---|
944 | Dec(EraYearOffset);
|
---|
945 | Result := Year + EraYearOffset;
|
---|
946 | end;
|
---|
947 |
|
---|
948 | begin
|
---|
949 | //asm int 3 end; //KS trap
|
---|
950 | Y := 0;
|
---|
951 | M := 0;
|
---|
952 | D := 0;
|
---|
953 | YearLen := 0;
|
---|
954 | Result := False;
|
---|
955 | DateOrder := GetDateOrder(ShortDateFormat);
|
---|
956 | EraYearOffset := 0;
|
---|
957 | if ShortDateFormat[1] = 'g' then // skip over prefix text
|
---|
958 | begin
|
---|
959 | ScanToNumber(S, Pos);
|
---|
960 | EraName := Trim(Copy(S, 1, Pos-1));
|
---|
961 | EraYearOffset := GetEraYearOffset(EraName);
|
---|
962 | end
|
---|
963 | else
|
---|
964 | if AnsiPos('e', ShortDateFormat) > 0 then
|
---|
965 | EraYearOffset := EraYearOffsets[1];
|
---|
966 | if not (ScanNumber(S, Pos, N1, L1) and ScanChar(S, Pos, DateSeparator) and
|
---|
967 | ScanNumber(S, Pos, N2, L2)) then Exit;
|
---|
968 | if ScanChar(S, Pos, DateSeparator) then
|
---|
969 | begin
|
---|
970 | if not ScanNumber(S, Pos, N3, L3) then Exit;
|
---|
971 | case DateOrder of
|
---|
972 | doMDY: begin Y := N3; YearLen := L3; M := N1; D := N2; end;
|
---|
973 | doDMY: begin Y := N3; YearLen := L3; M := N2; D := N1; end;
|
---|
974 | doYMD: begin Y := N1; YearLen := L1; M := N2; D := N3; end;
|
---|
975 | end;
|
---|
976 | if EraYearOffset > 0 then
|
---|
977 | Y := EraToYear(Y)
|
---|
978 | else if (YearLen <= 2) then
|
---|
979 | begin
|
---|
980 | CenturyBase := CurrentYear - TwoDigitYearCenturyWindow;
|
---|
981 | Inc(Y, CenturyBase div 100 * 100);
|
---|
982 | if (TwoDigitYearCenturyWindow > 0) and (Y < CenturyBase) then
|
---|
983 | Inc(Y, 100);
|
---|
984 | end;
|
---|
985 | end else
|
---|
986 | begin
|
---|
987 | Y := CurrentYear;
|
---|
988 | if DateOrder = doDMY then
|
---|
989 | begin
|
---|
990 | D := N1; M := N2;
|
---|
991 | end else
|
---|
992 | begin
|
---|
993 | M := N1; D := N2;
|
---|
994 | end;
|
---|
995 | end;
|
---|
996 | ScanChar(S, Pos, DateSeparator);
|
---|
997 | ScanBlanks(S, Pos);
|
---|
998 | if SysLocale.FarEast and (System.Pos('ddd', ShortDateFormat) <> 0) then
|
---|
999 | begin // ignore trailing text
|
---|
1000 | if ShortTimeFormat[1] in ['0'..'9'] then // stop at time digit
|
---|
1001 | ScanToNumber(S, Pos)
|
---|
1002 | else // stop at time prefix
|
---|
1003 | repeat
|
---|
1004 | while (Pos <= Length(S)) and (S[Pos] <> ' ') do Inc(Pos);
|
---|
1005 | ScanBlanks(S, Pos);
|
---|
1006 | until (Pos > Length(S)) or
|
---|
1007 | (AnsiCompareText(TimeAMString, Copy(S, Pos, Length(TimeAMString))) = 0) or
|
---|
1008 | (AnsiCompareText(TimePMString, Copy(S, Pos, Length(TimePMString))) = 0);
|
---|
1009 | end;
|
---|
1010 | Result := DoEncodeDate(Y, M, D, Date);
|
---|
1011 | end;
|
---|
1012 | //------------------------------------------------------------------------------
|
---|
1013 | function DoEncodeTime(Hour, Min, Sec, MSec: Word; var Time: TDateTime): Boolean;
|
---|
1014 | begin
|
---|
1015 | //asm int 3 end; //KS trap
|
---|
1016 | Result := False;
|
---|
1017 | if (Hour < 24) and (Min < 60) and (Sec < 60) and (MSec < 1000) then
|
---|
1018 | begin
|
---|
1019 | Time := (Hour * 3600000 + Min * 60000 + Sec * 1000 + MSec) / MSecsPerDay;
|
---|
1020 | Result := True;
|
---|
1021 | end;
|
---|
1022 | end;
|
---|
1023 | //------------------------------------------------------------------------------
|
---|
1024 | function ScanTime(const S: string; var Pos: Integer;
|
---|
1025 | var Time: TDateTime): Boolean;
|
---|
1026 | var
|
---|
1027 | BaseHour: Integer;
|
---|
1028 | Hour, Min, Sec, MSec: Word;
|
---|
1029 | Junk: Byte;
|
---|
1030 | begin
|
---|
1031 | //asm int 3 end; //KS trap
|
---|
1032 | Result := False;
|
---|
1033 | BaseHour := -1;
|
---|
1034 | if ScanString(S, Pos, TimeAMString) or ScanString(S, Pos, 'AM') then
|
---|
1035 | BaseHour := 0
|
---|
1036 | else if ScanString(S, Pos, TimePMString) or ScanString(S, Pos, 'PM') then
|
---|
1037 | BaseHour := 12;
|
---|
1038 | if BaseHour >= 0 then ScanBlanks(S, Pos);
|
---|
1039 | if not ScanNumber(S, Pos, Hour, Junk) then Exit;
|
---|
1040 | Min := 0;
|
---|
1041 | if ScanChar(S, Pos, TimeSeparator) then
|
---|
1042 | if not ScanNumber(S, Pos, Min, Junk) then Exit;
|
---|
1043 | Sec := 0;
|
---|
1044 | if ScanChar(S, Pos, TimeSeparator) then
|
---|
1045 | if not ScanNumber(S, Pos, Sec, Junk) then Exit;
|
---|
1046 | MSec := 0;
|
---|
1047 | if ScanChar(S, Pos, DecimalSeparator) then
|
---|
1048 | if not ScanNumber(S, Pos, MSec, Junk) then Exit;
|
---|
1049 | if BaseHour < 0 then
|
---|
1050 | if ScanString(S, Pos, TimeAMString) or ScanString(S, Pos, 'AM') then
|
---|
1051 | BaseHour := 0
|
---|
1052 | else
|
---|
1053 | if ScanString(S, Pos, TimePMString) or ScanString(S, Pos, 'PM') then
|
---|
1054 | BaseHour := 12;
|
---|
1055 | if BaseHour >= 0 then
|
---|
1056 | begin
|
---|
1057 | if (Hour = 0) or (Hour > 12) then Exit;
|
---|
1058 | if Hour = 12 then Hour := 0;
|
---|
1059 | Inc(Hour, BaseHour);
|
---|
1060 | end;
|
---|
1061 | ScanBlanks(S, Pos);
|
---|
1062 | Result := DoEncodeTime(Hour, Min, Sec, MSec, Time);
|
---|
1063 | end;
|
---|
1064 | //------------------------------------------------------------------------------
|
---|
1065 |
|
---|
1066 | Function DateStrToDateTime(aDate: string): TDateTime;
|
---|
1067 | var
|
---|
1068 | OldDateSeparator: Char;
|
---|
1069 | OldShortDateFormat: string;
|
---|
1070 | Pos: Integer;
|
---|
1071 | //S: string;
|
---|
1072 | begin
|
---|
1073 | //asm int 3 end; //KS trap
|
---|
1074 | OldDateSeparator := DateSeparator;
|
---|
1075 | OldShortDateFormat := ShortDateFormat;
|
---|
1076 | DateSeparator := '.';
|
---|
1077 | ShortDateFormat := 'dd.mm.yy';
|
---|
1078 |
|
---|
1079 | try
|
---|
1080 | Pos := 1;
|
---|
1081 | if not ScanDate(aDate, Pos, Result) or (Pos <= Length(aDate))
|
---|
1082 | then result := 0;
|
---|
1083 | finally
|
---|
1084 | DateSeparator := OldDateSeparator;
|
---|
1085 | ShortDateFormat := OldShortDateFormat;
|
---|
1086 | end;
|
---|
1087 | end;
|
---|
1088 |
|
---|
1089 | //------------------------------------------------------------------------------
|
---|
1090 | Function TimeStrToDateTime(aDateTime: string): TDateTime;
|
---|
1091 | var
|
---|
1092 | OldDateSeparator: Char;
|
---|
1093 | OldTimeSeparator: Char;
|
---|
1094 | OldShortDateFormat: string;
|
---|
1095 | Pos: Integer;
|
---|
1096 | Date, Time: TDateTime;
|
---|
1097 | begin
|
---|
1098 | //asm int 3 end; //KS trap
|
---|
1099 | OldDateSeparator := DateSeparator;
|
---|
1100 | OldShortDateFormat := ShortDateFormat;
|
---|
1101 | OldTimeSeparator := TimeSeparator;
|
---|
1102 | DateSeparator := '.';
|
---|
1103 | ShortDateFormat := 'dd.mm.yy';
|
---|
1104 | TimeSeparator := ':';
|
---|
1105 | Result := 0;
|
---|
1106 |
|
---|
1107 | try
|
---|
1108 | try
|
---|
1109 | Pos := 1;
|
---|
1110 | Time := 0;
|
---|
1111 | if not ScanDate(aDateTime, Pos, Date) or
|
---|
1112 | not ((Pos > Length(aDateTime)) or
|
---|
1113 | ScanTime(aDateTime, Pos, Time))
|
---|
1114 | then begin // Try time only
|
---|
1115 | Pos := 1;
|
---|
1116 | if not ScanTime(aDateTime, Pos, Result) or (Pos <= Length(aDateTime))
|
---|
1117 | then result := 0;
|
---|
1118 | end
|
---|
1119 | else begin
|
---|
1120 | if Date >= 0
|
---|
1121 | then Result := Date + Time
|
---|
1122 | else Result := Date - Time;
|
---|
1123 | end;
|
---|
1124 | except
|
---|
1125 | Result := 0;
|
---|
1126 | end;
|
---|
1127 | finally
|
---|
1128 | DateSeparator := OldDateSeparator;
|
---|
1129 | ShortDateFormat := OldShortDateFormat;
|
---|
1130 | TimeSeparator := OldTimeSeparator;
|
---|
1131 | end;
|
---|
1132 | end;
|
---|
1133 | //------------------------------------------------------------------------------
|
---|
1134 | function DirExists(const Name: string): Boolean;
|
---|
1135 | var
|
---|
1136 | Code: Integer;
|
---|
1137 | begin
|
---|
1138 | //asm int 3 end; //trap
|
---|
1139 | {$RANGECHECKS OFF}
|
---|
1140 | Code := GetFileAttributes(PChar(Name));
|
---|
1141 | Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
|
---|
1142 | end;
|
---|
1143 | //------------------------------------------------------------------------------
|
---|
1144 | function KSGetTempPath: string;
|
---|
1145 | //Returns the path of the directory designated for temporary files
|
---|
1146 | var
|
---|
1147 | Buffer: array[0..1023] of Char;
|
---|
1148 | begin
|
---|
1149 | //asm int 3 end; //trap
|
---|
1150 | SetString(Result, Buffer, GetTempPath(Sizeof(Buffer) - 1, Buffer));
|
---|
1151 | //Fixes a bug in Windows 2000
|
---|
1152 | //Strg.MakeLongName(result);
|
---|
1153 | //problems
|
---|
1154 | (*
|
---|
1155 | if (result = '') or (not DirExists(result))
|
---|
1156 | then begin
|
---|
1157 | result := GetWinDir + '\TEMP\';
|
---|
1158 | MkDir(result);
|
---|
1159 | end;
|
---|
1160 | *)
|
---|
1161 | end;
|
---|
1162 | //------------------------------------------------------------------------------
|
---|
1163 | procedure WinExecError(iErr: Word; const sCmdLine: string);
|
---|
1164 | //Returns a dialogbox with the explanation of an WinExecError
|
---|
1165 | var
|
---|
1166 | S: string;
|
---|
1167 | begin
|
---|
1168 | //asm int 3 end; //KS trap
|
---|
1169 | case iErr of
|
---|
1170 | (* nye ting og sager fra win32
|
---|
1171 | SE_ERR_ACCESSDENIED Windows 95 only: The operating system denied access to the specified file.
|
---|
1172 | SE_ERR_ASSOCINCOMPLETE The filename association is incomplete or invalid.
|
---|
1173 | SE_ERR_DDEBUSY The DDE transaction could not be completed because other DDE transactions were being processed.
|
---|
1174 | SE_ERR_DDEFAIL The DDE transaction failed.
|
---|
1175 | SE_ERR_DDETIMEOUT The DDE transaction could not be completed because the request timed out.
|
---|
1176 | SE_ERR_DLLNOTFOUND Windows 95 only: The specified dynamic-link library was not found.
|
---|
1177 | SE_ERR_FNF Windows 95 only: The specified file was not found.
|
---|
1178 | SE_ERR_NOASSOC There is no application associated with the given filename extension.
|
---|
1179 | SE_ERR_OOM Windows 95 only: There was not enough memory to complete the operation.
|
---|
1180 | SE_ERR_PNF Windows 95 only: The specified path was not found.
|
---|
1181 | SE_ERR_SHARE A sharing violation occurred.
|
---|
1182 | *)
|
---|
1183 |
|
---|
1184 | 0:
|
---|
1185 | S := 'The operating system is out of memory or resources,'+CrLf+
|
---|
1186 | 'the executable file was corrupt, or'+CrLf+
|
---|
1187 | 'relocations were invalid';
|
---|
1188 | ERROR_FILE_NOT_FOUND:
|
---|
1189 | S := 'The specified file was not found' + CrLf + sCmdLine;
|
---|
1190 | ERROR_PATH_NOT_FOUND:
|
---|
1191 | S := 'The specified path was not found' + CrLf + sCmdLine;
|
---|
1192 | //ERROR_TOO_MANY_OPEN_FILES:
|
---|
1193 | 5:
|
---|
1194 | S := 'Attempt was made to dynamically link to a task, or there'
|
---|
1195 | + ' was a sharing or network-protection error.';
|
---|
1196 | 6:
|
---|
1197 | S := 'Library required separate data segments for each task.';
|
---|
1198 | 8:
|
---|
1199 | S := 'There was insufficient memory to start the application.';
|
---|
1200 | 10:
|
---|
1201 | S := 'Windows version was incorrect.';
|
---|
1202 | ERROR_BAD_FORMAT:
|
---|
1203 | S := 'The .EXE file is invalid (non-Win32 .EXE or error in .EXE image)';
|
---|
1204 | 12:
|
---|
1205 | S := 'Application was designed for a different operating system.';
|
---|
1206 | 13:
|
---|
1207 | S := 'Application was designed for MS-DOS 4.0.';
|
---|
1208 | 14:
|
---|
1209 | S := 'Type of executable file was unknown.';
|
---|
1210 | 15:
|
---|
1211 | S := 'Attempt was made to load a real-mode application'
|
---|
1212 | + ' (developed for an earlier version of Windows).';
|
---|
1213 | 16:
|
---|
1214 | S := 'Attempt was made to load a second instance of an'
|
---|
1215 | + ' executable file containing multiple data segments'
|
---|
1216 | + ' that were not marked read-only.';
|
---|
1217 | 19:
|
---|
1218 | S := 'Attempt was made to load a compressed executable file.'
|
---|
1219 | + ' The file must be decompressed before it can be loaded.';
|
---|
1220 | 20:
|
---|
1221 | S := 'Dynamic-link library (DLL) file was invalid. One of the'
|
---|
1222 | + ' DLLs required to run this application was corrupt.';
|
---|
1223 | 21:
|
---|
1224 | S := 'Application requires 32-bit extensions.';
|
---|
1225 | end;
|
---|
1226 |
|
---|
1227 | KSMessageE(S, 'Win Exe Error');
|
---|
1228 | end;
|
---|
1229 | //------------------------------------------------------------------------------
|
---|
1230 | procedure PrintWordDoc(const fil: string; handle: HWND);
|
---|
1231 | var
|
---|
1232 | Hwnd: Thandle;
|
---|
1233 | begin
|
---|
1234 | //asm int 3 end; //KS trap
|
---|
1235 | Hwnd := GetWindowFromText('Microsoft Word');
|
---|
1236 | // Hvis word er aktiv så minimer > så kan der printes i baggrunden
|
---|
1237 | if hwnd > 0
|
---|
1238 | then ShowWindow(hwnd, SW_HIDE); //hvis word ikke er aktiv må vi finde os i forgrunds-print
|
---|
1239 |
|
---|
1240 | Hwnd := ShellExecute(handle, 'Print', Pchar(Fil), nil, nil, SW_HIDE);
|
---|
1241 | if Hwnd < 32
|
---|
1242 | then WinExecError(Hwnd, ExtractFileName(fil)); {vis fejlen}
|
---|
1243 |
|
---|
1244 | end;
|
---|
1245 | //------------------------------------------------------------------------------
|
---|
1246 | Function GetFileAsText(const afile: String): String;
|
---|
1247 | var
|
---|
1248 | iFileHandle: Integer;
|
---|
1249 | iFileLength: Integer;
|
---|
1250 | begin
|
---|
1251 | //asm int 3 end; //trap
|
---|
1252 | result := '';
|
---|
1253 | if FileExists(afile)
|
---|
1254 | then begin
|
---|
1255 | iFileHandle := FileOpen(afile, fmOpenRead);
|
---|
1256 | try
|
---|
1257 | iFileLength := FileSeek(iFileHandle, 0, 2);
|
---|
1258 | FileSeek(iFileHandle, 0, 0);
|
---|
1259 | SetLength(Result, iFileLength);
|
---|
1260 | FileRead(iFileHandle, Result[1], iFileLength);
|
---|
1261 | finally
|
---|
1262 | FileClose(iFileHandle);
|
---|
1263 | end;
|
---|
1264 |
|
---|
1265 | if length(Trim(Result)) > 500
|
---|
1266 | then DeveloperMessage('Reading file: ' +afile+ DblCrLf + Trim(Copy(Result, 1, 500) + DblCrLf +'{ Snip }'))
|
---|
1267 | else DeveloperMessage('Reading file: ' +afile+ DblCrLf + Trim(Result));
|
---|
1268 | end
|
---|
1269 | else DeveloperMessage('Failed to read file: ' +afile);
|
---|
1270 | end;
|
---|
1271 | //------------------------------------------------------------------------------
|
---|
1272 | function SaveTextAsFile(const afile, Text: String): Boolean;
|
---|
1273 | var
|
---|
1274 | //F: TextFile;
|
---|
1275 | aHandle: THandle;
|
---|
1276 | dwRead: DWORD;
|
---|
1277 | begin
|
---|
1278 | //asm int 3 end; //KS trap
|
---|
1279 | result := false;
|
---|
1280 |
|
---|
1281 | aHandle := CreateFile(Pchar(afile), GENERIC_WRITE, 0, nil, CREATE_ALWAYS, 0,0);
|
---|
1282 |
|
---|
1283 | if aHandle = INVALID_HANDLE_VALUE
|
---|
1284 | then begin
|
---|
1285 | KSMessageE('Failed to create file: '+CrLf+afile);
|
---|
1286 | exit;
|
---|
1287 | end;
|
---|
1288 | try
|
---|
1289 | result := WriteFile(aHandle, PChar(Text)^, Length(Text), dwRead, nil);
|
---|
1290 | if not result
|
---|
1291 | then begin
|
---|
1292 | KSMessageE('Failed to write to file: '+CrLf+afile);
|
---|
1293 | exit;
|
---|
1294 | end;
|
---|
1295 | finally
|
---|
1296 | if not CloseHandle(aHandle)
|
---|
1297 | then KSMessageE('Failed to close file handle: '+CrLf+afile);
|
---|
1298 | end;
|
---|
1299 |
|
---|
1300 | (*
|
---|
1301 | AssignFile(F, afile);
|
---|
1302 | try
|
---|
1303 | Rewrite(F);
|
---|
1304 | Write(F, Text);
|
---|
1305 | finally
|
---|
1306 | CloseFile(F);
|
---|
1307 | end;
|
---|
1308 | *)
|
---|
1309 | end;
|
---|
1310 | //------------------------------------------------------------------------------
|
---|
1311 | function GetUserCookie: string;
|
---|
1312 | begin
|
---|
1313 | //asm int 3 end; //KS trap
|
---|
1314 | Result := Trim(GetFileAsText(GetWinDir + 'KSUserCookie'));
|
---|
1315 | end;
|
---|
1316 | //------------------------------------------------------------------------------
|
---|
1317 | var
|
---|
1318 | NetUserName: string = '';
|
---|
1319 |
|
---|
1320 | //------------------------------------------------------------------------------
|
---|
1321 | function KSGetNetUserName(const aResource: string = '?'): string;
|
---|
1322 | begin
|
---|
1323 | //asm int 3 end; //trap
|
---|
1324 | if Length(NetUserName) = 0 //not initialized
|
---|
1325 | then GetNetUserName(aResource);
|
---|
1326 |
|
---|
1327 | Result := NetUserName;
|
---|
1328 | end;
|
---|
1329 | //------------------------------------------------------------------------------
|
---|
1330 | function KSGetUserName(Uppercase: boolean = true): string;
|
---|
1331 | var
|
---|
1332 | pcUser: PChar;
|
---|
1333 | dwUSize: Cardinal;
|
---|
1334 |
|
---|
1335 | //-----------------------------------------------
|
---|
1336 | function GetCaseUserName: string;
|
---|
1337 | begin
|
---|
1338 | if Uppercase
|
---|
1339 | then Result := AnsiUpperCase(NetUserName)
|
---|
1340 | else result := NetUserName;
|
---|
1341 |
|
---|
1342 | //if Pos('\', result) > 0 //a win 95 returns NetUserName without "domain\"
|
---|
1343 | //then SplitAtToken(result, '\');
|
---|
1344 | end;
|
---|
1345 | //-----------------------------------------------
|
---|
1346 | begin
|
---|
1347 | //asm int 3 end; //KS trap
|
---|
1348 | if Length(NetUserName) > 0 //already initialized
|
---|
1349 | then begin
|
---|
1350 | result := GetCaseUserName;
|
---|
1351 | exit;
|
---|
1352 | end;
|
---|
1353 |
|
---|
1354 | //first try NetUser
|
---|
1355 | NetUserName := GetNetUserName('?'); //this returns Domaine\user for users
|
---|
1356 | if length(NetUserName) > 0 //from a forign domaine
|
---|
1357 | then begin
|
---|
1358 | result := GetCaseUserName;
|
---|
1359 | exit;
|
---|
1360 | end;
|
---|
1361 |
|
---|
1362 | //then try PC-user
|
---|
1363 | dwUSize := 21; // user name can be up to 20 characters
|
---|
1364 | GetMem(pcUser, dwUSize);
|
---|
1365 | try
|
---|
1366 | if GetUserName(pcUser, dwUSize)
|
---|
1367 | then begin
|
---|
1368 | NetUserName := Trim(pcUser);
|
---|
1369 | if length(NetUserName) > 0
|
---|
1370 | then begin
|
---|
1371 | result := GetCaseUserName;
|
---|
1372 | exit;
|
---|
1373 | end;
|
---|
1374 | end;
|
---|
1375 | finally
|
---|
1376 | FreeMem(pcUser);
|
---|
1377 | end;
|
---|
1378 |
|
---|
1379 | //we only come heir if NetUser and PC-user is not getting any result
|
---|
1380 | //get User from "Cookie"
|
---|
1381 | NetUserName := GetUserCookie;
|
---|
1382 |
|
---|
1383 | if Length(NetUserName) > 0
|
---|
1384 | then Result := GetCaseUserName
|
---|
1385 | else KSMessageE('This computer dos''ent return any'+ CrLf +
|
---|
1386 | 'NetUser- or PC-user name.'+ DblCrLf +
|
---|
1387 | 'You must put a user name in:'+ CrLf +
|
---|
1388 | GetWinDir+'KSUserCookie');
|
---|
1389 | end;
|
---|
1390 | //------------------------------------------------------------------------------
|
---|
1391 | Function GetFirstNetworkDrive: string;
|
---|
1392 | var
|
---|
1393 | dtDrive: TDriveType;
|
---|
1394 | AllDrives: string;
|
---|
1395 | I: Integer;
|
---|
1396 | begin
|
---|
1397 | //asm int 3 end; //trap
|
---|
1398 | Result := '';
|
---|
1399 |
|
---|
1400 | AllDrives := KSGetLogicalDrives;
|
---|
1401 |
|
---|
1402 | for I := 1 to Length(AllDrives) do
|
---|
1403 | begin
|
---|
1404 | dtDrive := TDriveType(GetDriveType(PChar(AllDrives[i]+':\')));
|
---|
1405 |
|
---|
1406 | if dtDrive = dtNetwork // it's a connected network drive
|
---|
1407 | then begin
|
---|
1408 | Result := AllDrives[i]+':';
|
---|
1409 | break;
|
---|
1410 | end;
|
---|
1411 | end;
|
---|
1412 | end;
|
---|
1413 | //------------------------------------------------------------------------------
|
---|
1414 | function GetNetUserName(const aResource: string = ''): string;
|
---|
1415 | // aResource = drive to get Log In Name from - if blank we use the first net-drive
|
---|
1416 | var
|
---|
1417 | pcUser: PChar;
|
---|
1418 | dwUSize: Cardinal;
|
---|
1419 | _aResource: String;
|
---|
1420 | begin
|
---|
1421 | //asm int 3 end; //trap
|
---|
1422 | if ((length(aResource) = 0) or (aResource = '?'))and
|
---|
1423 | (length(NetUserName) > 0) //no need to call net more than once
|
---|
1424 | then begin
|
---|
1425 | result := NetUserName;
|
---|
1426 | exit;
|
---|
1427 | end;
|
---|
1428 |
|
---|
1429 |
|
---|
1430 | Result := '';
|
---|
1431 | dwUSize := 21; // user name can be up to 20 characters
|
---|
1432 | GetMem(pcUser, dwUSize); // allocate memory for the string
|
---|
1433 | try
|
---|
1434 | if aResource = '?'
|
---|
1435 | then _aResource := GetFirstNetworkDrive
|
---|
1436 | else _aResource := aResource;
|
---|
1437 |
|
---|
1438 | if NO_ERROR = WNetGetUser(Pchar(_aResource), pcUser, dwUSize)
|
---|
1439 | then begin
|
---|
1440 | Result := Trim(pcUser);
|
---|
1441 |
|
---|
1442 | if (aResource = '?') //if no drive letter used then save default NetUserName
|
---|
1443 | then begin
|
---|
1444 | NetUserName := Result;
|
---|
1445 |
|
---|
1446 | //at siemens the network-user is returned like this SIEDK\KS
|
---|
1447 | //if (Pos('\', Result) > 0)
|
---|
1448 | //then Result := afterLastToken(Result, '\');
|
---|
1449 | end;
|
---|
1450 | end;
|
---|
1451 | finally
|
---|
1452 | FreeMem(pcUser);
|
---|
1453 | end;
|
---|
1454 | end;
|
---|
1455 | //------------------------------------------------------------------------------
|
---|
1456 | function GetWinDir: string;
|
---|
1457 | //Returns the windows directory
|
---|
1458 | var
|
---|
1459 | pcWindowsDirectory: PChar;
|
---|
1460 | dwWDSize: Cardinal;
|
---|
1461 | begin
|
---|
1462 | //asm int 3 end; //trap
|
---|
1463 | if length(ActualWinDir)= 0
|
---|
1464 | then begin
|
---|
1465 | dwWDSize := MAX_PATH + 1;
|
---|
1466 | GetMem(pcWindowsDirectory, dwWDSize); // allocate memory for the string
|
---|
1467 | try
|
---|
1468 | if Windows.GetWindowsDirectory(pcWindowsDirectory, dwWDSize) <> 0
|
---|
1469 | then ActualWinDir := strEndSlash(pcWindowsDirectory);
|
---|
1470 | finally
|
---|
1471 | FreeMem(pcWindowsDirectory); // now free the memory allocated for the string
|
---|
1472 | end;
|
---|
1473 | end;
|
---|
1474 |
|
---|
1475 | result := ActualWinDir;
|
---|
1476 | end;
|
---|
1477 | //------------------------------------------------------------------------------
|
---|
1478 | function KSGetSystemDirectory: string;
|
---|
1479 | //Returns system directory
|
---|
1480 | var
|
---|
1481 | pcSystemDirectory: PChar;
|
---|
1482 | dwSDSize: Cardinal;
|
---|
1483 | begin
|
---|
1484 | //asm int 3 end; //KS trap
|
---|
1485 | dwSDSize := MAX_PATH + 1;
|
---|
1486 | GetMem(pcSystemDirectory, dwSDSize); // allocate memory for the string
|
---|
1487 | try
|
---|
1488 | if Windows.GetSystemDirectory(pcSystemDirectory, dwSDSize) <> 0
|
---|
1489 | then Result := strEndSlash(pcSystemDirectory);
|
---|
1490 | finally
|
---|
1491 | FreeMem(pcSystemDirectory); // now free the memory allocated for the string
|
---|
1492 | end;
|
---|
1493 | end;
|
---|
1494 | //------------------------------------------------------------------------------
|
---|
1495 | function KSGetSystemTime: string;
|
---|
1496 | //returns date and time
|
---|
1497 | var
|
---|
1498 | stSystemTime: TSystemTime;
|
---|
1499 | begin
|
---|
1500 | //asm int 3 end; //trap
|
---|
1501 | Windows.GetSystemTime(stSystemTime);
|
---|
1502 | Result := DateTimeToStr(SystemTimeToDateTime(stSystemTime));
|
---|
1503 | end;
|
---|
1504 | //------------------------------------------------------------------------------
|
---|
1505 | function KSFileGetDateTime(const aFile: string): TDateTime;
|
---|
1506 | begin
|
---|
1507 | //asm int 3 end; //KS trap
|
---|
1508 | Result := FileDateToDateTime(FileAge(aFile));
|
---|
1509 | end;
|
---|
1510 | //------------------------------------------------------------------------------
|
---|
1511 | function KSCompareFileTime(const FileNameOne, FileNameTwo: string; ComparisonType:
|
---|
1512 | TTimeOfWhat): TFileTimeComparision;
|
---|
1513 | //Compares two files timestamps
|
---|
1514 | // NB der er vistnok vrøvl med alt andet end ftLastWriteTime
|
---|
1515 | var
|
---|
1516 | FileOneFileTime: TFileTime;
|
---|
1517 | FileTwoFileTime: TFileTime;
|
---|
1518 | begin
|
---|
1519 | //asm int 3 end; //trap
|
---|
1520 | Result := ftError;
|
---|
1521 |
|
---|
1522 | if FileExists(FileNameOne) and FileExists(FileNameTwo)
|
---|
1523 | then begin
|
---|
1524 | FileOneFileTime := KSGetFileTime(FileNameOne, ComparisonType);
|
---|
1525 | FileTwoFileTime := KSGetFileTime(FileNameTwo, ComparisonType);
|
---|
1526 |
|
---|
1527 | case Windows.CompareFileTime(FileOneFileTime, FileTwoFileTime) of
|
---|
1528 | - 1: Result := ftFileOneIsOlder;
|
---|
1529 | 0: Result := ftFileTimesAreEqual;
|
---|
1530 | 1: Result := ftFileTwoIsOlder;
|
---|
1531 | end;
|
---|
1532 | end
|
---|
1533 | else Result := ftError;
|
---|
1534 | end;
|
---|
1535 | //------------------------------------------------------------------------------
|
---|
1536 | function GetFileTimeEx(const FileName: string; ComparisonType: TTimeOfWhat): TDateTime;
|
---|
1537 | // Returns the date and time that a file was created, last accessed, or last modified as TDateTime
|
---|
1538 | // NB der er vistnok vrøvl med alt andet end ftLastWriteTime
|
---|
1539 | var
|
---|
1540 | SystemTime: TSystemTime;
|
---|
1541 | FileTime: TFileTime;
|
---|
1542 | begin
|
---|
1543 | //asm int 3 end; //KS trap
|
---|
1544 | Result := StrToDate('31' + DateSeparator + '12' + DateSeparator + '9999');
|
---|
1545 |
|
---|
1546 | FileTime := KSGetFileTime(FileName, ComparisonType);
|
---|
1547 | if FileTimeToSystemTime(FileTime, SystemTime)
|
---|
1548 | then Result := SystemTimeToDateTime(SystemTime); // Convert to TDateTime and return
|
---|
1549 |
|
---|
1550 | end;
|
---|
1551 | //------------------------------------------------------------------------------
|
---|
1552 | function GetLogicalPathFromUNC(var aUNC :string): Boolean;
|
---|
1553 | var
|
---|
1554 | S,S1: string;
|
---|
1555 | I: Integer;
|
---|
1556 | UNC: string;
|
---|
1557 | begin
|
---|
1558 | //asm int 3 end; //KS trap
|
---|
1559 | Result := False;
|
---|
1560 |
|
---|
1561 | UNC := Lowercase(aUNC);
|
---|
1562 |
|
---|
1563 | S := KSGetLogicalDrives;
|
---|
1564 |
|
---|
1565 | for I := 1 to Length(S) do
|
---|
1566 | begin
|
---|
1567 | S1 := Lowercase(ExpandUNCFileName(S[i]+':\'));
|
---|
1568 | if pos(s1, UNC) = 1
|
---|
1569 | then begin
|
---|
1570 | Delete(aUNC, 1, Length(S1)-1);
|
---|
1571 | Insert(S[i]+':', aUNC, 1);
|
---|
1572 | result := True;
|
---|
1573 | break;
|
---|
1574 | end;
|
---|
1575 | end;
|
---|
1576 | end;
|
---|
1577 | //------------------------------------------------------------------------------
|
---|
1578 | function KSGetFileTime(const FileName: string; ComparisonType: TTimeOfWhat): TFileTime;
|
---|
1579 | // Returns the date and time that a file was created, last accessed, or last modified
|
---|
1580 | // NB der er vistnok vrøvl med alt andet end ftLastWriteTime
|
---|
1581 | var
|
---|
1582 | FileTime, LocalFileTime: TFileTime;
|
---|
1583 | hFile: THandle;
|
---|
1584 | //AFileName: string;
|
---|
1585 | begin
|
---|
1586 | //asm int 3 end; //trap
|
---|
1587 | // initialize TFileTime record in case of error
|
---|
1588 | Result.dwLowDateTime := 0;
|
---|
1589 | Result.dwHighDateTime := 0;
|
---|
1590 |
|
---|
1591 | hFile := FileOpen(FileName, fmOpenRead{fmShareDenyNone});
|
---|
1592 | try
|
---|
1593 | if hFile <> 0
|
---|
1594 | then begin
|
---|
1595 | case ComparisonType of
|
---|
1596 | ftCreationTime: Windows.GetFileTime(hFile, @FileTime, nil, nil);
|
---|
1597 | ftLastAccessTime: Windows.GetFileTime(hFile, nil, @FileTime, nil);
|
---|
1598 | ftLastWriteTime: Windows.GetFileTime(hFile, nil, nil, @FileTime);
|
---|
1599 | end; // case FileTimeOf
|
---|
1600 |
|
---|
1601 | // Change the file time to local time
|
---|
1602 | FileTimeToLocalFileTime(FileTime, LocalFileTime);
|
---|
1603 | Result := LocalFileTime;
|
---|
1604 | end; // if hFile <> 0
|
---|
1605 | finally
|
---|
1606 | FileClose(hFile);
|
---|
1607 | end; // try
|
---|
1608 | end;
|
---|
1609 | //------------------------------------------------------------------------------
|
---|
1610 | Function GetFreeDiskSize(TheDrive: String):Int64;
|
---|
1611 | //NB husk C:\
|
---|
1612 | var
|
---|
1613 | TheSize : int64;
|
---|
1614 | begin
|
---|
1615 | //asm int 3 end; //KS trap
|
---|
1616 | GetDiskFreeSpaceEx(Pchar(TheDrive), Result, TheSize, nil);
|
---|
1617 | end;
|
---|
1618 | //------------------------------------------------------------------------------
|
---|
1619 | function KSGetCurrentDirectory: string;
|
---|
1620 | //Returns the current directory for the current process
|
---|
1621 | var
|
---|
1622 | nBufferLength: Cardinal; // size, in characters, of directory buffer
|
---|
1623 | lpBuffer: PChar; // address of buffer for current directory
|
---|
1624 | begin
|
---|
1625 | //asm int 3 end; //KS trap
|
---|
1626 | GetMem(lpBuffer, MAX_PATH + 1);
|
---|
1627 | nBufferLength := 100;
|
---|
1628 | try
|
---|
1629 | if Windows.GetCurrentDirectory(nBufferLength, lpBuffer) > 0
|
---|
1630 | then Result := strEndSlash(lpBuffer);
|
---|
1631 | finally
|
---|
1632 | FreeMem(lpBuffer);
|
---|
1633 | end; // try
|
---|
1634 | end;
|
---|
1635 | //------------------------------------------------------------------------------
|
---|
1636 | function FileSizeEx(const FileName: string): LongInt;
|
---|
1637 | //returns the size of a file in bytes
|
---|
1638 | var
|
---|
1639 | (*
|
---|
1640 | hFile: THandle; // handle of file to get size of
|
---|
1641 | lpFileSizeHigh: Cardinal; // address of high-order word for file size
|
---|
1642 |
|
---|
1643 | f: file of Byte;
|
---|
1644 | fileSize: Integer;
|
---|
1645 | *)
|
---|
1646 | //ret: Integer;
|
---|
1647 | sResult: TSearchRec;
|
---|
1648 | begin
|
---|
1649 | //asm int 3 end; //KS trap
|
---|
1650 | if 0 = SysUtils.FindFirst(filename, faAnyFile, sResult)
|
---|
1651 | then result := sResult.Size
|
---|
1652 | else result := -1;
|
---|
1653 |
|
---|
1654 | SysUtils.FindClose(sResult);
|
---|
1655 |
|
---|
1656 | (*
|
---|
1657 | Result := -1;
|
---|
1658 | hFile := FileOpen(FileName, fmOpenRead);
|
---|
1659 | try
|
---|
1660 | if hFile <> 0
|
---|
1661 | then begin
|
---|
1662 | Result := Windows.GetFileSize(hFile, @lpFileSizeHigh);
|
---|
1663 | //if result = -1
|
---|
1664 | //then KSMessageE(GetLastErrorStr);
|
---|
1665 |
|
---|
1666 | end;
|
---|
1667 | finally
|
---|
1668 | FileClose(hFile);
|
---|
1669 | end;
|
---|
1670 | *)
|
---|
1671 | end;
|
---|
1672 | //------------------------------------------------------------------------------
|
---|
1673 | function ShortFileNameToLFN(ShortName: String):String;
|
---|
1674 | var
|
---|
1675 | temp: TWIN32FindData;
|
---|
1676 | searchHandle: THandle;
|
---|
1677 | begin
|
---|
1678 | //asm int 3 end; //KS trap
|
---|
1679 | searchHandle := FindFirstFile(PChar(ShortName), temp);
|
---|
1680 |
|
---|
1681 | if searchHandle <> ERROR_INVALID_HANDLE
|
---|
1682 | then result := String(temp.cFileName)
|
---|
1683 | else result := '';
|
---|
1684 |
|
---|
1685 | Windows.FindClose(searchHandle);
|
---|
1686 | end;
|
---|
1687 | //------------------------------------------------------------------------------
|
---|
1688 | function GetFullPathNameEx(const Path: string): string;
|
---|
1689 | //Returns the full path and filename of a specified file
|
---|
1690 | var
|
---|
1691 | nBufferLength: Cardinal; // size, in characters, of path buffer
|
---|
1692 | lpBuffer: PChar; // address of path buffer
|
---|
1693 | lpFilePart: PChar; // address of filename in path
|
---|
1694 | begin
|
---|
1695 | //asm int 3 end; //KS trap
|
---|
1696 | Result := '';
|
---|
1697 | nBufferLength := MAX_PATH + 1;
|
---|
1698 | GetMem(lpBuffer, MAX_PATH + 1);
|
---|
1699 | GetMem(lpFilePart, MAX_PATH + 1);
|
---|
1700 | try
|
---|
1701 | if Windows.GetFullPathName(PChar(Path), nBufferLength, lpBuffer, lpFilePart) <> 0
|
---|
1702 | then Result := lpBuffer;
|
---|
1703 | finally
|
---|
1704 | FreeMem(lpBuffer);
|
---|
1705 | FreeMem(lpFilePart);
|
---|
1706 | end;
|
---|
1707 | end;
|
---|
1708 | //------------------------------------------------------------------------------
|
---|
1709 | function GetFirstAviableDriveLetter: string;
|
---|
1710 | //Returns the first available disk drives letter
|
---|
1711 | var
|
---|
1712 | S: string;
|
---|
1713 | I: Integer;
|
---|
1714 | begin
|
---|
1715 | //asm int 3 end; //KS trap
|
---|
1716 | Result := '';
|
---|
1717 | S := UpperCase(KSGetLogicalDrives); //this is used letters
|
---|
1718 |
|
---|
1719 | while (Length(S) > 0) and (S[1] in ['A'..'C']) do
|
---|
1720 | Delete(S, 1, 1); //skip A, B and C
|
---|
1721 |
|
---|
1722 | for I := 1 to Length(S) do
|
---|
1723 | if (Ord(S[I]) - 67) <> I //first posible char = D ~ 68
|
---|
1724 | then begin
|
---|
1725 | Result := Succ(S[I -1]); //first letter after last letter "in sync"
|
---|
1726 | break;
|
---|
1727 | end;
|
---|
1728 | end;
|
---|
1729 | //------------------------------------------------------------------------------
|
---|
1730 | function KSGetLogicalDrives: string;
|
---|
1731 | //Returns a string that contains the currently available disk drives
|
---|
1732 | var
|
---|
1733 | drives: set of 0..25;
|
---|
1734 | drive: integer;
|
---|
1735 | begin
|
---|
1736 | //asm int 3 end; //trap
|
---|
1737 | Result := '';
|
---|
1738 | Cardinal(drives) := Windows.GetLogicalDrives;
|
---|
1739 | for drive := 0 to 25
|
---|
1740 | do
|
---|
1741 | if drive in drives
|
---|
1742 | then Result := Result + Chr(drive + Ord('A'));
|
---|
1743 | end;
|
---|
1744 | //------------------------------------------------------------------------------
|
---|
1745 | function KSDelete(var S: String; DeleteString: String; All: Boolean = False): boolean;
|
---|
1746 | var
|
---|
1747 | I: Integer;
|
---|
1748 | begin
|
---|
1749 | //asm int 3 end; //trap
|
---|
1750 | i := Pos(DeleteString, S);
|
---|
1751 | if I > 0
|
---|
1752 | then begin
|
---|
1753 | delete(S, i, length(DeleteString));
|
---|
1754 | Result := True;
|
---|
1755 | end
|
---|
1756 | else Result := False;
|
---|
1757 |
|
---|
1758 | if all and result //se if there is more to delete
|
---|
1759 | then begin
|
---|
1760 | i := Pos(DeleteString, S);
|
---|
1761 | while I > 0 do
|
---|
1762 | begin
|
---|
1763 | delete(S, i, length(DeleteString));
|
---|
1764 | i := Pos(DeleteString, S);
|
---|
1765 | end;
|
---|
1766 | end;
|
---|
1767 | end;
|
---|
1768 | //------------------------------------------------------------------------------
|
---|
1769 | function squish(const Search: string): string;
|
---|
1770 | {squish() returns a string with all whitespace not inside single
|
---|
1771 | quotes deleted.}
|
---|
1772 | var
|
---|
1773 | Index: byte;
|
---|
1774 | InString: boolean;
|
---|
1775 | begin
|
---|
1776 | //asm int 3 end; //trap
|
---|
1777 | InString := False;
|
---|
1778 | Result := '';
|
---|
1779 | for Index := 1 to Length(Search)
|
---|
1780 | do begin
|
---|
1781 | if InString or (Search[Index] in BlackSpace)
|
---|
1782 | then AppendStr(Result, Search[Index]);
|
---|
1783 | InString := ((Search[Index] = '''') and (Search[Index - 1] <> '\')) xor InString;
|
---|
1784 | end;
|
---|
1785 | end;
|
---|
1786 | //------------------------------------------------------------------------------
|
---|
1787 | function before(const Search, Find: string): string;
|
---|
1788 | {before() returns everything before the first occurance of Find
|
---|
1789 | in Search. If Find does not occur in Search, Search is returned.}
|
---|
1790 | var
|
---|
1791 | index: byte;
|
---|
1792 | begin
|
---|
1793 | //asm int 3 end; //trap
|
---|
1794 | index := Pos(Find, Search);
|
---|
1795 | if index = 0
|
---|
1796 | then Result := Search
|
---|
1797 | else Result := Copy(Search, 1, index - 1);
|
---|
1798 | end;
|
---|
1799 | //------------------------------------------------------------------------------
|
---|
1800 | function beforeX(const Search, Find: string): string;
|
---|
1801 | {before() returns everything before the first occurance of Find
|
---|
1802 | in Search. If Find does not occur in Search, An empty string is returned.}
|
---|
1803 | var
|
---|
1804 | index: byte;
|
---|
1805 | begin
|
---|
1806 | //asm int 3 end; //trap
|
---|
1807 | index := Pos(Find, Search);
|
---|
1808 | if index = 0
|
---|
1809 | then Result := ''
|
---|
1810 | else Result := Copy(Search, 1, index - 1);
|
---|
1811 | end;
|
---|
1812 | //------------------------------------------------------------------------------
|
---|
1813 | function after(const Search, Find: string): string;
|
---|
1814 | {after() returns everything after the first occurance of Find
|
---|
1815 | in Search. If Find does not occur in Search, a null string is returned.}
|
---|
1816 | var
|
---|
1817 | index: byte;
|
---|
1818 | begin
|
---|
1819 | //asm int 3 end; //trap
|
---|
1820 | index := Pos(Find, Search);
|
---|
1821 | if index = 0
|
---|
1822 | then Result := ''
|
---|
1823 | else Result := Copy(Search, index + Length(Find), Length(Search));
|
---|
1824 | end;
|
---|
1825 | //------------------------------------------------------------------------------
|
---|
1826 | function LastChar(const Search: string; const Find: char): Integer;
|
---|
1827 | begin
|
---|
1828 | //asm int 3 end; //KS trap
|
---|
1829 | Result := Length(Search);
|
---|
1830 |
|
---|
1831 | while (Result > 0) and (Search[Result] <> Find) do
|
---|
1832 | Dec(Result);
|
---|
1833 | end;
|
---|
1834 | //------------------------------------------------------------------------------
|
---|
1835 | function RPos(const Find, Search: string): Integer;
|
---|
1836 | {RPos() returns the index of the first character of the last occurance
|
---|
1837 | of Find in Search. Returns 0 if Find does not occur in Search.
|
---|
1838 | Like Pos() but searches in reverse.}
|
---|
1839 | var
|
---|
1840 | Quit : Boolean;
|
---|
1841 | Pos,Len : Integer;
|
---|
1842 | begin
|
---|
1843 | //asm int 3 end; //trap
|
---|
1844 | result := 0;
|
---|
1845 | Len := Length(Find);
|
---|
1846 | if (Len = 0) or (length(Search) = 0)
|
---|
1847 | then exit;
|
---|
1848 |
|
---|
1849 | Quit:= False;
|
---|
1850 |
|
---|
1851 | Pos := Length(Search)+ 1 - Len;
|
---|
1852 | while not Quit do
|
---|
1853 | begin
|
---|
1854 | if (Search[pos] = Find[1]) and //speed it up
|
---|
1855 | (Copy(Search,Pos,Len) = Find)
|
---|
1856 | then begin
|
---|
1857 | result := Pos;
|
---|
1858 | Quit:= True;
|
---|
1859 | end;
|
---|
1860 |
|
---|
1861 | if Pos = 1 //not found
|
---|
1862 | then Quit:= True;
|
---|
1863 |
|
---|
1864 | Dec(Pos,1);
|
---|
1865 | end;
|
---|
1866 |
|
---|
1867 | end;
|
---|
1868 | //------------------------------------------------------------------------------
|
---|
1869 | function AfterLastToken(const StrInd, Token: string): string;
|
---|
1870 | //Returns the right part of StrInd that comes after Token
|
---|
1871 | begin
|
---|
1872 | //asm int 3 end; //trap
|
---|
1873 | result := copy(StrInd, RPos(Token, StrInd) + 1, length(StrInd));
|
---|
1874 | end;
|
---|
1875 | //------------------------------------------------------------------------------
|
---|
1876 | function KSSameText(S1, S2: string; MaxLen: Cardinal): boolean;
|
---|
1877 | begin
|
---|
1878 | Result := 2 = CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE,
|
---|
1879 | PChar(S1), MaxLen, PChar(S2), MaxLen);
|
---|
1880 | end;
|
---|
1881 | //------------------------------------------------------------------------------
|
---|
1882 | function BeforLastToken(const StrIn, Token: string): string;
|
---|
1883 | //Returns the left part of StrInd that comes before last Token
|
---|
1884 | //if no token found then StrInd is returned
|
---|
1885 | var
|
---|
1886 | I: Integer;
|
---|
1887 | begin
|
---|
1888 | //asm int 3 end; //trap
|
---|
1889 | i := Rpos(Token, StrIn);//LastDelimiter(Token, StrIn);
|
---|
1890 | if I = 0
|
---|
1891 | then result := StrIn
|
---|
1892 | else result := copy(StrIn, 1, I-1);
|
---|
1893 | end;
|
---|
1894 | //------------------------------------------------------------------------------
|
---|
1895 | type
|
---|
1896 | TFindHwndRec = record
|
---|
1897 | FoundWnd: HWND;
|
---|
1898 | WindowTekst: array[0..50] of Char;
|
---|
1899 | LenWindowTekst: Word;
|
---|
1900 | end;
|
---|
1901 |
|
---|
1902 | PFindHwndRec = ^TFindHwndRec;
|
---|
1903 | //------------------------------------------------------------------------------
|
---|
1904 | function EnumWindowsProc(WndBeingChecked: HWND; rec: PFindHwndRec): Bool; export; stdcall;
|
---|
1905 | {callback funktionen som window kalder tilbage til efter EnumWindows}
|
---|
1906 | var
|
---|
1907 | p: array[0..100] of Char;
|
---|
1908 | begin
|
---|
1909 | //asm int 3 end; //KS trap
|
---|
1910 | Result := True;
|
---|
1911 |
|
---|
1912 | if (GetWindowText(WndBeingChecked, p, 99) >= rec^.LenWindowTekst)
|
---|
1913 | and (pos(rec^.WindowTekst, p) > 0)
|
---|
1914 | then begin //(strCompLeft(rec^.WindowTekst, p)
|
---|
1915 | rec^.FoundWnd := WndBeingChecked;
|
---|
1916 | Result := False;
|
---|
1917 | end; {afbryd, windows-handle er nu fundet}
|
---|
1918 |
|
---|
1919 | end;
|
---|
1920 | //------------------------------------------------------------------------------
|
---|
1921 | function GetWindowFromText(const WindowText: string): Hwnd;
|
---|
1922 | {returnere en handle til vinduet hvis WindowText findes i caption}
|
---|
1923 | var
|
---|
1924 | rec: TFindHwndRec;
|
---|
1925 | begin
|
---|
1926 | //asm int 3 end; //KS trap
|
---|
1927 | {gem søgestrengen så callback-funktionen kan læse den}
|
---|
1928 | StrPcopy(rec.WindowTekst, WindowText);
|
---|
1929 | rec.LenWindowTekst := word(Length(WindowText));
|
---|
1930 | if rec.LenWindowTekst > 48
|
---|
1931 | then KSMessageE('It is maximum posible to search for 49 characters [function GetWindowFromText])');
|
---|
1932 | rec.FoundWnd := 0; {rturværdi hvis window ikke findes}
|
---|
1933 |
|
---|
1934 | EnumWindows(@EnumWindowsProc, Longint(@rec));
|
---|
1935 |
|
---|
1936 | Result := rec.FoundWnd
|
---|
1937 | end;
|
---|
1938 | //------------------------------------------------------------------------------
|
---|
1939 | function DropLastDir(path: string): string;
|
---|
1940 | //fjerner sidste directory fra stien i path
|
---|
1941 | begin
|
---|
1942 | //asm int 3 end; //KS trap
|
---|
1943 | if path[Length(path)] = '\'
|
---|
1944 | then Delete(path, Length(path), 1);
|
---|
1945 |
|
---|
1946 | Result := Copy(path, 1, RPos('\', path));
|
---|
1947 | end;
|
---|
1948 | //------------------------------------------------------------------------------
|
---|
1949 | function CtrlDown: Boolean;
|
---|
1950 | var
|
---|
1951 | State: TKeyboardState;
|
---|
1952 | begin
|
---|
1953 | //asm int 3 end; //KS trap
|
---|
1954 | GetKeyboardState(State);
|
---|
1955 | Result := ((State[vk_Control] and 128) <> 0);
|
---|
1956 | end;
|
---|
1957 | //------------------------------------------------------------------------------
|
---|
1958 | function FileDifferent(const Sourcefile: string; TargetPath: string): Boolean;
|
---|
1959 | var
|
---|
1960 | TargetFil: string;
|
---|
1961 | begin
|
---|
1962 | //asm int 3 end; //KS trap
|
---|
1963 | Result := True;
|
---|
1964 |
|
---|
1965 | if not Fileexists(Sourcefile)
|
---|
1966 | then exit;
|
---|
1967 |
|
---|
1968 | TargetPath := strEndSlash(TargetPath);
|
---|
1969 | TargetFil := TargetPath + ExtractFileName(Sourcefile);
|
---|
1970 |
|
---|
1971 | if not Fileexists(TargetFil)
|
---|
1972 | then exit;
|
---|
1973 |
|
---|
1974 | if ftFileTimesAreEqual <> KSCompareFileTime(TargetFil, Sourcefile, ftLastWriteTime)
|
---|
1975 | then exit;
|
---|
1976 |
|
---|
1977 | //hvis de er ens skifter Result til False og funktionen returnere med false
|
---|
1978 | Result := fileSizeEx(Sourcefile) <> fileSizeEx(TargetFil);
|
---|
1979 | end;
|
---|
1980 | //------------------------------------------------------------------------------
|
---|
1981 | function GetErrorString(var aFmtStr: String; ErrorCode: Integer): boolean;
|
---|
1982 | var
|
---|
1983 | Buf: array [Byte] of Char;
|
---|
1984 | begin
|
---|
1985 | //asm int 3 end; //KS trap
|
---|
1986 | Result := (0 = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, ErrorCode,
|
---|
1987 | LOCALE_USER_DEFAULT, Buf, sizeof(Buf), nil));
|
---|
1988 | if result
|
---|
1989 | then aFmtStr := 'Call to FormatMessage failed in:'+CrLf+'function GetErrorString'
|
---|
1990 | else aFmtStr := Buf;
|
---|
1991 |
|
---|
1992 | end;
|
---|
1993 | //------------------------------------------------------------------------------
|
---|
1994 | function GetSystemErrorMessage(var aFmtStr: String; ErrorAccept: Integer = ERROR_SUCCESS): boolean;
|
---|
1995 | //returns true if an error is found
|
---|
1996 | var
|
---|
1997 | ErrorCode: Integer;
|
---|
1998 | begin
|
---|
1999 | //asm int 3 end; //KS trap
|
---|
2000 | aFmtStr := '';
|
---|
2001 | ErrorCode := GetLastError;
|
---|
2002 | result := (ErrorCode <> ERROR_SUCCESS) and (ErrorCode <> ErrorAccept);
|
---|
2003 |
|
---|
2004 | if result
|
---|
2005 | then GetErrorString(aFmtStr, ErrorCode);
|
---|
2006 | end;
|
---|
2007 | //------------------------------------------------------------------------------
|
---|
2008 | function GetLastErrorStr: string;
|
---|
2009 | var
|
---|
2010 | S: string;
|
---|
2011 | begin
|
---|
2012 | //asm int 3 end; //KS trap
|
---|
2013 | GetSystemErrorMessage(S);
|
---|
2014 | result := S;
|
---|
2015 | end;
|
---|
2016 | //------------------------------------------------------------------------------
|
---|
2017 | function ShowLastErrorIfAny(anError: Integer; Handle: Hwnd = 0): Boolean;
|
---|
2018 | begin
|
---|
2019 | //asm int 3 end; //KS trap
|
---|
2020 | Result := True;
|
---|
2021 | if anError > 32
|
---|
2022 | then exit
|
---|
2023 | else Result := False;
|
---|
2024 |
|
---|
2025 | KSMessageE(GetLastErrorStr);
|
---|
2026 | end;
|
---|
2027 | //------------------------------------------------------------------------------
|
---|
2028 | function KSSetCurrentDir(const Dir: string): Boolean;
|
---|
2029 | begin
|
---|
2030 | //asm int 3 end; //trap
|
---|
2031 | result := DirExists(Dir);
|
---|
2032 | if result
|
---|
2033 | then Result := SetCurrentDirectory(PChar(Dir));
|
---|
2034 | end;
|
---|
2035 | //------------------------------------------------------------------------------
|
---|
2036 | function DelDir(aDir: string): boolean;
|
---|
2037 | //Remove a directory including all content
|
---|
2038 | var
|
---|
2039 | SHFileOpStruct: TSHFileOpStruct;
|
---|
2040 | begin
|
---|
2041 | fillchar(SHFileOpStruct, sizeof(TSHFileOpStruct), 0);
|
---|
2042 | with SHFileOpStruct do
|
---|
2043 | begin
|
---|
2044 | Wnd := 0; {form1.handle}
|
---|
2045 | wFunc := FO_DELETE;
|
---|
2046 | pFrom := pchar(NoEndBackSlash(aDir) + #0#0);
|
---|
2047 | pTo := nil;
|
---|
2048 | fFlags := FOF_NOCONFIRMATION or FOF_SILENT;
|
---|
2049 | lpszProgressTitle := nil; {'Deleting '+path;}
|
---|
2050 | end;
|
---|
2051 |
|
---|
2052 | result := SHFileOperation(SHFileOpStruct) = 0;
|
---|
2053 | end;
|
---|
2054 | //------------------------------------------------------------------------------
|
---|
2055 | function KSEmptyDir(aDir: string): Boolean;
|
---|
2056 | //Clears all files and subdirectories from directory
|
---|
2057 | var
|
---|
2058 | SearchRec : TSearchRec;
|
---|
2059 | begin
|
---|
2060 | //asm int 3 end; //trap
|
---|
2061 |
|
---|
2062 | result := (0 = findfirst(aDir + '\*.*', faAnyFile, SearchRec)); {first always '.' }
|
---|
2063 |
|
---|
2064 | While (findnext(SearchRec) = 0) Do
|
---|
2065 | if not(SearchRec.Name = '..') {skip '..' to}
|
---|
2066 | then begin
|
---|
2067 | if (SearchRec.Attr and faDirectory) > 0
|
---|
2068 | then result := result and DelDir(aDir + '\' + Searchrec.name)
|
---|
2069 | else result := result and Deletefile(aDir + '\' + SearchRec.name);
|
---|
2070 | end;
|
---|
2071 |
|
---|
2072 | FindClose(SearchRec);
|
---|
2073 | end;
|
---|
2074 | //------------------------------------------------------------------------------
|
---|
2075 | function KSForceDirectories(Dir: string): Boolean;
|
---|
2076 | begin
|
---|
2077 | //asm int 3 end; //trap
|
---|
2078 | if Length(Dir) = 0
|
---|
2079 | then begin
|
---|
2080 | KSMessageE('Cant create directory');
|
---|
2081 | Result := False;
|
---|
2082 | end
|
---|
2083 | else begin
|
---|
2084 | Result := True;
|
---|
2085 |
|
---|
2086 | Dir := ExcludeTrailingBackslash(Dir);
|
---|
2087 | if (Length(Dir) < 3) or DirExists(Dir) or (ExtractFilePath(Dir) = Dir)
|
---|
2088 | then Exit; // avoid 'xyz:\' problem.
|
---|
2089 |
|
---|
2090 | Result := KSForceDirectories(ExtractFilePath(Dir)) and CreateDir(Dir);
|
---|
2091 | end;
|
---|
2092 | end;
|
---|
2093 | //------------------------------------------------------------------------------
|
---|
2094 | function GetShareFromURN(const URN: string; var Share: string; aPath: string = ''): boolean;
|
---|
2095 | begin
|
---|
2096 | //asm int 3 end; //KS trap
|
---|
2097 | if pos('\\', URN) = 1
|
---|
2098 | then begin { \\bupb0f4a\program\..... }
|
---|
2099 | result := true;
|
---|
2100 | Share := BeforeTokenNr(URN, '\', 4) + '\'+ aPath;
|
---|
2101 | end
|
---|
2102 | else result := False;
|
---|
2103 | end;
|
---|
2104 | //------------------------------------------------------------------------------
|
---|
2105 | function GetFileDateAsString(aFile: string): String;
|
---|
2106 | begin
|
---|
2107 | //asm int 3 end; //KS trap
|
---|
2108 | result := IntToStr(FileAge(aFile))
|
---|
2109 | end;
|
---|
2110 | //------------------------------------------------------------------------------
|
---|
2111 | function GetUTCFileDateAsString(aFile: string): String;
|
---|
2112 | begin
|
---|
2113 | //asm int 3 end; //KS trap
|
---|
2114 | result := IntToStr(UTCFileAge(aFile))
|
---|
2115 | end;
|
---|
2116 | //------------------------------------------------------------------------------
|
---|
2117 | function UTCFileAge(const FileName: string): Integer;
|
---|
2118 | //get UTC-based file time (no conversion to local time)
|
---|
2119 | var
|
---|
2120 | Handle: THandle;
|
---|
2121 | FindData: TWin32FindData;
|
---|
2122 | //LocalFileTime: TFileTime;
|
---|
2123 | //S, S1: String;
|
---|
2124 | begin
|
---|
2125 | //asm int 3 end; //KS trap
|
---|
2126 |
|
---|
2127 | Handle := FindFirstFile(PChar(FileName), FindData);
|
---|
2128 | if Handle <> INVALID_HANDLE_VALUE
|
---|
2129 | then begin
|
---|
2130 | Windows.FindClose(Handle);
|
---|
2131 | if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0
|
---|
2132 | then begin
|
---|
2133 | (*
|
---|
2134 | FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);
|
---|
2135 | FileTimeToDosDateTime(LocalFileTime, LongRec(Result).Hi, LongRec(Result).Lo);
|
---|
2136 | S := DateTimeToStr(FileDateToDateTime(Result)); //local time
|
---|
2137 | //exit;
|
---|
2138 |
|
---|
2139 | FileTimeToDosDateTime(FindData.ftLastWriteTime, LongRec(Result).Hi, LongRec(Result).Lo);
|
---|
2140 | S1 := DateTimeToStr(FileDateToDateTime(Result)); //UTC time
|
---|
2141 | *)
|
---|
2142 | if FileTimeToDosDateTime(FindData.ftLastWriteTime, LongRec(Result).Hi, LongRec(Result).Lo)
|
---|
2143 | then Exit;
|
---|
2144 | end;
|
---|
2145 | end;
|
---|
2146 |
|
---|
2147 | Result := -1;
|
---|
2148 | end;
|
---|
2149 | //------------------------------------------------------------------------------
|
---|
2150 | function DosLocalTimeToDosUTCTime(aDosFileTime: Integer): Integer;
|
---|
2151 | var
|
---|
2152 | aFileTime: TFileTime;
|
---|
2153 | aLocalFileTime: TFileTime;
|
---|
2154 | begin
|
---|
2155 | //asm int 3 end; //KS trap
|
---|
2156 |
|
---|
2157 | //convert to UTC time
|
---|
2158 | //S := DateTimeToStr(FileDateToDateTime(aDosFileTime));
|
---|
2159 | DosDateTimeToFileTime(LongRec(aDosFileTime).Hi, LongRec(aDosFileTime).Lo, aLocalFileTime);
|
---|
2160 | LocalFileTimeToFileTime(aLocalFileTime, aFileTime);
|
---|
2161 | FileTimeToDosDateTime(aFileTime, LongRec(result).Hi, LongRec(result).Lo);
|
---|
2162 | //S := DateTimeToStr(FileDateToDateTime(result));
|
---|
2163 |
|
---|
2164 | //result is now UTC filetime
|
---|
2165 |
|
---|
2166 | end;
|
---|
2167 | //------------------------------------------------------------------------------
|
---|
2168 | Function GetShortDateTime(aTime: TDateTime; Seconds: boolean = false): String;
|
---|
2169 | var
|
---|
2170 | OldShortDateFormat: string;
|
---|
2171 | begin
|
---|
2172 | //asm int 3 end; //KS trap
|
---|
2173 |
|
---|
2174 | OldShortDateFormat := ShortDateFormat;
|
---|
2175 | ShortDateFormat := 'dd.mm.yy';
|
---|
2176 | try
|
---|
2177 | result := DateTimeToStr(aTime);
|
---|
2178 | if not Seconds
|
---|
2179 | then result := BeforLastToken(result, TimeSeparator); //drop seconds
|
---|
2180 | finally
|
---|
2181 | ShortDateFormat := OldShortDateFormat;
|
---|
2182 | end;
|
---|
2183 | end;
|
---|
2184 | //------------------------------------------------------------------------------
|
---|
2185 | Function GetFileDateTime(aFile: string): String;
|
---|
2186 | //var
|
---|
2187 | //OldShortDateFormat: string;
|
---|
2188 | begin
|
---|
2189 | //asm int 3 end; //KS trap
|
---|
2190 | if Not FileExists(aFile)
|
---|
2191 | then result := 'Error'
|
---|
2192 | else result := GetShortDateTime(FileDateToDateTime(FileAge(aFile)));
|
---|
2193 | end;
|
---|
2194 | //------------------------------------------------------------------------------
|
---|
2195 | Function GetModuleName(aFile: string = ''): String;
|
---|
2196 | var
|
---|
2197 | ModuleName: array[0..255] of Char;
|
---|
2198 | begin
|
---|
2199 | //asm int 3 end; //trap
|
---|
2200 | if length(aFile) = 0
|
---|
2201 | then GetModuleFileName(GetModuleHandle(Nil), ModuleName, SizeOf(ModuleName))
|
---|
2202 | else GetModuleFileName(GetModuleHandle(Pchar(aFile)), ModuleName, SizeOf(ModuleName));
|
---|
2203 | result := ModuleName;
|
---|
2204 | end;
|
---|
2205 | //------------------------------------------------------------------------------
|
---|
2206 | function GetBoxHead(aBoxHead, aDefault: string): string;
|
---|
2207 | begin
|
---|
2208 | //asm int 3 end; //trap
|
---|
2209 | if length(ActualAppName) = 0 //only set default one time
|
---|
2210 | then ActualAppName := LowerCase(ExtractFileName(GetModuleName));
|
---|
2211 |
|
---|
2212 | if length(aBoxHead) = 0
|
---|
2213 | then result := ActualAppName + ': ' + aDefault
|
---|
2214 | else result := ActualAppName + ': ' + aBoxHead;
|
---|
2215 | end;
|
---|
2216 | //------------------------------------------------------------------------------
|
---|
2217 | function KSMessage(aMessage: string; aBoxHead: string; Params: integer): integer;
|
---|
2218 | begin
|
---|
2219 | //asm int 3 end; //trap
|
---|
2220 | result := MessageBox(0, Pchar(aMessage), Pchar(aBoxHead), Params or
|
---|
2221 | MB_TASKMODAL or MB_TOPMOST or MB_SETFOREGROUND);
|
---|
2222 |
|
---|
2223 | { posible button flags:
|
---|
2224 | MB_ABORTRETRYIGNORE, MB_OK, MB_OKCANCEL, MB_RETRYCANCEL, MB_YESNO, MB_YESNOCANCEL
|
---|
2225 | MB_DEFBUTTON2, MB_DEFBUTTON3, MB_DEFBUTTON4 - MB_DEFBUTTON1 is default
|
---|
2226 |
|
---|
2227 | MB_ICONWARNING, MB_ICONINFORMATION, MB_ICONQUESTION, MB_ICONERROR.
|
---|
2228 |
|
---|
2229 | posible resulte:
|
---|
2230 | IDABORT, IDCANCEL, IDIGNORE, IDNO, IDOK, IDRETRY, IDYES }
|
---|
2231 | end;
|
---|
2232 |
|
---|
2233 | //------------------------------------------------------------------------------
|
---|
2234 | function KSQuestion(aMessage: string; aBoxHead: string = ''; Params: integer = MB_ICONQUESTION or MB_YESNO): integer;
|
---|
2235 | begin
|
---|
2236 | //asm int 3 end; //trap
|
---|
2237 | result := KSMessage(aMessage, GetBoxHead(aBoxHead, 'Question'), Params);
|
---|
2238 | end;
|
---|
2239 | //------------------------------------------------------------------------------
|
---|
2240 | Procedure KSMessageI(aMessage: string; aBoxHead: string = '');
|
---|
2241 | begin
|
---|
2242 | KSMessage(aMessage, GetBoxHead(aBoxHead, 'Information'), MB_ICONINFORMATION or MB_OK)
|
---|
2243 | end;
|
---|
2244 | //------------------------------------------------------------------------------
|
---|
2245 | Procedure KSMessageQ(aMessage: string; aBoxHead: string = '');
|
---|
2246 | begin
|
---|
2247 | KSMessage(aMessage, GetBoxHead(aBoxHead, 'Question'), MB_ICONQUESTION or MB_OK);
|
---|
2248 | end;
|
---|
2249 | //------------------------------------------------------------------------------
|
---|
2250 | Procedure KSMessageE(aMessage: string; aBoxHead: string = '');
|
---|
2251 | begin
|
---|
2252 | KSMessage(aMessage, GetBoxHead(aBoxHead, 'Error'), MB_ICONERROR or MB_OK);
|
---|
2253 | end;
|
---|
2254 | //------------------------------------------------------------------------------
|
---|
2255 | Procedure KSMessageW(aMessage: string; aBoxHead: string = '');
|
---|
2256 | begin
|
---|
2257 | KSMessage(aMessage, GetBoxHead(aBoxHead, 'Warning'), MB_ICONWARNING or MB_OK);
|
---|
2258 | end;
|
---|
2259 | //------------------------------------------------------------------------------
|
---|
2260 | Procedure KSMessageT(aMessage: string; aBoxHead: string = '');
|
---|
2261 | begin
|
---|
2262 | KSMessageI(aMessage, aBoxHead);
|
---|
2263 | end;
|
---|
2264 | //------------------------------------------------------------------------------
|
---|
2265 | const
|
---|
2266 | NewBlock: string = '-----------------------------------------'+ #13+#10+#13+#10;
|
---|
2267 |
|
---|
2268 | //------------------------------------------------------------------------------
|
---|
2269 | function SaveDeveloperMessagesLog(afile: string): boolean;
|
---|
2270 | begin
|
---|
2271 | //asm int 3 end; //KS trap
|
---|
2272 | result := SaveTextAsFile(afile, DeveloperMessagesLog);
|
---|
2273 | if result
|
---|
2274 | then DeveloperMessagesLog := '';
|
---|
2275 | end;
|
---|
2276 | //------------------------------------------------------------------------------
|
---|
2277 | function CloseDeveloperMessagesLog(afile: string): boolean;
|
---|
2278 | begin
|
---|
2279 | //asm int 3 end; //KS trap
|
---|
2280 | if ShowDeveloperMessages
|
---|
2281 | then begin
|
---|
2282 | DeveloperMessagesLog := DeveloperMessagesLog+ 'Log ended at: '+ DateTimeToStr(now)+ DblCrLf+ NewBlock;
|
---|
2283 |
|
---|
2284 | result := SaveTextAsFile(afile, DeveloperMessagesLog);
|
---|
2285 | if result
|
---|
2286 | then DeveloperMessagesLog := ''
|
---|
2287 | else KsMessageE('"Developer messages log" could not be saved to:'+CrLf+ afile);
|
---|
2288 | end
|
---|
2289 | else result := false;
|
---|
2290 | end;
|
---|
2291 | //------------------------------------------------------------------------------
|
---|
2292 | procedure DeveloperMessage(aMessage: string);
|
---|
2293 |
|
---|
2294 | begin
|
---|
2295 | //asm int 3 end; //trap
|
---|
2296 | if ShowDeveloperMessages
|
---|
2297 | then begin
|
---|
2298 | if length(DeveloperMessagesLog) = 0
|
---|
2299 | then begin
|
---|
2300 | DeveloperMessagesLog := 'Developer messages log for:'+CrLf+
|
---|
2301 | 'Appe name: '+ActualAppName+ CrLf+
|
---|
2302 | 'User: '+ KSGetUserName+CrLf+
|
---|
2303 | 'Log started at: '+ GetShortDateTime(now) + DblCrLf+
|
---|
2304 | //DateTimeToStr(now)
|
---|
2305 | NewBlock;
|
---|
2306 |
|
---|
2307 | end;
|
---|
2308 |
|
---|
2309 | DeveloperMessagesLog := DeveloperMessagesLog + aMessage + DblCrLf + NewBlock;
|
---|
2310 |
|
---|
2311 | //by instalation DeveloperMessagesCanceled := True; is set at program start
|
---|
2312 | //i.e. in the beginning of KnowHow.dpr
|
---|
2313 |
|
---|
2314 | if DeveloperMessagesCanceled
|
---|
2315 | then exit;
|
---|
2316 |
|
---|
2317 | DeveloperMessagesCanceled := (IDCANCEL = KSQuestion('Developer message' + DblCrLf+ aMessage, 'Information',
|
---|
2318 | MB_ICONINFORMATION or MB_OKCANCEL));
|
---|
2319 | end;
|
---|
2320 | end;
|
---|
2321 | //------------------------------------------------------------------------------
|
---|
2322 | procedure OpenDeveloperMessagesLog;
|
---|
2323 | const
|
---|
2324 | Stars: string = '*****************************************'+ #13+#10;
|
---|
2325 | var
|
---|
2326 | tmpFile: String;
|
---|
2327 | begin
|
---|
2328 | //asm int 3 end; //KS trap
|
---|
2329 | if ShowDeveloperMessages
|
---|
2330 | then begin
|
---|
2331 | tmpFile := fileTemp('.txt');
|
---|
2332 | DeveloperMessagesLog := DeveloperMessagesLog + 'Log opened at: '+
|
---|
2333 | DateTimeToStr(now)+ DblCrLf+ Stars + Stars+ NewBlock;
|
---|
2334 |
|
---|
2335 | if SaveTextAsFile(tmpFile, DeveloperMessagesLog)
|
---|
2336 | then ExecuteDefaultOpen('txt', tmpFile)
|
---|
2337 | else KSMessageE('Creation of '+tmpFile+' failed');
|
---|
2338 | end
|
---|
2339 | else KSMessageI('Developer messages log is not open');
|
---|
2340 | end;
|
---|
2341 | //------------------------------------------------------------------------------
|
---|
2342 | function IsAlNum(C: char): bool;
|
---|
2343 | begin
|
---|
2344 | //asm int 3 end; //trap
|
---|
2345 | result := C in ['0'..'9', 'A'..'Z', 'a'..'z', 'À'..'ÿ'];
|
---|
2346 | end;
|
---|
2347 | //------------------------------------------------------------------------------
|
---|
2348 | procedure SearchForFiles(path, mask: AnsiString; var Value: TStringList; Recurse: Boolean = False);
|
---|
2349 | //path = rootdir
|
---|
2350 | //fileMask = *.db, *.*, ....osv
|
---|
2351 | //value = stringlist til at modtage resultate af søgningen
|
---|
2352 | //Recurse = True -> recursering af foldere under path
|
---|
2353 | var
|
---|
2354 | srRes : TSearchRec;
|
---|
2355 | iFound : Integer;
|
---|
2356 | begin
|
---|
2357 | //asm int 3 end; //KS trap
|
---|
2358 | if (Recurse) // First, we must search the directories
|
---|
2359 | then begin
|
---|
2360 | if path[Length(path)] <> '\' then path := path +'\';
|
---|
2361 | iFound := FindFirst(path + '*.*', faAnyfile, srRes);
|
---|
2362 | while iFound = 0
|
---|
2363 | do begin
|
---|
2364 | if (srRes.Name <> '.') and (srRes.Name <> '..')
|
---|
2365 | then if srRes.Attr and faDirectory > 0
|
---|
2366 | then SearchForFiles(path + srRes.Name, mask, Value, Recurse);//recurse folder
|
---|
2367 | iFound := FindNext(srRes);
|
---|
2368 | end;
|
---|
2369 | FindClose(srRes);
|
---|
2370 | end;
|
---|
2371 |
|
---|
2372 | // Now, we don't treat the directories anymore
|
---|
2373 |
|
---|
2374 | if path[Length(path)] <> '\' then path := path +'\';
|
---|
2375 |
|
---|
2376 | iFound := FindFirst(path + mask, faAnyFile-faDirectory {any file but not folders}, srRes);
|
---|
2377 | while iFound = 0 {0 ~ true}
|
---|
2378 | do begin
|
---|
2379 | if (srRes.Name <> '.') and (srRes.Name <> '..') and (srRes.Name <> '')
|
---|
2380 | then Value.Add(path + srRes.Name);
|
---|
2381 | iFound := FindNext(srRes);
|
---|
2382 | end;
|
---|
2383 |
|
---|
2384 | FindClose(srRes);
|
---|
2385 |
|
---|
2386 | end;
|
---|
2387 | //------------------------------------------------------------------------------
|
---|
2388 | type
|
---|
2389 | TRegProc = function : HResult; stdcall;
|
---|
2390 | //------------------------------------------------------------------------------
|
---|
2391 | function RegisterAxLib(FileName: string; Unreg: Boolean = False): boolean;
|
---|
2392 | var
|
---|
2393 | LibHandle: THandle;
|
---|
2394 | RegProc: TRegProc;
|
---|
2395 | DllProc: String;
|
---|
2396 | begin
|
---|
2397 | //asm int 3 end; //KS trap
|
---|
2398 | Result := False;
|
---|
2399 |
|
---|
2400 | LibHandle := LoadLibrary(PChar(FileName));
|
---|
2401 | if LibHandle = 0
|
---|
2402 | then begin
|
---|
2403 | KSMessageE('Failed to load:'+DblCrLf+FileName);
|
---|
2404 | exit;
|
---|
2405 | end;
|
---|
2406 | try
|
---|
2407 | if Unreg
|
---|
2408 | then DllProc := 'DllUnregisterServer'
|
---|
2409 | else DllProc := 'DllRegisterServer';
|
---|
2410 |
|
---|
2411 | @RegProc := GetProcAddress(LibHandle, Pchar(DllProc));
|
---|
2412 | if @RegProc = Nil
|
---|
2413 | then KSMessageE(DllProc+' procedure not found in:'+DblCrLf+FileName)
|
---|
2414 | else if RegProc <> 0 //run register process
|
---|
2415 | then KSMessageE('Call to '+DllProc+' failed in:'+DblCrLf+FileName)
|
---|
2416 | else Result := True; //success - the dll is Reg- / Unregistered
|
---|
2417 | finally
|
---|
2418 | FreeLibrary(LibHandle);
|
---|
2419 | end;
|
---|
2420 | end;
|
---|
2421 | //------------------------------------------------------------------------------
|
---|
2422 | //------------------------------------------------------------------------------
|
---|
2423 | procedure KSWait(aTime: Cardinal);
|
---|
2424 | //waits unthil aTime (in miliseconds) is elapsed
|
---|
2425 | var
|
---|
2426 | T: Cardinal;
|
---|
2427 | begin
|
---|
2428 | //asm int 3 end; //trap
|
---|
2429 | T := GetTickCount + aTime;
|
---|
2430 | while T > GetTickCount do
|
---|
2431 | KSProcessMessages;
|
---|
2432 | end;
|
---|
2433 | //------------------------------------------------------------------------------
|
---|
2434 | procedure KSProcessMessages;
|
---|
2435 | var
|
---|
2436 | Msg: TMsg;
|
---|
2437 |
|
---|
2438 | //-----------------------
|
---|
2439 | function ProcessMessage(var Msg: TMsg): Boolean;
|
---|
2440 | begin
|
---|
2441 | Result := False;
|
---|
2442 | if PeekMessage(Msg, 0, 0, 0, PM_REMOVE)
|
---|
2443 | then begin
|
---|
2444 | Result := True;
|
---|
2445 | if Msg.Message = WM_QUIT
|
---|
2446 | then begin
|
---|
2447 | {Re-post quit message so main message loop will terminate}
|
---|
2448 | PostQuitMessage(Msg.WParam)
|
---|
2449 | end
|
---|
2450 | else begin
|
---|
2451 | TranslateMessage(Msg);
|
---|
2452 | DispatchMessage(Msg);
|
---|
2453 | end;
|
---|
2454 | end;
|
---|
2455 | end;
|
---|
2456 | //-----------------------
|
---|
2457 | begin
|
---|
2458 | //asm int 3 end; //trap
|
---|
2459 | while ProcessMessage(Msg) do
|
---|
2460 | {loop};
|
---|
2461 | end;
|
---|
2462 | //------------------------------------------------------------------------------
|
---|
2463 | function _GetExeOpen(const Ext: string; var Exefil: string; sielent: boolean = true): Boolean;
|
---|
2464 | { find app associated with the extension of filename.
|
---|
2465 | Since file must exist we create a dummy file}
|
---|
2466 | var
|
---|
2467 | Dir, Name: string;
|
---|
2468 | res: array[1..250] of char;
|
---|
2469 | err: integer;
|
---|
2470 | F: TFileStream;
|
---|
2471 | //dummyFileCreated: boolean;
|
---|
2472 | filename: string;
|
---|
2473 | begin
|
---|
2474 | //asm int 3 end; //KS trap
|
---|
2475 |
|
---|
2476 | filename := KSGetTempPath + '~~~~~~~~.'+Ext;
|
---|
2477 | F:= TFileStream.create (filename, fmCreate);
|
---|
2478 | F.free;
|
---|
2479 |
|
---|
2480 | Dir:= extractFilePath(FileName) + #0;
|
---|
2481 | Name:= extractFileName(FileName) + #0;
|
---|
2482 | fillchar(res,SizeOf(res),' ');
|
---|
2483 | res[250]:= #0;
|
---|
2484 | err:= FindExecutable(@Name[1],@Dir[1],@res);
|
---|
2485 | if err >= 32
|
---|
2486 | then begin
|
---|
2487 | Exefil := strPas(@res);
|
---|
2488 | result := true;
|
---|
2489 | end
|
---|
2490 | else begin
|
---|
2491 | if not Sielent
|
---|
2492 | then KSMessageE('No default program for "'+Ext+'"');
|
---|
2493 | result:= false;
|
---|
2494 | Exefil := '';
|
---|
2495 | end;
|
---|
2496 |
|
---|
2497 | deletefile(filename);
|
---|
2498 | end;
|
---|
2499 | //------------------------------------------------------------------------------
|
---|
2500 | function GetAbsolutePath(ActualPath: string; var RelativePath: string): boolean;
|
---|
2501 | var
|
---|
2502 | S: string;
|
---|
2503 | ActualForSlashes: Boolean;
|
---|
2504 | ActualP: String;
|
---|
2505 | RelativeP: String;
|
---|
2506 | NewPath: String;
|
---|
2507 | begin
|
---|
2508 | //asm int 3 end; //KS trap
|
---|
2509 | result := false;
|
---|
2510 |
|
---|
2511 | if pos('/', ActualPath) > 0
|
---|
2512 | then begin
|
---|
2513 | ActualForSlashes := true;
|
---|
2514 | ActualP := StringReplace(ActualPath, '/', '\', [rfReplaceAll]);
|
---|
2515 | //ChangeAllToken(ActualPath, '/', '\');
|
---|
2516 | end
|
---|
2517 | else begin
|
---|
2518 | ActualForSlashes := False;
|
---|
2519 | ActualP := ActualPath;
|
---|
2520 | end;
|
---|
2521 |
|
---|
2522 | ActualP := NoEndBackSlash(ActualP);
|
---|
2523 |
|
---|
2524 | if pos('/', RelativePath) > 0
|
---|
2525 | then RelativeP := StringReplace(ActualPath, '/', '\', [rfReplaceAll])
|
---|
2526 | else RelativeP := RelativePath;
|
---|
2527 |
|
---|
2528 | RelativeP := NoEndBackSlash(RelativeP);
|
---|
2529 |
|
---|
2530 | if pos('..\', RelativeP) = 1
|
---|
2531 | then begin
|
---|
2532 | result := true;
|
---|
2533 | S := BeforLastToken(NoEndBackSlash(ActualP), '\'); //go up one level
|
---|
2534 | NewPath := after(RelativeP, '\'); //go up one level
|
---|
2535 |
|
---|
2536 | While pos('..\', NewPath) > 0 do
|
---|
2537 | begin
|
---|
2538 | S := BeforLastToken(S, '\'); //go up one level
|
---|
2539 | NewPath := after(NewPath, '\'); //go up one level
|
---|
2540 | end;
|
---|
2541 |
|
---|
2542 | NewPath := S +'\'+ NewPath;
|
---|
2543 | end
|
---|
2544 | else begin
|
---|
2545 | if RelativeP[1] = '\'
|
---|
2546 | then begin
|
---|
2547 | NewPath := ActualP + RelativeP;
|
---|
2548 | result := true;
|
---|
2549 | end
|
---|
2550 | else NewPath := RelativeP;
|
---|
2551 | end;
|
---|
2552 |
|
---|
2553 | if result
|
---|
2554 | then begin
|
---|
2555 | if ActualForSlashes
|
---|
2556 | then RelativePath := StringReplace(NewPath, '\', '/', [rfReplaceAll])
|
---|
2557 | //ChangeAllToken(NewPath, '\', '/')
|
---|
2558 | else RelativePath := NewPath;
|
---|
2559 | end;
|
---|
2560 | end;
|
---|
2561 | //------------------------------------------------------------------------------
|
---|
2562 |
|
---|
2563 | end.
|
---|
2564 |
|
---|
2565 |
|
---|
2566 |
|
---|
2567 |
|
---|
2568 |
|
---|
2569 |
|
---|
2570 |
|
---|
2571 |
|
---|
2572 |
|
---|