[541] | 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 |
|
---|