source: cprs/branches/tmg-cprs/CPRS-Chart/TMG_Extra/HTMLEdit/EmbeddedED/KS_procs.pas@ 1359

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

TMG Ver 1.1 Added HTML Support, better demographics editing

File size: 84.7 KB
Line 
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
32unit KS_Procs;
33
34interface
35
36uses
37 Windows, ShellAPI, Messages, SysUtils, math, classes ;
38
39Var
40 ActualAppName: string = '';
41 ShowDeveloperMessages: boolean = false;
42 DeveloperMessagesCanceled: boolean = false;
43 DeveloperMessagesLog: string = '';
44 ActualWinDir: string = '';
45
46const
47 NoShowError: Boolean = False; // NoShowError, NoCache, NoHtmlFile
48 ShowError: Boolean = true;
49 NoCache: Boolean = true;
50 NoHtmlFile: Boolean = true;
51
52const
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
66const
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
84type
85 TMonth = (NoneMonth, January, February, March, April, May, June, July,
86 August, September, October, November, December);
87
88type
89 TDayOfWeek = (Sunday, Monday, Tuesday, Wednesday, Thursday, Friday, Saturday);
90
91type
92 TBit = 0..31;
93
94type
95 TFileTimeComparision = (ftError, ftFileOneIsOlder, ftFileTimesAreEqual, ftFileTwoIsOlder);
96
97type
98 TTimeOfWhat = (ftCreationTime, ftLastAccessTime, ftLastWriteTime);
99
100type
101 TDriveType = (dtUnknown, dtNoDrive, dtFloppy, dtFixed, dtNetwork, dtCDROM, dtRAM);
102
103
104type
105 TVolumeInfo = record
106 Name: string;
107 SerialNumber: DWORD;
108 MaxComponentLength: DWORD;
109 FileSystemFlags: DWORD;
110 FileSystemName: string;
111 end; // TVolumeInfo
112
113type
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
131procedure KSProcessMessages;
132procedure KSWait(aTime: Cardinal);
133
134function CopyCursor(cur: HCURSOR): HCURSOR;
135function _GetExeOpen(const Ext: string; var Exefil: string; sielent: boolean = true): Boolean;
136Function GetModuleName(aFile: string = ''): String;
137Function GetFileDateTime(aFile: string): String;
138Function GetShortDateTime(aTime: TDateTime; Seconds: boolean = false): String;
139function GetAbsolutePath(ActualPath: string; var RelativePath: string): boolean;
140function KSMessage(aMessage: string; aBoxHead: string; Params: integer): integer;
141function KSQuestion(aMessage: string; aBoxHead: string = ''; Params: integer = MB_ICONQUESTION or MB_YESNO): integer;
142Procedure KSMessageW(aMessage: string; aBoxHead: string = '');
143Procedure KSMessageE(aMessage: string; aBoxHead: string = '');
144Procedure KSMessageQ(aMessage: string; aBoxHead: string = '');
145Procedure KSMessageI(aMessage: string; aBoxHead: string = '');
146Procedure KSMessageT(aMessage: string; aBoxHead: string = '');
147procedure DeveloperMessage(aMessage: string);
148function CloseDeveloperMessagesLog(afile: string): boolean;
149function SaveDeveloperMessagesLog(afile: string): boolean;
150procedure OpenDeveloperMessagesLog;
151
152function IsAlNum(C: char): bool;
153function RegisterAxLib(FileName: string; Unreg: Boolean = False): boolean;
154procedure SearchForFiles(path, mask: AnsiString; var Value: TStringList; Recurse: Boolean = False);
155
156function StringIsInteger(Const S: String): boolean;
157function _StringIsInteger(Const S: String; var I: Integer): boolean;
158function KSDelete(var S: String; DeleteString: String; All: Boolean = False): boolean;
159{Deletes one or more instances of S}
160
161function GetFileDateAsString(aFile: string): String;
162function DosLocalTimeToDosUTCTime(aDosFileTime: Integer): Integer;
163function GetUTCFileDateAsString(aFile: string): String;
164function UTCFileAge(const FileName: string): Integer;
165function KSSetCurrentDir(const Dir: string): Boolean;
166function KSEmptyDir( aDir: string): Boolean;
167function DelDir(aDir: string): boolean;
168function Squish(const Search: string): string;
169{squish() returns a string with all whitespace not inside single
170quotes deleted.}
171function Before(const Search, Find: string): string;
172{before() returns everything before the first occurance of Find
173in Search. If Find does not occur in Search, Search is returned.}
174function beforeX(const Search, Find: string): string;
175{before() returns everything before the first occurance of Find
176in Search. If Find does not occur in Search, An empty string is returned.}
177function After(const Search, Find: string): string;
178{after() returns everything after the first occurance of Find
179in Search. If Find does not occur in Search, a null string is returned.}
180function RPos(const Find, Search: string): Integer;
181{RPos() returns the index of the first character of the last occurance
182of Find in Search. Returns 0 if Find does not occur in Search.
183Like Pos() but searches in reverse.}
184
185function 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
189function AfterLastToken(const StrInd, Token: string): string;
190
191function KsSameText(S1, S2: string; MaxLen: Cardinal): boolean;
192//same as AnsiSameText but the string are only compared up to MaxLen
193
194function BeforLastToken(const StrIn, Token: string): string;
195function BeforeFirstToken(const S: string; Token: Char): string;
196//Returnerer alt før Token som Result
197
198function strMake(C: Char; Len: Integer): string;
199//Returns a string with a specified number of a specified Char
200function 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
204function 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
206function strChange(var S: string; const Src, Dest: string): boolean;
207//Changes every ocuranc of a text in a string with new text
208function strEndSlash(const S: string): string;
209//Returns a string with a trailing slash (\)
210function strEndSlashX(const S: string): string;
211//returns a string with a trailing slash (/)
212function NoEndBackSlash(const S: string): string;
213//Returns a string without a traling slash (\)
214
215function NoStartSlash(const S: string): string;
216//Returns a string without a leading slash (/)
217
218function SplitAtToken(var S: string; Token: Char): string;
219function SplitAtTokenStr(var S: string; Token: string): string;
220//returnerer alt før Token som Result, og alt efter Token i S
221function strTokenCount(S: string; Token: Char): Integer;
222//Returnerer antal token i S
223function AfterTokenNr(const S: string; Token: Char; Nr: Integer): string;
224//Returns the right part of an string after token (Char) Nr.
225function BeforeTokenNr(const S: string; Token: Char; Nr: Integer): string;
226//Returns the left part of an string before token (Char) Nr.
227
228function strLastCh(const S: string): string;
229//Returns the last char in a string
230
231type { Search and Replace options }
232 TSROption = (srWord, srCase, srAll);
233 TSROptions = set of TsrOption;
234
235function DropLastDir(path: string): string;
236//fjerner sidste directory fra stien i path
237
238type
239 TCharSet = set of Char;
240
241
242{ Integer functions }
243function intMax(a, b: Integer): Integer;
244//Returns the highest value
245function intMin(a, b: Integer): Integer;
246//Returns the lowest value
247
248{ date functions }
249Function DateStrToDateTime(aDate: string): TDateTime;
250Function TimeStrToDateTime(aDateTime: string): TDateTime;
251//function dateYear(D: TDateTime): Integer;
252
253function fileSizeEx(const Filename: string): Longint;
254//returns the size of a file in bytes
255
256function KSForceDirectories(Dir: string): Boolean;
257
258function GetShareFromURN(const URN: string; var Share: string; aPath: string = ''): boolean;
259
260function ExecuteFile(handle: HWND; const FileName, Params, DefaultDir: string; ShowCmd: Integer; Silent: boolean = true): THandle;
261//run an exefile
262
263function fileCopy(const SourceFile, TargetFile: string): Boolean;
264//copy a file (with date info)
265function fileMove(const SourceFile, TargetFile: string): Boolean;
266function fileTemp(const aExt: string = ''): string;
267//Returns a unique temparary filename
268function fileTempEx(const aName: string): string;
269//Returns a unique temparary filename based on the suplied filename
270
271function KSGetCurrentDirectory: string;
272//Returns the current directory for the current process
273
274function DirExists(const Name: string): Boolean;
275function GetLogicalPathFromUNC(var aUNC :string): Boolean;
276//returns a normal filepath fore a UNC-filepath
277Function GetFirstNetworkDrive: string;
278//returns the UNC-filepath fore the first network-drive
279function KSGetTempPath: string;
280//Returns the path of the directory designated for temporary files
281function KSGetLogicalDrives: string;
282//Returns a string that contains the currently available disk drives
283function GetFirstAviableDriveLetter: string;
284
285function KSGetFileTime(const FileName: string; ComparisonType: TTimeOfWhat): TFileTime;
286// Returns the date and time that a file was created, last accessed, or last modified
287
288function KSCompareFileTime(const FileNameOne, FileNameTwo: string; ComparisonType: TTimeOfWhat): TFileTimeComparision;
289//Compares two files timestamps
290function FileDifferent(const Sourcefile: string; TargetPath: string): Boolean;
291//Returnere true hvis de to filer har forskellig dato eller størrelse
292function KSFileGetDateTime(const aFile: string): TDateTime;
293//Returnere TdateTime for en fils dato
294function 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
297Function GetFreeDiskSize(TheDrive: String):Int64;
298//Returns the amount of free space on the specified disk
299function ShortFileNameToLFN(ShortName: String): String;
300function GetFullPathNameEx(const Path: string): string;
301//Returns the full path and filename of a specified file
302function 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 }
307function GetWindir: string;
308//Returns the windows directory
309procedure WinExecError(iErr: Word; const sCmdLine: string);
310//Returns a dialogbox with the explanation of an WinExecError
311
312procedure PrintWordDoc(const fil: string; handle: HWND);
313
314{System Information }
315function KSGetUserName(Uppercase: boolean = true): string;
316function GetNetUserName(const aResource: string = ''): string;
317function KSGetNetUserName(const aResource: string = '?'): string;
318function GetUserCookie: string;
319//returns current username
320Function GetFileAsText(const afile: String): String;
321function SaveTextAsFile(const afile, Text: String): Boolean;
322
323function KSGetSystemDirectory: string;
324//Returns system directory
325
326// Time Functions
327function KSGetSystemTime: string;
328//returns date and time
329
330function GetWindowFromText(const WindowText: string): Hwnd;
331{returnere en handle til vinduet hvis det findes}
332
333
334function CtrlDown: Boolean;
335
336
337function GetSystemErrorMessage(var aFmtStr: String; ErrorAccept: Integer = ERROR_SUCCESS): boolean;
338function GetErrorString(var aFmtStr: String; ErrorCode: Integer): boolean;
339
340function GetLastErrorStr: string;
341function ShowLastErrorIfAny(anError: Integer; Handle: Hwnd = 0): Boolean;
342
343implementation
344
345uses RegFuncs;
346
347//------------------------------------------------------------------------------
348function CopyCursor(cur: HCURSOR): HCURSOR;
349begin
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 }
353end;
354//------------------------------------------------------------------------------
355function _StringIsInteger(Const S: String; var I: Integer): boolean;
356{
357var
358 Err: Integer;
359begin
360 Val(S, I, Err);
361 Result := (Err = 0); This raises an error i debugging
362end;
363}
364
365var a: Integer;
366begin
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;
385end;
386//------------------------------------------------------------------------------
387function StringIsInteger(Const S: String): boolean;
388var
389 I: Integer;
390begin
391 //asm int 3 end; //trap
392 result := _StringIsInteger(S, I);
393end;
394//------------------------------------------------------------------------------
395{ bit manipulating }
396
397//------------------------------------------------------------------------------
398function strMake(C: Char; Len: Integer): string;
399//Returns a string with a specified number of a specified Char
400begin
401 //asm int 3 end; //KS trap
402 Result := strPadChL('', C, Len);
403end;
404//------------------------------------------------------------------------------
405function strPadChL(const S: string; C: Char; Len: Integer): string;
406//Fills leading Char's into a string up to a specified length
407begin
408 //asm int 3 end; //KS trap
409 Result := S;
410 while Length(Result) < Len
411 do Result := C + Result;
412end;
413//------------------------------------------------------------------------------
414function strEndSlash(const S: string): string;
415//returns a string with a trailing slash (\)
416begin
417 //asm int 3 end; //trap
418 Result := S;
419 if strLastCh(Result) <> '\'
420 then Result := Result + '\';
421end;
422//------------------------------------------------------------------------------
423function strEndSlashX(const S: string): string;
424//returns a string with a trailing slash (/)
425begin
426 //asm int 3 end; //trap
427 Result := S;
428 if strLastCh(Result) <> '/'
429 then Result := Result + '/';
430end;
431//------------------------------------------------------------------------------
432function NoEndBackSlash(const S: string): string;
433//Returns a string without a traling slash (\)
434begin
435 //asm int 3 end; //trap
436 Result := S;
437 if strLastCh(Result) = '\'
438 then Delete(Result, Length(Result), 1);
439end;
440//------------------------------------------------------------------------------
441function NoStartSlash(const S: string): string;
442//Returns a string without a leading slash (/)
443begin
444 //asm int 3 end; //KS trap
445 Result := S;
446 if (length(Result) > 0) and (Result[1] = '/')
447 then Delete(Result, 1, 1);
448end;
449//------------------------------------------------------------------------------
450function 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
453var
454 I: Word;
455begin
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;
467end;
468//------------------------------------------------------------------------------
469function BeforeFirstToken(const S: string; Token: Char): string;
470//Returnerer alt før Token som Result
471var
472 I: Word;
473begin
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
479end;
480//------------------------------------------------------------------------------
481function 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
484var
485 I: Word;
486begin
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;
498end;
499//------------------------------------------------------------------------------
500function strTokenCount(S: string; Token: Char): Integer;
501//Returns the number of Char in S
502var
503 //s1: string;
504 i: Integer;
505begin
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
520end;
521//------------------------------------------------------------------------------
522function AfterTokenNr(const S: string; Token: Char; Nr: Integer): string;
523//Returns the right part of an string after token (Char) Nr.
524var
525 j, i: Integer;
526begin
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));
544end;
545//------------------------------------------------------------------------------
546function BeforeTokenNr(const S: string; Token: Char; Nr: Integer): string;
547//Returns the left part of an string before token (Char) Nr.
548var
549 j, i: Integer;
550begin
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
569end;
570//------------------------------------------------------------------------------
571function 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
574begin
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);
579end;
580//------------------------------------------------------------------------------
581function strChange(var S: string; const Src, Dest: string): boolean;
582//Changes every ocuranc of a text in a string with new text
583var
584 Org: String;
585begin
586 //asm int 3 end; //trap
587 Org := S;
588 S := StringReplace(S, Src, Dest, [rfReplaceAll]);
589 result := not AnsiSameText(Org, S);
590end;
591//------------------------------------------------------------------------------
592function strLastCh(const S: string): string;
593//Returns the last char in a string
594var
595 i: integer;
596begin
597 //asm int 3 end; //trap
598 i := Length(S);
599 if i > 0
600 then Result := S[Length(S)]
601 else Result := '';
602end;
603//------------------------------------------------------------------------------
604{ Integer stuff }
605//------------------------------------------------------------------------------
606function IntMax(a, b: Integer): Integer;
607//Returns the highest value
608begin
609 //asm int 3 end; //trap
610 if a > b
611 then Result := a
612 else Result := b;
613end;
614//------------------------------------------------------------------------------
615function IntMin(a, b: Integer): Integer;
616//Returns the lowest value
617begin
618 //asm int 3 end; //KS trap
619 if a < b
620 then Result := a
621 else Result := b;
622end;
623//------------------------------------------------------------------------------
624function ExecuteFile(handle: HWND; const FileName, Params, DefaultDir: string; ShowCmd: Integer; Silent: boolean = true): THandle;
625begin
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);
633end;
634//------------------------------------------------------------------------------
635function fileCopy(const SourceFile, TargetFile: string): Boolean;
636begin
637 //asm int 3 end; //trap
638 Result := CopyFile(Pchar(SourceFile), Pchar(TargetFile), False);
639 // Existing file Copy of file
640end;
641//------------------------------------------------------------------------------
642function fileMove(const SourceFile, TargetFile: string): Boolean;
643begin
644 //asm int 3 end; //KS trap
645 Result := MoveFile(Pchar(SourceFile), Pchar(TargetFile));
646 // Existing file New file
647end;
648//------------------------------------------------------------------------------
649function fileTemp(const aExt: string = ''): string;
650//Returns a unique temparary filename
651var
652 Buffer: array[0..1023] of Char;
653 aFile: string;
654begin
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;
667end;
668//------------------------------------------------------------------------------
669function fileTempEx(const aName: string): string;
670//Returns a unique temparary filename based on the suplied filename
671var
672 Buffer: array[0..1023] of Char;
673 aFile: string;
674 aPath: string;
675 aExt: string;
676begin
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;
695end;
696//------------------------------------------------------------------------------
697function 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
701var
702 StartupInfo: TStartupInfo;
703 ProcessInfo: TProcessInformation;
704 dwI : Cardinal;
705 dwCreationFlags: Cardinal;
706 S, S1: string;
707 //lpExitCode: DWORD;
708 //Msg: TMsg;
709begin
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;
776end;
777//------------------------------------------------------------------------------
778{ date calculations }
779
780type
781 TDateOrder = (doMDY, doDMY, doYMD);
782
783function CurrentYear: Word;
784var
785 SystemTime: TSystemTime;
786begin
787 //asm int 3 end; //KS trap
788 GetLocalTime(SystemTime);
789 Result := SystemTime.wYear;
790end;
791//------------------------------------------------------------------------------
792function GetDateOrder(const DateFormat: string): TDateOrder;
793var
794 I: Integer;
795begin
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;
813end;
814//------------------------------------------------------------------------------
815procedure ScanToNumber(const S: string; var Pos: Integer);
816begin
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;
823end;
824//------------------------------------------------------------------------------
825function GetEraYearOffset(const Name: string): Integer;
826var
827 I: Integer;
828begin
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;
840end;
841//------------------------------------------------------------------------------
842procedure ScanBlanks(const S: string; var Pos: Integer);
843var
844 I: Integer;
845begin
846 //asm int 3 end; //KS trap
847 I := Pos;
848 while (I <= Length(S)) and (S[I] = ' ') do Inc(I);
849 Pos := I;
850end;
851//------------------------------------------------------------------------------
852function ScanNumber(const S: string; var Pos: Integer;
853 var Number: Word; var CharCount: Byte): Boolean;
854var
855 I: Integer;
856 N: Word;
857begin
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;
876end;
877//------------------------------------------------------------------------------
878function ScanString(const S: string; var Pos: Integer;
879 const Symbol: string): Boolean;
880begin
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;
892end;
893//------------------------------------------------------------------------------
894function ScanChar(const S: string; var Pos: Integer; Ch: Char): Boolean;
895begin
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;
904end;
905//------------------------------------------------------------------------------
906function DoEncodeDate(Year, Month, Day: Word; var Date: TDateTime): Boolean;
907var
908 I: Integer;
909 DayTable: PDayTable;
910begin
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;
922end;
923//------------------------------------------------------------------------------
924function ScanDate(const S: string; var Pos: Integer;
925 var Date: TDateTime): Boolean;
926var
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
948begin
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);
1011end;
1012//------------------------------------------------------------------------------
1013function DoEncodeTime(Hour, Min, Sec, MSec: Word; var Time: TDateTime): Boolean;
1014begin
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;
1022end;
1023//------------------------------------------------------------------------------
1024function ScanTime(const S: string; var Pos: Integer;
1025 var Time: TDateTime): Boolean;
1026var
1027 BaseHour: Integer;
1028 Hour, Min, Sec, MSec: Word;
1029 Junk: Byte;
1030begin
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);
1063end;
1064//------------------------------------------------------------------------------
1065
1066Function DateStrToDateTime(aDate: string): TDateTime;
1067var
1068 OldDateSeparator: Char;
1069 OldShortDateFormat: string;
1070 Pos: Integer;
1071 //S: string;
1072begin
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;
1087end;
1088
1089//------------------------------------------------------------------------------
1090Function TimeStrToDateTime(aDateTime: string): TDateTime;
1091var
1092 OldDateSeparator: Char;
1093 OldTimeSeparator: Char;
1094 OldShortDateFormat: string;
1095 Pos: Integer;
1096 Date, Time: TDateTime;
1097begin
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;
1132end;
1133//------------------------------------------------------------------------------
1134function DirExists(const Name: string): Boolean;
1135var
1136 Code: Integer;
1137begin
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);
1142end;
1143//------------------------------------------------------------------------------
1144function KSGetTempPath: string;
1145//Returns the path of the directory designated for temporary files
1146var
1147 Buffer: array[0..1023] of Char;
1148begin
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 *)
1161end;
1162//------------------------------------------------------------------------------
1163procedure WinExecError(iErr: Word; const sCmdLine: string);
1164//Returns a dialogbox with the explanation of an WinExecError
1165var
1166 S: string;
1167begin
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');
1228end;
1229//------------------------------------------------------------------------------
1230procedure PrintWordDoc(const fil: string; handle: HWND);
1231var
1232 Hwnd: Thandle;
1233begin
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
1244end;
1245//------------------------------------------------------------------------------
1246Function GetFileAsText(const afile: String): String;
1247var
1248 iFileHandle: Integer;
1249 iFileLength: Integer;
1250begin
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);
1270end;
1271//------------------------------------------------------------------------------
1272function SaveTextAsFile(const afile, Text: String): Boolean;
1273var
1274 //F: TextFile;
1275 aHandle: THandle;
1276 dwRead: DWORD;
1277begin
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 *)
1309end;
1310//------------------------------------------------------------------------------
1311function GetUserCookie: string;
1312begin
1313 //asm int 3 end; //KS trap
1314 Result := Trim(GetFileAsText(GetWinDir + 'KSUserCookie'));
1315end;
1316//------------------------------------------------------------------------------
1317var
1318 NetUserName: string = '';
1319
1320//------------------------------------------------------------------------------
1321function KSGetNetUserName(const aResource: string = '?'): string;
1322begin
1323 //asm int 3 end; //trap
1324 if Length(NetUserName) = 0 //not initialized
1325 then GetNetUserName(aResource);
1326
1327 Result := NetUserName;
1328end;
1329//------------------------------------------------------------------------------
1330function KSGetUserName(Uppercase: boolean = true): string;
1331var
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 //-----------------------------------------------
1346begin
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');
1389end;
1390//------------------------------------------------------------------------------
1391Function GetFirstNetworkDrive: string;
1392var
1393 dtDrive: TDriveType;
1394 AllDrives: string;
1395 I: Integer;
1396begin
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;
1412end;
1413//------------------------------------------------------------------------------
1414function GetNetUserName(const aResource: string = ''): string;
1415// aResource = drive to get Log In Name from - if blank we use the first net-drive
1416var
1417 pcUser: PChar;
1418 dwUSize: Cardinal;
1419 _aResource: String;
1420begin
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;
1454end;
1455//------------------------------------------------------------------------------
1456function GetWinDir: string;
1457//Returns the windows directory
1458var
1459 pcWindowsDirectory: PChar;
1460 dwWDSize: Cardinal;
1461begin
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;
1476end;
1477//------------------------------------------------------------------------------
1478function KSGetSystemDirectory: string;
1479//Returns system directory
1480var
1481 pcSystemDirectory: PChar;
1482 dwSDSize: Cardinal;
1483begin
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;
1493end;
1494//------------------------------------------------------------------------------
1495function KSGetSystemTime: string;
1496//returns date and time
1497var
1498 stSystemTime: TSystemTime;
1499begin
1500 //asm int 3 end; //trap
1501 Windows.GetSystemTime(stSystemTime);
1502 Result := DateTimeToStr(SystemTimeToDateTime(stSystemTime));
1503end;
1504//------------------------------------------------------------------------------
1505function KSFileGetDateTime(const aFile: string): TDateTime;
1506begin
1507 //asm int 3 end; //KS trap
1508 Result := FileDateToDateTime(FileAge(aFile));
1509end;
1510//------------------------------------------------------------------------------
1511function 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
1515var
1516 FileOneFileTime: TFileTime;
1517 FileTwoFileTime: TFileTime;
1518begin
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;
1534end;
1535//------------------------------------------------------------------------------
1536function 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
1539var
1540 SystemTime: TSystemTime;
1541 FileTime: TFileTime;
1542begin
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
1550end;
1551//------------------------------------------------------------------------------
1552function GetLogicalPathFromUNC(var aUNC :string): Boolean;
1553var
1554 S,S1: string;
1555 I: Integer;
1556 UNC: string;
1557begin
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;
1576end;
1577//------------------------------------------------------------------------------
1578function 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
1581var
1582 FileTime, LocalFileTime: TFileTime;
1583 hFile: THandle;
1584 //AFileName: string;
1585begin
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
1608end;
1609//------------------------------------------------------------------------------
1610Function GetFreeDiskSize(TheDrive: String):Int64;
1611//NB husk C:\
1612var
1613 TheSize : int64;
1614begin
1615 //asm int 3 end; //KS trap
1616 GetDiskFreeSpaceEx(Pchar(TheDrive), Result, TheSize, nil);
1617end;
1618//------------------------------------------------------------------------------
1619function KSGetCurrentDirectory: string;
1620//Returns the current directory for the current process
1621var
1622 nBufferLength: Cardinal; // size, in characters, of directory buffer
1623 lpBuffer: PChar; // address of buffer for current directory
1624begin
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
1634end;
1635//------------------------------------------------------------------------------
1636function FileSizeEx(const FileName: string): LongInt;
1637//returns the size of a file in bytes
1638var
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;
1648begin
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 *)
1671end;
1672//------------------------------------------------------------------------------
1673function ShortFileNameToLFN(ShortName: String):String;
1674var
1675 temp: TWIN32FindData;
1676 searchHandle: THandle;
1677begin
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);
1686end;
1687//------------------------------------------------------------------------------
1688function GetFullPathNameEx(const Path: string): string;
1689//Returns the full path and filename of a specified file
1690var
1691 nBufferLength: Cardinal; // size, in characters, of path buffer
1692 lpBuffer: PChar; // address of path buffer
1693 lpFilePart: PChar; // address of filename in path
1694begin
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;
1707end;
1708//------------------------------------------------------------------------------
1709function GetFirstAviableDriveLetter: string;
1710//Returns the first available disk drives letter
1711var
1712 S: string;
1713 I: Integer;
1714begin
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;
1728end;
1729//------------------------------------------------------------------------------
1730function KSGetLogicalDrives: string;
1731//Returns a string that contains the currently available disk drives
1732var
1733 drives: set of 0..25;
1734 drive: integer;
1735begin
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'));
1743end;
1744//------------------------------------------------------------------------------
1745function KSDelete(var S: String; DeleteString: String; All: Boolean = False): boolean;
1746var
1747 I: Integer;
1748begin
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;
1767end;
1768//------------------------------------------------------------------------------
1769function squish(const Search: string): string;
1770{squish() returns a string with all whitespace not inside single
1771quotes deleted.}
1772var
1773 Index: byte;
1774 InString: boolean;
1775begin
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;
1785end;
1786//------------------------------------------------------------------------------
1787function before(const Search, Find: string): string;
1788{before() returns everything before the first occurance of Find
1789in Search. If Find does not occur in Search, Search is returned.}
1790var
1791 index: byte;
1792begin
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);
1798end;
1799//------------------------------------------------------------------------------
1800function beforeX(const Search, Find: string): string;
1801{before() returns everything before the first occurance of Find
1802in Search. If Find does not occur in Search, An empty string is returned.}
1803var
1804 index: byte;
1805begin
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);
1811end;
1812//------------------------------------------------------------------------------
1813function after(const Search, Find: string): string;
1814{after() returns everything after the first occurance of Find
1815in Search. If Find does not occur in Search, a null string is returned.}
1816var
1817 index: byte;
1818begin
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));
1824end;
1825//------------------------------------------------------------------------------
1826function LastChar(const Search: string; const Find: char): Integer;
1827begin
1828 //asm int 3 end; //KS trap
1829 Result := Length(Search);
1830
1831 while (Result > 0) and (Search[Result] <> Find) do
1832 Dec(Result);
1833end;
1834//------------------------------------------------------------------------------
1835function RPos(const Find, Search: string): Integer;
1836{RPos() returns the index of the first character of the last occurance
1837of Find in Search. Returns 0 if Find does not occur in Search.
1838Like Pos() but searches in reverse.}
1839var
1840 Quit : Boolean;
1841 Pos,Len : Integer;
1842begin
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
1867end;
1868//------------------------------------------------------------------------------
1869function AfterLastToken(const StrInd, Token: string): string;
1870//Returns the right part of StrInd that comes after Token
1871begin
1872 //asm int 3 end; //trap
1873 result := copy(StrInd, RPos(Token, StrInd) + 1, length(StrInd));
1874end;
1875//------------------------------------------------------------------------------
1876function KSSameText(S1, S2: string; MaxLen: Cardinal): boolean;
1877begin
1878 Result := 2 = CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE,
1879 PChar(S1), MaxLen, PChar(S2), MaxLen);
1880end;
1881//------------------------------------------------------------------------------
1882function 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
1885var
1886 I: Integer;
1887begin
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);
1893end;
1894//------------------------------------------------------------------------------
1895type
1896 TFindHwndRec = record
1897 FoundWnd: HWND;
1898 WindowTekst: array[0..50] of Char;
1899 LenWindowTekst: Word;
1900 end;
1901
1902 PFindHwndRec = ^TFindHwndRec;
1903//------------------------------------------------------------------------------
1904function EnumWindowsProc(WndBeingChecked: HWND; rec: PFindHwndRec): Bool; export; stdcall;
1905{callback funktionen som window kalder tilbage til efter EnumWindows}
1906var
1907 p: array[0..100] of Char;
1908begin
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
1919end;
1920//------------------------------------------------------------------------------
1921function GetWindowFromText(const WindowText: string): Hwnd;
1922{returnere en handle til vinduet hvis WindowText findes i caption}
1923var
1924 rec: TFindHwndRec;
1925begin
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
1937end;
1938//------------------------------------------------------------------------------
1939function DropLastDir(path: string): string;
1940//fjerner sidste directory fra stien i path
1941begin
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));
1947end;
1948//------------------------------------------------------------------------------
1949function CtrlDown: Boolean;
1950var
1951 State: TKeyboardState;
1952begin
1953 //asm int 3 end; //KS trap
1954 GetKeyboardState(State);
1955 Result := ((State[vk_Control] and 128) <> 0);
1956end;
1957//------------------------------------------------------------------------------
1958function FileDifferent(const Sourcefile: string; TargetPath: string): Boolean;
1959var
1960 TargetFil: string;
1961begin
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);
1979end;
1980//------------------------------------------------------------------------------
1981function GetErrorString(var aFmtStr: String; ErrorCode: Integer): boolean;
1982var
1983 Buf: array [Byte] of Char;
1984begin
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
1992end;
1993//------------------------------------------------------------------------------
1994function GetSystemErrorMessage(var aFmtStr: String; ErrorAccept: Integer = ERROR_SUCCESS): boolean;
1995//returns true if an error is found
1996var
1997 ErrorCode: Integer;
1998begin
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);
2006end;
2007//------------------------------------------------------------------------------
2008function GetLastErrorStr: string;
2009var
2010 S: string;
2011begin
2012 //asm int 3 end; //KS trap
2013 GetSystemErrorMessage(S);
2014 result := S;
2015end;
2016//------------------------------------------------------------------------------
2017function ShowLastErrorIfAny(anError: Integer; Handle: Hwnd = 0): Boolean;
2018begin
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);
2026end;
2027//------------------------------------------------------------------------------
2028function KSSetCurrentDir(const Dir: string): Boolean;
2029begin
2030 //asm int 3 end; //trap
2031 result := DirExists(Dir);
2032 if result
2033 then Result := SetCurrentDirectory(PChar(Dir));
2034end;
2035//------------------------------------------------------------------------------
2036function DelDir(aDir: string): boolean;
2037//Remove a directory including all content
2038var
2039 SHFileOpStruct: TSHFileOpStruct;
2040begin
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;
2053end;
2054//------------------------------------------------------------------------------
2055function KSEmptyDir(aDir: string): Boolean;
2056//Clears all files and subdirectories from directory
2057var
2058 SearchRec : TSearchRec;
2059begin
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);
2073end;
2074//------------------------------------------------------------------------------
2075function KSForceDirectories(Dir: string): Boolean;
2076begin
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;
2092end;
2093//------------------------------------------------------------------------------
2094function GetShareFromURN(const URN: string; var Share: string; aPath: string = ''): boolean;
2095begin
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;
2103end;
2104//------------------------------------------------------------------------------
2105function GetFileDateAsString(aFile: string): String;
2106begin
2107 //asm int 3 end; //KS trap
2108 result := IntToStr(FileAge(aFile))
2109end;
2110//------------------------------------------------------------------------------
2111function GetUTCFileDateAsString(aFile: string): String;
2112begin
2113 //asm int 3 end; //KS trap
2114 result := IntToStr(UTCFileAge(aFile))
2115end;
2116//------------------------------------------------------------------------------
2117function UTCFileAge(const FileName: string): Integer;
2118//get UTC-based file time (no conversion to local time)
2119var
2120 Handle: THandle;
2121 FindData: TWin32FindData;
2122 //LocalFileTime: TFileTime;
2123 //S, S1: String;
2124begin
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;
2148end;
2149//------------------------------------------------------------------------------
2150function DosLocalTimeToDosUTCTime(aDosFileTime: Integer): Integer;
2151var
2152 aFileTime: TFileTime;
2153 aLocalFileTime: TFileTime;
2154begin
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
2166end;
2167//------------------------------------------------------------------------------
2168Function GetShortDateTime(aTime: TDateTime; Seconds: boolean = false): String;
2169var
2170 OldShortDateFormat: string;
2171begin
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;
2183end;
2184//------------------------------------------------------------------------------
2185Function GetFileDateTime(aFile: string): String;
2186//var
2187 //OldShortDateFormat: string;
2188begin
2189 //asm int 3 end; //KS trap
2190 if Not FileExists(aFile)
2191 then result := 'Error'
2192 else result := GetShortDateTime(FileDateToDateTime(FileAge(aFile)));
2193end;
2194//------------------------------------------------------------------------------
2195Function GetModuleName(aFile: string = ''): String;
2196var
2197 ModuleName: array[0..255] of Char;
2198begin
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;
2204end;
2205//------------------------------------------------------------------------------
2206function GetBoxHead(aBoxHead, aDefault: string): string;
2207begin
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;
2215end;
2216//------------------------------------------------------------------------------
2217function KSMessage(aMessage: string; aBoxHead: string; Params: integer): integer;
2218begin
2219 //asm int 3 end; //trap
2220result := 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 }
2231end;
2232
2233//------------------------------------------------------------------------------
2234function KSQuestion(aMessage: string; aBoxHead: string = ''; Params: integer = MB_ICONQUESTION or MB_YESNO): integer;
2235begin
2236 //asm int 3 end; //trap
2237 result := KSMessage(aMessage, GetBoxHead(aBoxHead, 'Question'), Params);
2238end;
2239//------------------------------------------------------------------------------
2240Procedure KSMessageI(aMessage: string; aBoxHead: string = '');
2241begin
2242 KSMessage(aMessage, GetBoxHead(aBoxHead, 'Information'), MB_ICONINFORMATION or MB_OK)
2243end;
2244//------------------------------------------------------------------------------
2245Procedure KSMessageQ(aMessage: string; aBoxHead: string = '');
2246begin
2247 KSMessage(aMessage, GetBoxHead(aBoxHead, 'Question'), MB_ICONQUESTION or MB_OK);
2248end;
2249//------------------------------------------------------------------------------
2250Procedure KSMessageE(aMessage: string; aBoxHead: string = '');
2251begin
2252 KSMessage(aMessage, GetBoxHead(aBoxHead, 'Error'), MB_ICONERROR or MB_OK);
2253end;
2254//------------------------------------------------------------------------------
2255Procedure KSMessageW(aMessage: string; aBoxHead: string = '');
2256begin
2257 KSMessage(aMessage, GetBoxHead(aBoxHead, 'Warning'), MB_ICONWARNING or MB_OK);
2258end;
2259//------------------------------------------------------------------------------
2260Procedure KSMessageT(aMessage: string; aBoxHead: string = '');
2261begin
2262 KSMessageI(aMessage, aBoxHead);
2263end;
2264//------------------------------------------------------------------------------
2265const
2266 NewBlock: string = '-----------------------------------------'+ #13+#10+#13+#10;
2267
2268//------------------------------------------------------------------------------
2269function SaveDeveloperMessagesLog(afile: string): boolean;
2270begin
2271 //asm int 3 end; //KS trap
2272 result := SaveTextAsFile(afile, DeveloperMessagesLog);
2273 if result
2274 then DeveloperMessagesLog := '';
2275end;
2276//------------------------------------------------------------------------------
2277function CloseDeveloperMessagesLog(afile: string): boolean;
2278begin
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;
2290end;
2291//------------------------------------------------------------------------------
2292procedure DeveloperMessage(aMessage: string);
2293
2294begin
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;
2320end;
2321//------------------------------------------------------------------------------
2322procedure OpenDeveloperMessagesLog;
2323const
2324 Stars: string = '*****************************************'+ #13+#10;
2325var
2326 tmpFile: String;
2327begin
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');
2340end;
2341//------------------------------------------------------------------------------
2342function IsAlNum(C: char): bool;
2343begin
2344 //asm int 3 end; //trap
2345 result := C in ['0'..'9', 'A'..'Z', 'a'..'z', 'À'..'ÿ'];
2346end;
2347//------------------------------------------------------------------------------
2348procedure 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
2353var
2354srRes : TSearchRec;
2355iFound : Integer;
2356begin
2357 //asm int 3 end; //KS trap
2358if (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
2374if path[Length(path)] <> '\' then path := path +'\';
2375
2376iFound := FindFirst(path + mask, faAnyFile-faDirectory {any file but not folders}, srRes);
2377while 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
2384FindClose(srRes);
2385
2386end;
2387//------------------------------------------------------------------------------
2388type
2389 TRegProc = function : HResult; stdcall;
2390//------------------------------------------------------------------------------
2391function RegisterAxLib(FileName: string; Unreg: Boolean = False): boolean;
2392var
2393 LibHandle: THandle;
2394 RegProc: TRegProc;
2395 DllProc: String;
2396begin
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;
2420end;
2421//------------------------------------------------------------------------------
2422//------------------------------------------------------------------------------
2423procedure KSWait(aTime: Cardinal);
2424//waits unthil aTime (in miliseconds) is elapsed
2425var
2426 T: Cardinal;
2427begin
2428 //asm int 3 end; //trap
2429 T := GetTickCount + aTime;
2430 while T > GetTickCount do
2431 KSProcessMessages;
2432end;
2433//------------------------------------------------------------------------------
2434procedure KSProcessMessages;
2435var
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 //-----------------------
2457begin
2458 //asm int 3 end; //trap
2459 while ProcessMessage(Msg) do
2460 {loop};
2461end;
2462//------------------------------------------------------------------------------
2463function _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}
2466var
2467 Dir, Name: string;
2468 res: array[1..250] of char;
2469 err: integer;
2470 F: TFileStream;
2471 //dummyFileCreated: boolean;
2472 filename: string;
2473begin
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);
2498end;
2499//------------------------------------------------------------------------------
2500function GetAbsolutePath(ActualPath: string; var RelativePath: string): boolean;
2501var
2502 S: string;
2503 ActualForSlashes: Boolean;
2504 ActualP: String;
2505 RelativeP: String;
2506 NewPath: String;
2507begin
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;
2560end;
2561//------------------------------------------------------------------------------
2562
2563end.
2564
2565
2566
2567
2568
2569
2570
2571
2572
Note: See TracBrowser for help on using the repository browser.