source: trunk/Packages/Common/UCommon.pas

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