Monday, June 25, 2007

Calculate Size of Folders, Sub folders and files


function DirSize(const ADirName : string; ARecurseDirs : boolean = true): integer;
const
FIND_OK = 0;
var
nResult : integer;

procedure _RecursiveDir(const ADirName : string);
var
sDirName : String;
rDirInfo : TSearchRec;
nFindResult : Integer;
begin
sDirName := IncludeTrailingPathDelimiter(ADirName);
nFindResult := FindFirst(sDirName + '*.*',faAnyFile,rDirInfo);

while nFindResult = FIND_OK do
begin
// Ignore . and .. directories
if (rDirInfo.Name[1] <> '.') then
begin
if (rDirInfo.Attr and faDirectory = faDirectory) and ARecurseDirs then
RecursiveDir(sDirName + rDirInfo.Name) // Keep Recursing
else
inc(nResult, rDirInfo.Size); // Accumulate Sizes
end;

nFindResult := FindNext(rDirInfo);
if nFindResult <> FIND_OK then
FindClose(rDirInfo);
end;
end;

// DirSize Main
begin
Screen.Cursor := crHourGlass;
Application.ProcessMessages;
nResult := 0;
RecursiveDir(ADirName);
Screen.Cursor := crDefault;

Result := nResult;
end;

How to catch kernel-signals in Kylix?


program TestSignals;

{$APPTYPE CONSOLE}

uses Libc;

var
bTerminate: Boolean;

procedure SignalProc(SigNum: Integer); cdecl;
begin
case SigNum of
SIGQUIT:
begin
WriteLn('signal SIGQUIT');
bTerminate := true;
end;
SIGUSR1: WriteLn('signal SIGUSR1');
else
WriteLn('not handled signal');
end;
signal(SigNum, SignalProc);
end;

begin
bTerminate := false;

signal(SIGQUIT, SignalProc);
signal(SIGUSR1, SignalProc);

repeat
sleep(1);
until bTerminate;
end.

How do I determine if the user has Administrator privileges under Windows 2000/NT?


This is not a completely intuitive process, however, it can be done by combining a few different Windows API functions, as shown in the following code sample:

function IsAdmin: Boolean;
var
hAccessToken : tHandle;
ptgGroups : pTokenGroups;
dwInfoBufferSize : DWORD;
psidAdministrators : PSID;
int : integer;
blnResult : boolean;

const
SECURITY_NT_AUTHORITY: SID_IDENTIFIER_AUTHORITY =
(Value: (0,0,0,0,0,5)); // ntfs
SECURITY_BUILTIN_DOMAIN_RID: DWORD = $00000020;
DOMAIN_ALIAS_RID_ADMINS: DWORD = $00000220;
DOMAIN_ALIAS_RID_USERS : DWORD = $00000221;
DOMAIN_ALIAS_RID_GUESTS: DWORD = $00000222;
DOMAIN_ALIAS_RID_POWER_: DWORD = $00000223;

begin
Result := False;
blnResult := OpenThreadToken( GetCurrentThread, TOKEN_QUERY,
True, hAccessToken );
if ( not blnResult ) then
begin
if GetLastError = ERROR_NO_TOKEN then
blnResult := OpenProcessToken( GetCurrentProcess,
TOKEN_QUERY, hAccessToken );
end;

if ( blnResult ) then
try

GetMem(ptgGroups, 1024);
blnResult := GetTokenInformation( hAccessToken, TokenGroups,
ptgGroups, 1024,
dwInfoBufferSize );
CloseHandle( hAccessToken );

if ( blnResult ) then
begin

AllocateAndInitializeSid( SECURITY_NT_AUTHORITY, 2,
SECURITY_BUILTIN_DOMAIN_RID,
DOMAIN_ALIAS_RID_ADMINS,
0, 0, 0, 0, 0, 0,
psidAdministrators );
{$R-}
for int := 0 to ptgGroups.GroupCount - 1 do

if EqualSid( psidAdministrators,
ptgGroups.Groups[ int ].Sid ) then
begin
Result := True;
Break;
end;
{$R+}

FreeSid( psidAdministrators );
end;

finally
FreeMem( ptgGroups );
end;
end;

User Management through Win32 call


Check out the JCL (JediVCL) it has a routine from lanmanager(JcLanMan.pas)



function CreateAccount(const Server, Username, Fullname, Password,
Description,
Homedir, Script: string; const PasswordNeverExpires: Boolean):
Boolean;
var
wServer, wUsername, wFullname,
wPassword, wDescription, wHomedir, wScript: WideString;
Details: USER_INFO_2;
Err: NET_API_STATUS;
ParmErr: DWORD;
begin
wServer := Server;
wUsername := Username;
wFullname := Fullname;
wPassword := Password;
wDescription := Description;
wScript := Script;
wHomedir := Homedir;

FillChar (Details, SizeOf(Details), 0);
with Details do
begin
usri2_name := PWideChar(wUsername);
usri2_full_name := PWideChar(wFullname);
usri2_password := PWideChar(wPassword);
usri2_comment := PWideChar(wDescription);
usri2_priv := USER_PRIV_USER;
usri2_flags := UF_SCRIPT;
if PassWordNeverExpires then
usri2_flags := usri2_flags or UF_DONT_EXPIRE_PASSWD;
usri2_script_path := PWideChar(wScript);
usri2_home_dir := PWideChar(wHomedir);
usri2_acct_expires := TIMEQ_FOREVER;
end;

Err := NetUserAdd(PWideChar(wServer), 2, @Details, @ParmErr);
Result := (Err = NERR_SUCCESS);
end;



C:\>cacls /?
Displays or modifies access control lists (ACLs) of files

CACLS filename [/T] [/E] [/C] [/G user:perm] [/R user [...]]
[/P user:perm [...]] [/D user [...]]
filename Displays ACLs.
/T Changes ACLs of specified files in
the current directory and all subdirectories.
/E Edit ACL instead of replacing it.
/C Continue on access denied errors.
/G user:perm Grant specified user access rights.
Perm can be: R Read
C Change (write)
F Full control
/R user Revoke specified user's access rights (only valid with /E).
/P user:perm Replace specified user's access rights.
Perm can be: N None
R Read
C Change (write)
F Full control
/D user Deny specified user access.
Wildcards can be used to specify more that one file in a command.
You can specify more than one user in a command.

Add checkboxes to a TShellTreeView


unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ShellCtrls;

type
TCheckBoxShellTreeView = class(ShellCtrls.TShellTreeView)
public
procedure CreateParams(var Params: TCreateParams); override;
end;

TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
ShellTreeView: TCheckBoxShellTreeView;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

const
TVS_CHECKBOXES = $00000100;

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
ShellTreeView := TCheckBoxShellTreeView.Create(Self);
with ShellTreeView do
begin
Name := 'ShellTreeView';
Parent := Self;
Root := 'rfDesktop';
UseShellImages := True;
Align := alClient;
AutoRefresh := False;
BorderStyle := bsNone;
Indent := 19;
ParentColor := False;
RightClickSelect := True;
ShowRoot := False;
TabOrder := 0;
end;
end;

procedure TCheckBoxShellTreeView.CreateParams(var Params: TCreateParams);
begin
inherited;
Params.Style := Params.Style or TVS_CHECKBOXES;
end;

end.

Adding TCheckbox to TCombobox

You need to do the following:

Set ComboBox.Style:=csOwnerDrawFixed

//..... your form class
private
Selected: array of Boolean;
//.....


procedure TForm1.ComboBox1DrawItem(Control: TWinControl;
Index: Integer; Rect: TRect; State: TOwnerDrawState);
begin
SetLength(Selected, TComboBox(Control).Items.Count);
with TComboBox(Control).Canvas do
begin
FillRect(rect);

Rect.Left := Rect.Left + 1;
Rect.Right := Rect.Left + 13;
Rect.Bottom := Rect.Bottom;
Rect.Top := Rect.Top;

if not (odSelected in State) and (Selected[Index]) then
DrawFrameControl(Handle, Rect, DFC_BUTTON,
DFCS_BUTTONCHECK or DFCS_CHECKED or DFCS_FLAT)
else if (odFocused in State) and (Selected[Index]) then
DrawFrameControl(Handle, Rect, DFC_BUTTON,
DFCS_BUTTONCHECK or DFCS_CHECKED or DFCS_FLAT)
else if (Selected[Index]) then
DrawFrameControl(Handle, Rect, DFC_BUTTON,
DFCS_BUTTONCHECK or DFCS_CHECKED or DFCS_FLAT)
else if not (Selected[Index]) then
DrawFrameControl(Handle, Rect, DFC_BUTTON, DFCS_BUTTONCHECK or DFCS_FLAT);

TextOut(Rect.Left + 15, Rect.Top, TComboBox(Control).Items[Index]);
end;
end;

procedure TForm1.ComboBox1Select(Sender: TObject);
var
i: Integer;
Sel: string;
begin
Sel := EmptyStr;
Selected[TComboBox(Sender).ItemIndex] := not Selected[TComboBox(Sender).ItemIndex];
for i := 0 to TComboBox(Sender).Items.Count - 1 do
if Selected[i] then
Sel := Sel + TComboBox(Sender).Items[i] + ' ';
ShowMessage(Sel); //Just for test...
end;

Adding data to a compiled Executable file

You can't proof whether additional data is attached or not.
To reach this, you would have to create a checksumm of the
MemoryStream and attach it.

try this out:

function AttachToFile(const AFileName: string; MemoryStream: TMemoryStream): Boolean;
var
aStream: TFileStream;
iSize: Integer;
begin
Result := False;
if not FileExists(AFileName) then
Exit;
try
aStream := TFileStream.Create(AFileName, fmOpenWrite or fmShareDenyWrite);
MemoryStream.Seek(0, soFromBeginning);
// seek to end of File
// ans Ende der Datei Seeken
aStream.Seek(0, soFromEnd);
// copy data from MemoryStream
aStream.CopyFrom(MemoryStream, 0);
// save Stream-Size
iSize := MemoryStream.Size + SizeOf(Integer);
aStream.Write(iSize, SizeOf(iSize));
finally
aStream.Free;
end;
Result := True;
end;

function LoadFromFile(const AFileName: string; MemoryStream: TMemoryStream): Boolean;
var
aStream: TFileStream;
iSize: Integer;
begin
Result := False;
if not FileExists(AFileName) then
Exit;

try
aStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
// seek to position where Stream-Size is saved
aStream.Seek(-SizeOf(Integer), soFromEnd);
aStream.Read(iSize, SizeOf(iSize));
if iSize > aStream.Size then
begin
aStream.Free;
Exit;
end;
// seek to position where data is saved
aStream.Seek(-iSize, soFromEnd);
MemoryStream.SetSize(iSize - SizeOf(Integer));
MemoryStream.CopyFrom(aStream, iSize - SizeOf(iSize));
MemoryStream.Seek(0, soFromBeginning);
finally
aStream.Free;
end;
Result := True;
end;

procedure TForm1.SaveClick(Sender: TObject);
var
aStream: TMemoryStream;
begin
aStream := TMemoryStream.Create;
Memo1.Lines.SaveToStream(aStream);
AttachToFile('Test.exe', aStream);
aStream.Free;
end;

procedure TForm1.LoadClick(Sender: TObject);
var
aStream: TMemoryStream;
begin
aStream := TMemoryStream.Create;
LoadFromFile('Test.exe', aStream);
Memo1.Lines.LoadFromStream(aStream);
aStream.Free;
end;

How can i call 16-bit dll function from win32?


const
Gfsr_SystemResources = 0;
Gfsr_GdiResources = 1;
Gfsr_UserResources = 2;
var
hInst16: THandle;
GFSR: Pointer;

{ Undocumented Kernel32 calls. }
function LoadLibrary16(LibraryName: PChar): THandle; stdcall; external kernel32 index 35;
procedure FreeLibrary16(HInstance: THandle); stdcall; external kernel32 index 36;
function GetProcAddress16(Hinstance: THandle; ProcName: PChar): Pointer; stdcall; external kernel32 index 37;
procedure QT_Thunk; cdecl; external kernel32 name 'QT_Thunk';

{ QT_Thunk needs a stack frame. }
{$StackFrames On}
{ Thunking call to 16-bit USER.EXE. The ThunkTrash argument allocates space on the stack for QT_Thunk. }

function NewGetFreeSystemResources(SysResource: Word): Word;
var
ThunkTrash: array[0..$20] of Word;
begin
{ Prevent the optimizer from getting rid of ThunkTrash. }
ThunkTrash[0] := hInst16;
hInst16 := LoadLibrary16('user.exe');
if hInst16 < 32 then
raise Exception.Create('Can''t load USER.EXE!');
{ Decrement the usage count. This doesn't really free the library, since USER.EXE is always loaded. }
FreeLibrary16(hInst16);
{ Get the function pointer for the 16-bit function in USER.EXE. }
GFSR := GetProcAddress16(hInst16, 'GetFreeSystemResources');
if GFSR = nil then
raise Exception.Create('Can''t get address of GetFreeSystemResources!');
{ Thunk down to USER.EXE. }
asm
push SysResource { push arguments }
mov edx, GFSR { load 16-bit procedure pointer }
call QT_Thunk { call thunk }
mov Result, ax { save the result }
end;
end;