Adding CheckBox to a TShellTreeView

unit Unit1;

interface

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

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

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

var
  Form1: TForm1;

implementation

{$R *.dfm}

const
  TVS_CHECKBOXES = $00000100;

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

procedure TForm1.FormCreate(Sender: TObject);
begin
  FShellTreeView := TCheckBoxShellTreeView.Create(Self);
  with FShellTreeView do
  begin
    Name := 'FShellTreeView';
    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 TForm1.FormDestroy(Sender: TObject);
begin
  FShellTreeView.Free;
end;

end.

Sending an email using MAPI

There are lot of different methods to send mail using MAPI (Windows Simple Mail API)
If you do not want to rely on Outlook to send an email but you know that MAPI is installed, then you can also send mails with the following handy routine SendMailMAPI(). You need to add unit MAPI to your uses clause. Note that MAPI is not always installed with Windows.

unit uMAPIMail;

interface

uses MAPI;

function SendMailMAPI(const Subject, Body, FileName, SenderName, SenderEMail,
RecepientName, RecepientEMail: String) : Integer;

implementation

function SendMailMAPI(const Subject, Body, FileName, SenderName, SenderEMail,
RecepientName, RecepientEMail: String) : Integer;
var
message: TMapiMessage;
lpSender,
lpRecepient: TMapiRecipDesc;
FileAttach: TMapiFileDesc;
SM: TFNMapiSendMail;
MAPIModule: HModule;
begin
FillChar(message, SizeOf(message), 0);
with message do
begin
if (Subject<>'') then
begin
lpszSubject := PChar(Subject)
end;
if (Body<>'') then
begin
lpszNoteText := PChar(Body)
end;
if (SenderEMail<>'') then
begin
lpSender.ulRecipClass := MAPI_ORIG;
if (SenderName='') then
begin
lpSender.lpszName := PChar(SenderEMail)
end
else
begin
lpSender.lpszName := PChar(SenderName)
end;
lpSender.lpszAddress := PChar('SMTP:'+SenderEMail);
lpSender.ulReserved := 0;
lpSender.ulEIDSize := 0;
lpSender.lpEntryID := nil;
lpOriginator := @lpSender;
end;
if (RecepientEMail<>'') then
begin
lpRecepient.ulRecipClass := MAPI_TO;
if (RecepientName='') then
begin
lpRecepient.lpszName := PChar(RecepientEMail)
end
else
begin
lpRecepient.lpszName := PChar(RecepientName)
end;
lpRecepient.lpszAddress := PChar('SMTP:'+RecepientEMail);
lpRecepient.ulReserved := 0;
lpRecepient.ulEIDSize := 0;
lpRecepient.lpEntryID := nil;
nRecipCount := 1;
lpRecips := @lpRecepient;
end
else
begin
lpRecips := nil
end;
if (FileName='') then
begin
nFileCount := 0;
lpFiles := nil;
end
else
begin
FillChar(FileAttach, SizeOf(FileAttach), 0);
FileAttach.nPosition := Cardinal($FFFFFFFF);
FileAttach.lpszPathName := PChar(FileName);
nFileCount := 1;
lpFiles := @FileAttach;
end;
end;
MAPIModule := LoadLibrary(PChar(MAPIDLL));
if MAPIModule=0 then
begin
Result := -1
end else
begin
try
@SM := GetProcAddress(MAPIModule, 'MAPISendMail');
if @SM<>nil then
begin
Result := SM(0, Application.Handle, message, MAPI_DIALOG or MAPI_LOGON_UI,0);
end else
begin
Result := 1
end;

finally
FreeLibrary(MAPIModule);
end;
end
if Result<>0 then
begin
MessageDlg('Error sending mail ('+IntToStr(Result)+').', mtError, [mbOk], 0)
end;
end;

end.

Preventing second instance of the application

There are many ways, but we'll see couple of examples here...

a) Using "GlobalAddAtom" & "GlobalFindAtom" API calls

 
procedure TForm1.FormCreate(Sender: TObject);
begin
  {Searchs table to see if the program is already running} 
  if GlobalFindAtom('PROGRAM_RUNNING') = 0 then
   { If not found then add it }
   atom := GlobalAddAtom('PROGRAM_RUNNING')
  else begin
   { If program is already running the show message and halt }
   MessageDlg('You have the program running all ready!!', mtWarning, [mbOK], 0); 
   Halt;
  end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  {Removes the item from the table so it can be run again}
  GlobalDeleteAtom(atom);
end;

b) Using "CreateMutex" & "OpenMutex" you can control this from your *.dpr code itself. Here we will try to create the mutex (kernel) object on the OS when your application starts for the first time.
ex:
MutexHandle := CreateMutex(Nil, False, 'ANYTHING-WHICH-IS-UNIQUE-TO-UR-APP');
if MutexHandle returns zero(0) or some error, that means the mutex is already created and your application is running in the background. Here you can just quit the application or you throw some error message to the user, using the below code...

MutexHandle := OpenMutex(MUTEX_ALL_ACCESS, False, 'ANYTHING-WHICH-IS-UNIQUE-TO-UR-APP');

If MutexHandle retruns zero (0) or some error, then there is some problem with your kernel object just exit from there, otherwise you can show the error message like I have shown in the above example and quit from the application.
Finally, dont forget to free the MutexHandle. You will get more information when you search for "CreateMutex" "OpenMutex" in Google.com

c) Using "CreateFileMapping" / "MapViewOfFile" / "UnmapViewOfFile", its bit complex to understand, but if you are familiar with Windows API calls then it would probably help you.

Sending Mail using Thread

unit uSMTPMailer;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, 
  Dialogs, IdMessage, IdBaseComponent, IdComponent, IdTCPConnection,
  IdTCPClient, IdMessageClient, IdSMTP, StdCtrls;

type
  TSendMail = class(TThread)
  private
    FPortNumber: Integer;
    FSubject: String;
    FPassword: String;
    FServerName: String;
    FFromAddress: String;
    FBodyMessage: TStrings;
    FRecipientsList: TStrings;
    procedure SetBodyMessage(const Value: TStrings);
    procedure SetFromAddress(const Value: String);
    procedure SetPasword(const Value: String);
    procedure SetPortNumber(const Value: Integer);
    procedure SetRecipientsList(const Value: TStrings);
    procedure SetServerName(const Value: String);
    procedure SetSubject(const Value: String);
  public
    constructor Create(ASuspended: Boolean);
    property PortNumber: Integer read FPortNumber write SetPortNumber;
    property ServerName: String read FServerName write SetServerName;
    property Password: String read FPassword write SetPasword;
    property FromAddress: String read FFromAddress write SetFromAddress;
    property Recipients: TStrings  read FRecipientsList write SetRecipientsList;
    property Subject: String read FSubject write SetSubject;
    property Body: TStrings read FBodyMessage write SetBodyMessage;
    procedure SendEMail;
  protected
    procedure Execute;  override;
  end;

  function SendSMTPMail(APort: Integer;
                        ASMTPServer, APassword, AFromAddress: String;
                        AToAddresses, ABodyText: TStrings): Boolean;

implementation

{ TSendMail }
constructor TSendMail.Create(ASuspended: Boolean);
begin
  inherited Create(ASuspended);
  FreeOnTerminate := True;
  FBodyMessage := TStringList.Create;
  FRecipientsList := TStringList.Create;
end;

procedure TSendMail.Execute;
var
  FIdSMTP: TIdSMTP;
  FIdMessage: TIdMessage;
begin
  FIdSMTP := TIdSMTP.Create(nil);
  FIdMessage := TIdMessage.Create(nil);
  try
    FIdSMTP.Host := FServerName;
    FIdSMTP.Port := FPortNumber;
    FIdSMTP.Password:= FPassword;
    FIdMessage.From.Address := FFromAddress;
    FIdmessage.Recipients.Assign(FRecipientsList);
    FIdMessage.Subject := FSubject;
    FIdMessage.Body.Assign(FBodyMessage);
    try
      FIdSMTP.Connect;
      FIdSMTP.Send(FIdMessage);
    except end;
  finally
    if FIdSMTP.Connected then FIdSMTP.Disconnect;
    FreeAndNil(FIdMessage);
    FreeAndNil(FIdSMTP);
  end;
end;

procedure TSendMail.SendEMail;
begin
  Resume;
end;

procedure TSendMail.SetBodyMessage(const Value: TStrings);
begin
  FBodyMessage.Assign(Value);
end;

procedure TSendMail.SetFromAddress(const Value: String);
begin
  FFromAddress := Value;
end;

procedure TSendMail.SetPasword(const Value: String);
begin
  FPassword := Value;
end;

procedure TSendMail.SetPortNumber(const Value: Integer);
begin
  FPortNumber := Value;
end;

procedure TSendMail.SetRecipientsList(const Value: TStrings);
begin
  FRecipientsList.Assign(Value);
end;

procedure TSendMail.SetServerName(const Value: String);
begin
  FServerName := Value;
end;

procedure TSendMail.SetSubject(const Value: String);
begin
  FSubject := Value;
end;

function SendSMTPMail(APort: Integer; ASMTPServer, APassword,
  AFromAddress: String; AToAddresses, ABodyText: TStrings): Boolean;
begin
  try
    with TSendMail.Create(True) do
    begin
      PortNumber := APort;
      ServerName := ASMTPServer;
      Password   := APassword;
      FromAddress := AFromAddress;
      Recipients.Assign(AToAddresses);
      Body.Assign(ABodyText);
      SendEMail;
      {no need to free, its a self destructive thread}
    end;
    Result := True;
  except
    Result := False;
  end;
end;

end.

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 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; 

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;

Post your Favorite Code here...

Would you be interested in posting your sample code or comments or information into this blog?