Delphi, C# .NET Tips & Tricks

Sunday, July 29, 2007

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.

Thursday, July 26, 2007

Display a shaded column like Windows Explorer in XP

The Windows Explorer in XP displays the sorted column in pale grey. We can bring up similar behaviour in Delphi TListView by handling all two OnCustomDraw, OnColumnClick events to display a list view with a specified column shaded in pale grey.


procedure TForm1.ListView1ColumnClick(Sender: TObject; Column: TListColumn);
begin
  FColumnToSort := Column.Index;
  ListView1.Invalidate;
end; 

procedure TForm1.ListView1CustomDraw(Sender: TCustomListView; const ARect: TRect; var DefaultDraw: Boolean);
var
  ColLeft: Integer;   
  ColBounds: TRect;
  I: Integer;      
begin
  ColLeft := ARect.Left;
  for I := 0 to Pred(FColumnToSort) do
    ColLeft := ColLeft + ListView_GetColumnWidth(ListView1.Handle, I);

  ColBounds := Rect(ColLeft, ARect.Top, ColLeft + ListView_GetColumnWidth(ListView1.Handle, FColumnToSort), ARect.Bottom);

  ListView1.Canvas.Brush.Color := clSilver;
  ListView1.Canvas.FillRect(ColBounds);
end;

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;