source: trunk/Packages/Common/UCommon.pas

Last change on this file was 38, checked in by chronos, 7 years ago
  • Modified: Updated Common package.
File size: 15.1 KB
Line 
1unit UCommon;
2
3{$mode delphi}
4
5interface
6
7uses
8 {$ifdef Windows}Windows,{$endif}
9 {$ifdef Linux}baseunix,{$endif}
10 Classes, SysUtils, StrUtils, Dialogs, Process, LCLIntf,
11 FileUtil; //, ShFolder, ShellAPI;
12
13type
14 TArrayOfByte = array of Byte;
15 TArrayOfString = array of string;
16 TExceptionEvent = procedure(Sender: TObject; E: Exception) of object;
17
18 TUserNameFormat = (
19 unfNameUnknown = 0, // Unknown name type.
20 unfNameFullyQualifiedDN = 1, // Fully qualified distinguished name
21 unfNameSamCompatible = 2, // Windows NT® 4.0 account name
22 unfNameDisplay = 3, // A "friendly" display name
23 unfNameUniqueId = 6, // GUID string that the IIDFromString function returns
24 unfNameCanonical = 7, // Complete canonical name
25 unfNameUserPrincipal = 8, // User principal name
26 unfNameCanonicalEx = 9,
27 unfNameServicePrincipal = 10, // Generalized service principal name
28 unfDNSDomainName = 11);
29
30 TFilterMethodMethod = function (FileName: string): Boolean of object;
31var
32 ExceptionHandler: TExceptionEvent;
33 DLLHandle1: HModule;
34
35{$IFDEF Windows}
36 GetUserNameEx: procedure (NameFormat: DWORD;
37 lpNameBuffer: LPSTR; nSize: PULONG); stdcall;
38{$ENDIF}
39
40function IntToBin(Data: Int64; Count: Byte): string;
41function BinToInt(BinStr: string): Int64;
42function TryHexToInt(Data: string; var Value: Integer): Boolean;
43function TryBinToInt(Data: string; var Value: Integer): Boolean;
44function BinToHexString(Source: AnsiString): string;
45//function DelTree(DirName : string): Boolean;
46//function GetSpecialFolderPath(Folder: Integer): string;
47function BCDToInt(Value: Byte): Byte;
48function CompareByteArray(Data1, Data2: TArrayOfByte): Boolean;
49function GetUserName: string;
50function LoggedOnUserNameEx(Format: TUserNameFormat): string;
51function SplitString(var Text: string; Count: Word): string;
52function GetBitCount(Variable: QWord; MaxIndex: Integer): Integer;
53function GetBit(Variable: QWord; Index: Byte): Boolean;
54procedure SetBit(var Variable: Int64; Index: Byte; State: Boolean); overload;
55procedure SetBit(var Variable: QWord; Index: Byte; State: Boolean); overload;
56procedure SetBit(var Variable: Cardinal; Index: Byte; State: Boolean); overload;
57procedure SetBit(var Variable: Word; Index: Byte; State: Boolean); overload;
58function AddLeadingZeroes(const aNumber, Length : integer) : string;
59function LastPos(const SubStr: String; const S: String): Integer;
60function GenerateNewName(OldName: string): string;
61function GetFileFilterItemExt(Filter: string; Index: Integer): string;
62procedure FileDialogUpdateFilterFileType(FileDialog: TOpenDialog);
63procedure DeleteFiles(APath, AFileSpec: string);
64procedure OpenWebPage(URL: string);
65procedure OpenFileInShell(FileName: string);
66procedure ExecuteProgram(Executable: string; Parameters: array of string);
67procedure FreeThenNil(var Obj);
68function RemoveQuotes(Text: string): string;
69function ComputerName: string;
70function OccurenceOfChar(What: Char; Where: string): Integer;
71function GetDirCount(Dir: string): Integer;
72function MergeArray(A, B: array of string): TArrayOfString;
73function LoadFileToStr(const FileName: TFileName): AnsiString;
74procedure SearchFiles(AList: TStrings; Dir: string;
75 FilterMethod: TFilterMethodMethod);
76function GetStringPart(var Text: string; Separator: string): string;
77
78
79implementation
80
81function BinToInt(BinStr : string) : Int64;
82var
83 i : byte;
84 RetVar : Int64;
85begin
86 BinStr := UpperCase(BinStr);
87 if BinStr[length(BinStr)] = 'B' then Delete(BinStr,length(BinStr),1);
88 RetVar := 0;
89 for i := 1 to length(BinStr) do begin
90 if not (BinStr[i] in ['0','1']) then begin
91 RetVar := 0;
92 Break;
93 end;
94 RetVar := (RetVar shl 1) + (byte(BinStr[i]) and 1) ;
95 end;
96
97 Result := RetVar;
98end;
99
100function BinToHexString(Source: AnsiString): string;
101var
102 I: Integer;
103begin
104 for I := 1 to Length(Source) do begin
105 Result := Result + LowerCase(IntToHex(Ord(Source[I]), 2));
106 end;
107end;
108
109
110procedure DeleteFiles(APath, AFileSpec: string);
111var
112 SearchRec: TSearchRec;
113 Find: Integer;
114 Path: string;
115begin
116 Path := IncludeTrailingPathDelimiter(APath);
117
118 Find := FindFirst(Path + AFileSpec, faAnyFile xor faDirectory, SearchRec);
119 while Find = 0 do begin
120 DeleteFile(Path + SearchRec.Name);
121
122 Find := SysUtils.FindNext(SearchRec);
123 end;
124 FindClose(SearchRec);
125end;
126
127
128function GetFileFilterItemExt(Filter: string; Index: Integer): string;
129var
130 List: TStringList;
131begin
132 try
133 List := TStringList.Create;
134 List.Text := StringReplace(Filter, '|', #10, [rfReplaceAll]);
135 Result := List[Index * 2 + 1];
136 finally
137 List.Free;
138 end;
139end;
140
141procedure FileDialogUpdateFilterFileType(FileDialog: TOpenDialog);
142var
143 FileExt: string;
144begin
145 FileExt := GetFileFilterItemExt(FileDialog.Filter, FileDialog.FilterIndex - 1);
146 Delete(FileExt, 1, 1); // Remove symbol '*'
147 if FileExt <> '.*' then
148 FileDialog.FileName := ChangeFileExt(FileDialog.FileName, FileExt)
149end;
150
151function GenerateNewName(OldName: string): string;
152var
153 I: Integer;
154 Number: Integer;
155begin
156 Number := 1;
157 // Find number on end
158 if Length(OldName) > 0 then begin
159 I := Length(OldName);
160 while (I > 1) and ((OldName[I] >= '0') and (OldName[I] <= '9')) do Dec(I);
161 TryStrToInt(Copy(OldName, I + 1, Length(OldName) - I), Number);
162 Inc(Number)
163 end;
164 Result := Copy(OldName, 1, I) + IntToStr(Number);
165end;
166
167(*function DelTree(DirName : string): Boolean;
168var
169 SHFileOpStruct : TSHFileOpStruct;
170 DirBuf : array [0..255] of char;
171begin
172 DirName := UTF8Decode(DirName);
173 try
174 Fillchar(SHFileOpStruct,Sizeof(SHFileOpStruct),0) ;
175 FillChar(DirBuf, Sizeof(DirBuf), 0 ) ;
176 StrPCopy(DirBuf, DirName) ;
177 with SHFileOpStruct do begin
178 Wnd := 0;
179 pFrom := @DirBuf;
180 wFunc := FO_DELETE;
181 fFlags := FOF_ALLOWUNDO;
182 fFlags := fFlags or FOF_NOCONFIRMATION;
183 fFlags := fFlags or FOF_SILENT;
184 end;
185 Result := (SHFileOperation(SHFileOpStruct) = 0) ;
186 except
187 Result := False;
188 end;
189end;*)
190
191function LastPos(const SubStr: String; const S: String): Integer;
192begin
193 Result := Pos(ReverseString(SubStr), ReverseString(S));
194 if (Result <> 0) then
195 Result := ((Length(S) - Length(SubStr)) + 1) - Result + 1;
196end;
197
198function BCDToInt(Value: Byte): Byte;
199begin
200 Result := (Value shr 4) * 10 + (Value and 15);
201end;
202
203(*function GetSpecialFolderPath(Folder: Integer): string;
204const
205 SHGFP_TYPE_CURRENT = 0;
206var
207 Path: array[0..MAX_PATH] of Char;
208begin
209 Result := 'C:\Test';
210 if SUCCEEDED(SHGetFolderPath(0, Folder, 0, SHGFP_TYPE_CURRENT, @path[0])) then
211 Result := path
212 else
213 Result := '';
214end;*)
215
216function IntToBin(Data: Int64; Count: Byte): string;
217var
218 I: Integer;
219begin
220 Result := '';
221 for I := 0 to Count - 1 do
222 Result := IntToStr((Data shr I) and 1) + Result;
223end;
224
225function IntToHex(Data: Cardinal; Count: Byte): string;
226const
227 Chars: array[0..15] of Char = '0123456789ABCDEF';
228var
229 I: Integer;
230begin
231 Result := '';
232 for I := 0 to Count - 1 do
233 Result := Result + Chars[(Data shr (I * 4)) and 15];
234end;
235
236function TryHexToInt(Data: string; var Value: Integer): Boolean;
237var
238 I: Integer;
239begin
240 Data := UpperCase(Data);
241 Result := True;
242 Value := 0;
243 for I := 0 to Length(Data) - 1 do begin
244 if (Data[I + 1] >= '0') and (Data[I + 1] <= '9') then
245 Value := Value or (Ord(Data[I + 1]) - Ord('0')) shl ((Length(Data) - I - 1) * 4)
246 else if (Data[I + 1] >= 'A') and (Data[I + 1] <= 'F') then
247 Value := Value or (Ord(Data[I + 1]) - Ord('A') + 10) shl ((Length(Data) - I - 1) * 4)
248 else Result := False;
249 end;
250end;
251
252function TryBinToInt(Data: string; var Value: Integer): Boolean;
253var
254 I: Integer;
255begin
256 Result := True;
257 Value := 0;
258 for I := 0 to Length(Data) - 1 do begin
259 if (Data[I + 1] >= '0') and (Data[I + 1] <= '1') then
260 Value := Value or (Ord(Data[I + 1]) - Ord('0')) shl ((Length(Data) - I - 1))
261 else Result := False;
262 end;
263end;
264
265function CompareByteArray(Data1, Data2: TArrayOfByte): Boolean;
266var
267 I: Integer;
268begin
269 if Length(Data1) = Length(Data2) then begin
270 Result := True;
271 for I := 0 to Length(Data1) - 1 do begin
272 if Data1[I] <> Data2[I] then begin
273 Result := False;
274 Break;
275 end
276 end;
277 end else Result := False;
278end;
279
280function Explode(Separator: char; Data: string): TArrayOfString;
281begin
282 SetLength(Result, 0);
283 while Pos(Separator, Data) > 0 do begin
284 SetLength(Result, Length(Result) + 1);
285 Result[High(Result)] := Copy(Data, 1, Pos(Separator, Data) - 1);
286 Delete(Data, 1, Pos(Separator, Data));
287 end;
288 SetLength(Result, Length(Result) + 1);
289 Result[High(Result)] := Data;
290end;
291
292{$IFDEF Windows}
293function GetUserName: string;
294const
295 MAX_USERNAME_LENGTH = 256;
296var
297 L: LongWord;
298begin
299 L := MAX_USERNAME_LENGTH + 2;
300 SetLength(Result, L);
301 if Windows.GetUserName(PChar(Result), L) and (L > 0) then begin
302 SetLength(Result, StrLen(PChar(Result)));
303 Result := UTF8Encode(Result);
304 end else Result := '';
305end;
306
307function GetVersionInfo: TOSVersionInfo;
308begin
309 Result.dwOSVersionInfoSize := SizeOf(Result);
310 if GetVersionEx(Result) then begin
311 end;
312end;
313{$endif}
314
315function ComputerName: string;
316{$ifdef mswindows}
317const
318 INFO_BUFFER_SIZE = 32767;
319var
320 Buffer : array[0..INFO_BUFFER_SIZE] of WideChar;
321 Ret : DWORD;
322begin
323 Ret := INFO_BUFFER_SIZE;
324 If (GetComputerNameW(@Buffer[0],Ret)) then begin
325 Result := UTF8Encode(WideString(Buffer));
326 end
327 else begin
328 Result := 'ERROR_NO_COMPUTERNAME_RETURNED';
329 end;
330end;
331{$endif}
332{$ifdef unix}
333var
334 Name: UtsName;
335begin
336 fpuname(Name);
337 Result := Name.Nodename;
338end;
339{$endif}
340
341{$ifdef windows}
342function LoggedOnUserNameEx(Format: TUserNameFormat): string;
343const
344 MaxLength = 1000;
345var
346 UserName: array[0..MaxLength] of Char;
347 VersionInfo: TOSVersionInfo;
348 Size: DWORD;
349begin
350 VersionInfo := GetVersionInfo;
351 if VersionInfo.dwPlatformId = VER_PLATFORM_WIN32_NT then begin
352 Size := MaxLength;
353 GetUserNameEx(Integer(Format), @UserName, @Size);
354 //ShowMessage(SysErrorMessage(GetLastError));
355 if GetLastError = 0 then Result := UTF8Encode(UserName)
356 else Result := GetUserName;
357 end else Result := GetUserName;
358end;
359{$ELSE}
360function GetUserName: string;
361begin
362 Result := '';
363end;
364
365function LoggedOnUserNameEx(Format: TUserNameFormat): string;
366begin
367 Result := '';
368end;
369
370{$ENDIF}
371
372function SplitString(var Text: string; Count: Word): string;
373begin
374 Result := Copy(Text, 1, Count);
375 Delete(Text, 1, Count);
376end;
377
378function GetBitCount(Variable: QWord; MaxIndex: Integer): Integer;
379var
380 I: Integer;
381begin
382 Result := 0;
383 for I := 0 to MaxIndex - 1 do
384 if ((Variable shr I) and 1) = 1 then Inc(Result);
385end;
386
387function GetBit(Variable:QWord;Index:Byte):Boolean;
388begin
389 Result := ((Variable shr Index) and 1) = 1;
390end;
391
392procedure SetBit(var Variable: Int64; Index: Byte; State: Boolean);
393begin
394 Variable := (Variable and ((1 shl Index) xor High(QWord))) or (Int64(State) shl Index);
395end;
396
397procedure SetBit(var Variable:QWord;Index:Byte;State:Boolean); overload;
398begin
399 Variable := (Variable and ((1 shl Index) xor High(QWord))) or (QWord(State) shl Index);
400end;
401
402procedure SetBit(var Variable:Cardinal;Index:Byte;State:Boolean); overload;
403begin
404 Variable := (Variable and ((1 shl Index) xor High(Cardinal))) or (Cardinal(State) shl Index);
405end;
406
407procedure SetBit(var Variable:Word;Index:Byte;State:Boolean); overload;
408begin
409 Variable := (Variable and ((1 shl Index) xor High(Word))) or (Word(State) shl Index);
410end;
411
412function AddLeadingZeroes(const aNumber, Length : integer) : string;
413begin
414 Result := SysUtils.Format('%.*d', [Length, aNumber]) ;
415end;
416
417procedure LoadLibraries;
418begin
419 {$IFDEF Windows}
420 DLLHandle1 := LoadLibrary('secur32.dll');
421 if DLLHandle1 <> 0 then
422 begin
423 @GetUserNameEx := GetProcAddress(DLLHandle1, 'GetUserNameExA');
424 end;
425 {$ENDIF}
426end;
427
428procedure FreeLibraries;
429begin
430 {$IFDEF Windows}
431 if DLLHandle1 <> 0 then FreeLibrary(DLLHandle1);
432 {$ENDIF}
433end;
434
435procedure ExecuteProgram(Executable: string; Parameters: array of string);
436var
437 Process: TProcess;
438 I: Integer;
439begin
440 try
441 Process := TProcess.Create(nil);
442 Process.Executable := Executable;
443 for I := 0 to Length(Parameters) - 1 do
444 Process.Parameters.Add(Parameters[I]);
445 Process.Options := [poNoConsole];
446 Process.Execute;
447 finally
448 Process.Free;
449 end;
450end;
451
452procedure FreeThenNil(var Obj);
453begin
454 TObject(Obj).Free;
455 TObject(Obj) := nil;
456end;
457
458procedure OpenWebPage(URL: string);
459begin
460 OpenURL(URL);
461end;
462
463procedure OpenFileInShell(FileName: string);
464begin
465 ExecuteProgram('cmd.exe', ['/c', 'start', FileName]);
466end;
467
468function RemoveQuotes(Text: string): string;
469begin
470 Result := Text;
471 if (Pos('"', Text) = 1) and (Text[Length(Text)] = '"') then
472 Result := Copy(Text, 2, Length(Text) - 2);
473end;
474
475function OccurenceOfChar(What: Char; Where: string): Integer;
476var
477 I: Integer;
478begin
479 Result := 0;
480 for I := 1 to Length(Where) do
481 if Where[I] = What then Inc(Result);
482end;
483
484function GetDirCount(Dir: string): Integer;
485begin
486 Result := OccurenceOfChar(DirectorySeparator, Dir);
487 if Copy(Dir, Length(Dir), 1) = DirectorySeparator then
488 Dec(Result);
489end;
490
491function MergeArray(A, B: array of string): TArrayOfString;
492var
493 I: Integer;
494begin
495 SetLength(Result, Length(A) + Length(B));
496 for I := 0 to Length(A) - 1 do
497 Result[I] := A[I];
498 for I := 0 to Length(B) - 1 do
499 Result[Length(A) + I] := B[I];
500end;
501
502function LoadFileToStr(const FileName: TFileName): AnsiString;
503var
504 FileStream: TFileStream;
505 Read: Integer;
506begin
507 Result := '';
508 FileStream := TFileStream.Create(FileName, fmOpenRead);
509 try
510 if FileStream.Size > 0 then begin
511 SetLength(Result, FileStream.Size);
512 Read := FileStream.Read(Pointer(Result)^, FileStream.Size);
513 SetLength(Result, Read);
514 end;
515 finally
516 FileStream.Free;
517 end;
518end;
519
520function DefaultSearchFilter(const FileName: string): Boolean;
521begin
522 Result := True;
523end;
524
525procedure SearchFiles(AList: TStrings; Dir: string;
526 FilterMethod: TFilterMethodMethod);
527var
528 SR: TSearchRec;
529begin
530 Dir := IncludeTrailingPathDelimiter(Dir);
531 if FindFirst(Dir + '*', faAnyFile, SR) = 0 then
532 try
533 repeat
534 if (SR.Name = '.') or (SR.Name = '..') or not FilterMethod(SR.Name) or
535 not FilterMethod(Copy(Dir, 3, Length(Dir)) + SR.Name) then Continue;
536 AList.Add(Dir + SR.Name);
537 if (SR.Attr and faDirectory) <> 0 then
538 SearchFiles(AList, Dir + SR.Name, FilterMethod);
539 until FindNext(SR) <> 0;
540 finally
541 FindClose(SR);
542 end;
543end;
544
545function GetStringPart(var Text: string; Separator: string): string;
546var
547 P: Integer;
548begin
549 P := Pos(Separator, Text);
550 if P > 0 then begin
551 Result := Copy(Text, 1, P - 1);
552 Delete(Text, 1, P - 1 + Length(Separator));
553 end else begin
554 Result := Text;
555 Text := '';
556 end;
557 Result := Trim(Result);
558 Text := Trim(Text);
559end;
560
561
562
563initialization
564
565LoadLibraries;
566
567
568finalization
569
570FreeLibraries;
571
572end.
Note: See TracBrowser for help on using the repository browser.