Convert 8 or 16 bit color images to 32 bit

Problem/Question/Abstract:

How do I convert a 8 bit color image or a 16 bit color image to 32 bits of color? In my case, I have files with 8bit or 16bit images which I read using scanline. So I have one or two bytes determining the pixel color. What I want to do is still read one or two bytes for each pixel, for either the 8bit or the 16bit, but convert it to 32 bits on display.

Answer:

I think you mean 8 or 16 bit per pixel, not 8 or 16 per sample. You must divide the 8 bit and the 16 bit. 8 bit is a indexed image (palette image). The pixel value is an index in a color table (palette). You need a pointer to this color table and get the color from this table. 16 bit is an RGB image, the pixel directly contains the color data. Unfortunately, you must determine the pixel mask. On Win9x the data can be 5 bit blue, 6 bit green, 5 bit red or 5 bit blue, 5 bit green, 5 bit red (bit 15 is unused). On WinNT or later the data can be stored in other combinations, but this is unlikely.

From a own project to convert such pixel data:

function DIB555ToBGR(Value: DWord): DWord; assembler;
asm
  {blue}
  mov   ecx, eax
  shl   eax, 3
  mov   edx, eax
  and   eax, $0000F8
  shr   ecx, 2
  and   ecx, $000007
  or    eax, ecx
  {green}
  shl   edx, 3
  mov   ecx, edx
  and   edx, $00F800
  or    eax, edx
  shr   edx, 5
  and   edx, $000700
  or    eax, edx
  {red}
  shl   ecx, 3
  and   ecx, $F80000
  or    eax, ecx
  shr   ecx, 5
  and   ecx, $070000
  or    eax, ecx
end;

function DIB565ToBGR(Value: DWord): DWord; assembler;
asm
  {blue}
  mov   ecx, eax
  shl   eax, 3
  mov   edx, eax
  and   eax, $0000F8
  shr   ecx, 2
  and   ecx, $000007
  or    eax, ecx
  {green}
  shl   edx, 2
  mov   ecx, edx
  and   edx, $00FC00
  or    eax, edx
  shr   edx, 6
  and   edx, $000300
  or    eax, edx
  {red}
  shl   ecx, 3
  and   ecx, $F80000
  or    eax, ecx
  shr   ecx, 5
  and   ecx, $070000
  or    eax, ecx
end;

However, I think you should simple use TBitmap.PixelFormat:

PixelFormat := pf32Bit;

This sets the bitmap to 32 Bit.

On the other side, you can directly display the 8 or 16 bit bitmap, the WinAPI convert the bitmap to the correct format.

Coloring Cells in a StringGrid / DBGrid

Problem/Question/Abstract:

StringGrids / DBGrids with colored cells looks very nice and you can inform the user about importent data inside the Grid.

Answer:

Unfortunately you can't use the same method for coloring StringGrids and DBGrids. So first let's have a look to the StringGrid:

1. StringGrid

Use the "OnDrawCell"-event to make your StringGrids colorful! The following Code shows how to give your Grid a red background color. The second column will be colored with green background.

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);

const //define your color here. Of course you
  //can use default colors too.
  clPaleGreen = TColor($CCFFCC);
  clPaleRed = TColor($CCCCFF);

begin

  //Does the cell have the focus you have to paint it with other colors
  if (gdFocused in State) then
  begin
    StringGrid1.Canvas.Brush.Color := clBlack;
    StringGrid1.Canvas.Font.Color := clWhite;
  end
  else //Does the cell have NOT the focus you can use
    //your personal colors here
    if ACol = 2 //the second Column should be
    {//green, the other cells red } then
      StringGrid1.Canvas.Brush.color := clPaleGreen
    else
      StringGrid1.canvas.brush.Color := clPaleRed;

  //Now Paint the cells, but only, if the cell isn't the Title- Row/Column
  //This of course depends whether you have title-Row/Columns or not.

  if (ACol > 0) and (ARow > 0) then
  begin
    //Painting the Background
    StringGrid1.canvas.fillRect(Rect);

    //Painting the Text. Here you can improve the code with
    // using alignment and so on.
    StringGrid1.canvas.TextOut(Rect.Left, Rect.Top, StringGrid1.Cells[ACol, ARow]);
  end;
end;

If you want to colorize your cells depending on values in the cells you can replace the 3 lines (if Acol = 2 ......) with something like this

if StringGrid1.Cells[ACol, ARow] = 'highlight it' then
  StringGrid1.Canvas.Brush.color := clPalered
else
  StringGrid1.canvas.brush.Color := clwhite;

But now lets coloring DBGrids:

2. DBGrid

It's much easier to give color to DBGrids. Here you have to use the "OnDrawColumnCell"-Event. The following example is coloring the Cells of Column "Status" when the value is not "a".
If you want to color the whole line you only have to delete the "If..." statement (see below)

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
  DataCol: Integer; Column: TColumn;
  State: TGridDrawState);
const
  clPaleGreen = TColor($CCFFCC);
  clPaleRed = TColor($CCCCFF);
begin

  if Column.FieldName = 'Status' then //Remove this line, if you want
    //to highlight the whole line

    if Column.Field.Dataset.FieldbyName('Status').AsString <> 'a' then
      if (gdFocused in State) {//does the cell have the focus? } then
        dbgrid1.canvas.brush.color := clBlack //focused
      else
        dbgrid1.canvas.brush.color := clPaleGreen; //not focused

  //Now let's paint the cell using a Default-Method:
  dbgrid1.DefaultDrawColumnCell(rect, DataCol, Column, State)
end;

How to draw text on the Windows taskbar

Problem/Question/Abstract:

Does anyone know how to write a text on the main taskbar in Win95 using Delphi 3.0?

Answer:

This modified splash procedure that I use draws text directly on the Start button. Perhaps it helps. I normally use it to draw splash text directly on screen. To do that, use DC:= GetDC(0):


procedure TForm1.Button1Click(Sender: TObject);
var
  DC: hDC;
  Size: TSize;
  Font: hFont;
const
  DispText = 'Test';
begin
  DC := GetDC(GetDlgItem(FindWindow(PChar('Shell_TrayWnd'), nil), $130));
  ShowMessage(IntToStr(GetDlgItem(FindWindow(PChar('Shell_TrayWnd'), nil), $130)));
  SetBkMode(DC, TRANSPARENT);
  Font := CreateFont(12, 10, 0, 0, 1000, 0, 0, 0, ANSI_CHARSET, OUT_DEVICE_PRECIS,
    CLIP_DEFAULT_PRECIS, PROOF_QUALITY, DEFAULT_PITCH, 'ARIAL');
  SelectObject(DC, Font);
  SetTextColor(DC, RGB(128, 128, 0));
  GetTextExtentPoint(DC, PChar(DispText), Length(DispText), Size);
  TextOut(DC, 0, 0, PChar(DispText), Length(DispText));
  DeleteObject(Font);
  ReleaseDC(GetDlgItem(FindWindow(PChar('Shell_TrayWnd'), nil), $130), DC);
end;

How to use a TImage as the background for a TDBGrid

Problem/Question/Abstract:

I would like to have a DBGrid on a form that contains a bitmap and have the text in the cells of the grid float on the bitmap. I've tried using SetBKMode but apparently I'm using it incorrectly. Is there a separate canvas for each cell as well as the grid itself?

Answer:

Place a TImage on a form or create it off-screen and put the following (untested) code in the OnDrawColumnCell event of the grid:


procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
  DataCol: Integer; Column: TColumn; State: TGridDrawState);
var
  w, h: Integer;
begin
  with DBGrid1.Canvas do
  begin
    w := Rect.Right - Rect.Left;
    h := Rect.Bottom - Rect.Top;
    BitBlt(DBGrid1.Canvas.Handle, Rect.Left, Rect.Top, w, h,
      Image1.Picture.Bitmap.Canvas.Handle, Rect.Left, Rect.Top, SRCCOPY);
    Brush.Style := bsClear;
    TextOut(Rect.left, Rect.Top, Column.Field.AsString);
  end;
end;

Return identity id from insert_SQL

Problem/Question/Abstract:

How can i obtain the value of the identity column in a table, when inserting a record with a INSERT SQL statement.

Answer:

Found the following note when surfing several sql-dba website forums:

You can use the SET NOCOUNT statement. SET NOCOUNT ON will prevent SQL Server from telling you how many rows each statement affected. SET NOCOUNT OFF will return SQL Server back to it's default setting. The variable @@ROWCOUNT will always contain the number of rows affected by the previous statement regardless of the setting of NOCOUNT

do use this statement to obtain the value of the inserted id:

whe have a table called TheTable with fields:

Field_ID (identity column)
Field001 (varchar)
Field002 (int)

Set Nocount on
Insert TheTable (Field001, Field002)
VALUES ('ABC', 1)
select IdentityInsert=@@identity
set nocount off

Example usage:

I have an order table with the primary order data, and a related table called orderdetails with the orderdetails per primary order data. The primary order table contains a key, field OrderID, of type identity-column autoincrement start at 0 and increment with 1. The table orderdetails contains the orderId as foreign key.

Case asp e-business website:

The visitor wants to checkout the order wich is composed. Now fire the insert sql to insert a record in the primary order table, using the script in this article to obtain the order id. With the obtained order id fire the several sql_inserts into the the order details table.

Tested with sqlserver 7, ado, d5, asp

Create a Menu from XML-File

Problem/Question/Abstract:

How can you build up the content of e.g. a TMainMenu from a XML-File?

Perhaps you have a program which also includes an administration part for a database, but only some users should be able to see and use this administration part. Why don't create a XML-File, which contains the menu of the program. When the program starts, it builds its menu from this XML-File. And only the people who should be able to see and use the administration part get the XML-File which contains it, all other users have a file without this part.

This way it's very hard for hackers to get into the administration part.

And when you even encrypt your XML-File, it should nearly unpossible.

But how can we do this?

Answer:

A special feature of the code below: You only need to specify the Name of the procedure which then
will be attached to a OnClick handler (but all this procedures MUST be public)

At first, insert this code in your mainform and add a TMainMenu (without any content) and a TXMLDocument to your form.

procedure TMainForm.CreateMenuFromXMLFile;

  function Get_Int(S: string): Integer;
  begin
    Result := 0;
    try
      Result := StrToInt(S);
    except
    end;
  end;

  procedure AddRecursive(Parent: TMenuItem; Item: IXMLNode);
  var
    I: Integer;
    Node: TMenuItem;
    Child: IXMLNode;
    Address: TMethod;
  begin
    Node := TMenuItem.Create(Parent);
    if (Uppercase(Item.Attributes['CAPTION']) <> 'SEPERATOR') then
    begin
      Node.Caption := Item.Attributes['CAPTION'];
      if (Uppercase(Item.Attributes['ID']) <> 'NONE') then
      begin
        Address.Code := MethodAddress(Item.Attributes['ID']);
        Address.Data := Self;
        if (Item.ChildNodes.Count - 1 < 0) then
          Node.OnClick := TNotifyEvent(Address);
      end;
      if (Uppercase(Item.Attributes['SHORTCUT']) <> 'NONE') then
        Node.ShortCut := TextToShortCut(Item.Attributes['SHORTCUT']);
      Node.Checked := (Item.Attributes['CHECKED'] = '1');
    end
    else
      Node.Caption := '-';
    Node.Visible := (Item.Attributes['VISIBLE'] = '1');
    if Parent <> nil then
      Parent.Add(Node)
    else
      MainMenu.Items.Add(Node);

    for I := 0 to Item.ChildNodes.Count - 1 do
    begin
      Child := item.ChildNodes[i];
      if (Child.NodeName = 'ENTRY') then
        AddRecursive(Node, Child);
    end;
  end;

var
  Root: IXMLMENUType;
  Parent: TMenuItem;
  I: Integer;
  Child: IXMLNode;
begin
  XMLDocument.FileName := ExtractFilePath(Application.ExeName) + XMLFile;
  if not FileExists(XMLDocument.FileName) then
  begin
    MessageDlg('Menu-XML-Document not found!', mtError, [mbOK], 0);
    Halt;
  end;
  XMLDocument.Active := True;

  Screen.Cursor := crHourglass;
  try
    Root := GetXMLMenu(XMLDocument);
    Parent := nil;

    for I := 0 to Root.ChildNodes.Count - 1 do
    begin
      Child := Root.ChildNodes[i];
      if (Child.NodeName = 'ENTRY') then
        AddRecursive(Parent, Child);
    end;
  finally
    Screen.Cursor := crDefault;
  end;
end;



This was the first step.
You also need the encapsulation of the XML-File.
( Save the code below as unit and add it to your program.
Created with Delphi6 -> New -> XML Data Binding Wizard )

{***************************************************}
{                                                   }
{ Delphi XML-Datenbindung                           }
{                                                   }
{ Erzeugt am: 27.06.2002 13:25:01                   }
{                                                   }
{***************************************************}

unit XMLMenuTranslation;

interface

uses xmldom, XMLDoc, XMLIntf;

type

  { Forward-Deklarationen }

  IXMLMENUType = interface;
  IXMLENTRYType = interface;

  { IXMLMENUType }

  IXMLMENUType = interface(IXMLNode)
    ['{8F36F5E2-834F-41D9-918F-9B1A441C9074}']
    { Zugriff auf Eigenschaften }
    function Get_ENTRY: IXMLENTRYType;
    { Methoden & Eigenschaften }
    property ENTRY: IXMLENTRYType read Get_ENTRY;
  end;

  { IXMLENTRYType }

  IXMLENTRYType = interface(IXMLNode)
    ['{AD85CD05-725E-40F8-A8D7-D6EC05FD4360}']
    { Zugriff auf Eigenschaften }
    function Get_CAPTION: WideString;
    function Get_VISIBLE: Integer;
    function Get_ID: Integer;
    function Get_ENTRY: IXMLENTRYType;
    procedure Set_CAPTION(Value: WideString);
    procedure Set_VISIBLE(Value: Integer);
    procedure Set_ID(Value: Integer);
    { Methoden & Eigenschaften }
    property Caption: WideString read Get_CAPTION write Set_CAPTION;
    property Visible: Integer read Get_VISIBLE write Set_VISIBLE;
    property ID: Integer read Get_ID write Set_ID;
    property ENTRY: IXMLENTRYType read Get_ENTRY;
  end;

  { Forward-Deklarationen }

  TXMLMENUType = class;
  TXMLENTRYType = class;

  { TXMLMENUType }

  TXMLMENUType = class(TXMLNode, IXMLMENUType)
  protected
    { IXMLMENUType }
    function Get_ENTRY: IXMLENTRYType;
  public
    procedure AfterConstruction; override;
  end;

  { TXMLENTRYType }

  TXMLENTRYType = class(TXMLNode, IXMLENTRYType)
  protected
    { IXMLENTRYType }
    function Get_CAPTION: WideString;
    function Get_VISIBLE: Integer;
    function Get_ID: Integer;
    function Get_ENTRY: IXMLENTRYType;
    procedure Set_CAPTION(Value: WideString);
    procedure Set_VISIBLE(Value: Integer);
    procedure Set_ID(Value: Integer);
  public
    procedure AfterConstruction; override;
  end;

  { Globale Funktionen }

function GetXMLMENU(Doc: IXMLDocument): IXMLMENUType;
function LoadMENU(const FileName: WideString): IXMLMENUType;
function NewMENU: IXMLMENUType;

implementation

{ Globale Funktionen }

function GetXMLMENU(Doc: IXMLDocument): IXMLMENUType;
begin
  Result := Doc.GetDocBinding('MENU', TXMLMENUType) as IXMLMENUType;
end;

function LoadMENU(const FileName: WideString): IXMLMENUType;
begin
  Result := LoadXMLDocument(FileName).GetDocBinding('MENU', TXMLMENUType) as
    IXMLMENUType;
end;

function NewMENU: IXMLMENUType;
begin
  Result := NewXMLDocument.GetDocBinding('MENU', TXMLMENUType) as IXMLMENUType;
end;

{ TXMLMENUType }

procedure TXMLMENUType.AfterConstruction;
begin
  RegisterChildNode('ENTRY', TXMLENTRYType);
  inherited;
end;

function TXMLMENUType.Get_ENTRY: IXMLENTRYType;
begin
  Result := ChildNodes['ENTRY'] as IXMLENTRYType;
end;

{ TXMLENTRYType }

procedure TXMLENTRYType.AfterConstruction;
begin
  RegisterChildNode('ENTRY', TXMLENTRYType);
  inherited;
end;

function TXMLENTRYType.Get_CAPTION: WideString;
begin
  Result := ChildNodes['CAPTION'].Text;
end;

procedure TXMLENTRYType.Set_CAPTION(Value: WideString);
begin
  ChildNodes['CAPTION'].NodeValue := Value;
end;

function TXMLENTRYType.Get_VISIBLE: Integer;
begin
  Result := ChildNodes['VISIBLE'].NodeValue;
end;

procedure TXMLENTRYType.Set_VISIBLE(Value: Integer);
begin
  ChildNodes['VISIBLE'].NodeValue := Value;
end;

function TXMLENTRYType.Get_ID: Integer;
begin
  Result := ChildNodes['ID'].NodeValue;
end;

procedure TXMLENTRYType.Set_ID(Value: Integer);
begin
  ChildNodes['ID'].NodeValue := Value;
end;

function TXMLENTRYType.Get_ENTRY: IXMLENTRYType;
begin
  Result := ChildNodes['ENTRY'] as IXMLENTRYType;
end;

end.


Finally, I'll show you an example for the XML-File.
The Procedure Name is assigned to the ID which then will be called.

<?xml version="1.0" encoding="ISO-8859-1"?>
<MENU>
        <ENTRY CAPTION="Datei" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0">
                <ENTRY CAPTION="Beenden" VISIBLE="1" ID="CloseProgram" SHORTCUT="Strg+X" CHECKED="0"></ENTRY>
        </ENTRY>

        <ENTRY CAPTION="Anzeige" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0">
                <ENTRY CAPTION="Toolbar" VISIBLE="1" ID="ShowToolbar" SHORTCUT="None" CHECKED="1"></ENTRY>
                <ENTRY CAPTION="Seperator" VISIBLE="1"></ENTRY>
                <ENTRY CAPTION="Optionen" VISIBLE="1" ID="ShowOptionen" SHORTCUT="Strg+O" CHECKED="0"></ENTRY>
        </ENTRY>

        <ENTRY CAPTION="News" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0">
                <ENTRY CAPTION="Refresh" VISIBLE="1" ID="RefreshAll" SHORTCUT="F5" CHECKED="0"></ENTRY>
                <ENTRY CAPTION="Seperator" VISIBLE="1"></ENTRY>
                <ENTRY CAPTION="Administration" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0">
                        <ENTRY CAPTION="neue Nachricht hinzuf�gen" VISIBLE="1" ID="NewMarkedNews"         SHORTCUT="Strg+N" CHECKED="0"></ENTRY>
                        <ENTRY CAPTION="markierte Nachricht bearbeiten" VISIBLE="1" ID="EditMarkedNews" SHORTCUT="Strg+E" CHECKED="0"></ENTRY>
                        <ENTRY CAPTION="markierte Nachricht l�schen" VISIBLE="1" ID="DeleteMarkedNews" SHORTCUT="None" CHECKED="0"></ENTRY>
                        <ENTRY CAPTION="Seperator" VISIBLE="1"></ENTRY>
                        <ENTRY CAPTION="Film hinzuf�gen" VISIBLE="1" ID="AddMPG" SHORTCUT="None" CHECKED="0"></ENTRY>
                        <ENTRY CAPTION="markierten Film l�schen" VISIBLE="1" ID="DeleteMPG" SHORTCUT="None" CHECKED="0"></ENTRY>
                </ENTRY>
        </ENTRY>

        <ENTRY CAPTION="Hilfe" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0">
                <ENTRY CAPTION="LogView" VISIBLE="1" ID="ShowLog" SHORTCUT="Strg+L" CHECKED="0"></ENTRY>
                <ENTRY CAPTION="eMail schreiben" VISIBLE="1" ID="WriteEMail" SHORTCUT="None" CHECKED="0"></ENTRY>
                <ENTRY CAPTION="Seperator" VISIBLE="1"></ENTRY>
                <ENTRY CAPTION="�ber" VISIBLE="1" ID="About" SHORTCUT="None" CHECKED="0"></ENTRY>
        </ENTRY>

</MENU>



The first Node should be <MENU> ... </MENU>

There you can the use <ENTRY ...></ENTRY>. When you write another entry before the Entry-Endtag, this will be a submenu item.

The parameters for ENTRY are:

CAPTION - this is the string which is displayed in the Menu. If this string is "Seperator", a Seperator will be insert
VISIBLE - when zero, the MenuItem will be generated but not displayed
ID - this is None for nothing or the Name of the procedure to call when the Item is clicked (BUT BE CAREFUL: THIS PROCEDURE MUST BE PUBLIC!)
SHORTCUT - None for nothing or e.g. Ctrl+X (read the Delphi-Help for 'TextToShortCut' to understand this)
CHECKED - when not zero, the MenuItem will be checked

How to track a TEdit at an OnExit event

Problem/Question/Abstract:

I'm getting a trouble with an special event inside a OnExit event. I need to know at OnExit of a TEdit Control, when the user clicks a button such as the Cancel button. The user may exit the TEdit just with a correct data or when the Cancel Button was clicked. How can I track this?

Answer:

Assuming that "BlockExit" is a global variable or field of your form:

procedure TForm1.FormCreate(Sender: TObject);
begin
  BlockExit := false;
end;

procedure TForm1.Edit1Exit(Sender: TObject);
begin
  BlockExit := (Edit1.Text <> 'OK');
end;

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  if BlockExit then
  begin
    Beep;
    Beep;
    MessageDlg('Wrong data in Edit1', mtError, [mbOK], -1);
    Edit1.SetFocus;
    CanClose := false;
  end
  else
    CanClose := true;
end;

procedure TForm1.btnCancelClick(Sender: TObject);
begin
  BlockExit := false;
  Close;
end;

procedure TForm1.btnOKClick(Sender: TObject);
begin
  Close;
end;

How to determine the caret position in a TMemo

Problem/Question/Abstract:

How to determine the caret position in a TMemo

Answer:

You can use the Windows API messages EM_LINEFROMCHAR and EM_LINEINDEX to determine the current line and offset within that line (starting from SelStart).

var
  LineNum: longint;
  CharsBeforeLine: longint;
begin
  LineNum := SendMessage(Memo1.Handle, EM_LINEFROMCHAR, Memo1.SelStart, 0);
  CharsBeforeLine := SendMessage(Memo1.Handle, EM_LINEINDEX, LineNum, 0);
  Label1.Caption := ' Line ' + IntToStr(LineNum + 1);
  Label2.Caption := ' Position ' + IntToStr((Memo1.SelStart - CharsBeforeLine) + 1);
end;

Select first five records from table

Problem/Question/Abstract:

How to select first five records from table

Answer:

I know that SQL looks like easy thing but sometimes we face some problems, try this solvation.

SELECT TOP 5 Field1, Field2, ....FROM Table1...

Check if Internet Explorer is running and get the source of the page that is displayed

Problem/Question/Abstract:

I need to identify if IE is already running on the machine, and if so, read the source of the HTML being displayed

Answer:

{ ... }

uses
  SHDocVw, MSHtml;

{ ...}
var
  ShellWindows: IShellWindows;
  Browser: IWebBrowser2;
  i: integer;
  Doc: IHTMLDocument2;
  { ...}
    { Use ShellWindows to get the active browser window }
  ShellWindows := CoShellWindows.Create;
  for i := 0 to ShellWindows.Count - 1 do
  begin
    if Supports(ShellWindows.Item(i), IWebBrowser2, Browser) then
    begin
      Doc := Browser.Document as IHTMLDocument2;
      Memo1.Clear;
      Memo1.Lines.Add(Doc.body.innerText);
      { ...}

Copy directory structures

Problem/Question/Abstract:

How to copy directory structures

Answer:

Solve 1:

The most appropriate way would be with the SHFileOperation API call. This is a snippet of a demo I have written for this. You should be able to see the functionality.

procedure TForm1.SHFileOperationCopy(sFrom, sTo, STitle: string);
var
  lpFileOp: TSHFILEOPSTRUCT;
  op, flag: Integer;
begin
  case rgOP.ItemIndex of
    0: op := FO_COPY;
    1: op := FO_DELETE;
    2: op := FO_MOVE;
    3: op := FO_RENAME;
  end;
  flag := 0;
  if AllowUndo.Checked then
    flag := flag or FOF_ALLOWUNDO;
  if ConfirmMouse.checked then
    flag := flag or FOF_CONFIRMMOUSE;
  if FilesOnly.checked then
    flag := flag or FOF_FILESONLY;
  if NoConfirm.Checked then
    flag := flag or FOF_NOCONFIRMATION;
  if NoConfirmMkdir.Checked then
    flag := flag or FOF_NOCONFIRMMKDIR;
  if RenameColl.Checked then
    flag := flag or FOF_RENAMEONCOLLISION;
  if Silent.Checked then
    flag := flag or FOF_SILENT;
  if SimpleProgress.Checked then
    flag := flag or FOF_SIMPLEPROGRESS;
  with lpFileOp do
  begin
    Wnd := Form1.Handle;
    wFunc := op;
    pFrom := pChar(sFrom);
    pTo := pChar(sTo);
    fFlags := Flag;
    hNameMappings := nil;
    lpszProgressTitle := pChar(sTitle);
  end;
  if (SHFileOperation(lpFileOp) <> 0) then
    ShowMessage('Error processing request.');
  if lpFileOp.fAnyOperationsAborted then
    ShowMessage('Operation Aborted');
end;


Solve 2:

Here is desired function - with recursion:

function copyfilesindir(const source, dest, mask: string; subdirs: Boolean): Boolean;
var
  ts: TSearchRec;

  function filewithpath(const dir, file: string): string;
  begin
    if (length(dir) > 0) and (copy(dir, length(dir), 1) <> '\') then
      result := dir + '\' + file
    else
      result := dir + file;
  end;

begin
  result := directoryexists(dest);
  if not result then
    result := createdir(dest);
  if not result then
    exit;
  if findfirst(filewithpath(source, mask), faanyfile, ts) = 0 then
    repeat
      if not ((ts.name = '.') or (ts.name = '..')) then
      begin
        if ts.Attr and fadirectory > 0 then
        begin
          if subdirs then
            result := copyfilesindir(filewithpath(source, ts.name),
              filewithpath(dest, ts.name), mask, subdirs);
        end
        else
          result := copyfile(pchar(filewithpath(source, ts.name)),
            pchar(filewithpath(dest, ts.name)), false);
        if not result then
          break;
      end;
    until
      findnext(ts) <> 0;
  findclose(ts);
end;

How to convert UNIX time to TDateTime and vice versa

Problem/Question/Abstract:

There is a date/ time format that I'm trying to translate, but I can't find anything that could match. This example is 2000-12-20 around 22:15. Integer: 977347109, Hex: 3A412225. Anyone know how to translate it?

Answer:

The value is a Unix Time, defined as seconds since 1970-01-01T00:00:00,0Z. Important is the Letter Z, you live in Sweden, in consequence you must add 1 hour for StandardDate and 2 hours for DaylightDate to the date. The infos you can get with GetTimeZoneInformation. But you must determine, which Bias (Standard or Daylight) is valid for the date (in this case -60). You can convert the date value with the function below.

The Date for 977347109 is 2000-12-20T22:18:29+01:00.

const
  UnixDateDelta = 25569; { 1970-01-01T00:00:00,0 }
  SecPerMin = 60;
  SecPerHour = SecPerMin * 60;
  SecPerDay = SecPerHour * 24;
  MinDayFraction = 1 / (24 * 60);

  {Convert Unix time to TDatetime}

function UnixTimeToDateTime(AUnixTime: DWord; ABias: Integer): TDateTime;
begin
  Result := UnixDateDelta + (AUnixTime div SecPerDay) { Days }
  + ((AUnixTime mod SecPerDay) / SecPerDay) { Seconds }
  - ABias * MinDayFraction { Bias to UTC in minutes };
end;

{Convert Unix time to String with locale settings}

function UnixTimeToStr(AUnixTime: DWord; ABias: Integer): string;
begin
  Result := FormatDateTime('ddddd  hh:nn:ss', UnixTimeToDateTime(AUnixTime, ABias));
end;

{Convert TDateTime to Unix time}

function DateTimeToUnixTime(ADateTime: TDateTime; ABias: Integer): DWord;
begin
  Result := Trunc((ADateTime - UnixDateDelta) * SecPerDay) + ABias * SecPerMin;
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
  Label1.Caption := UnixTimeToStr(977347109, -60);
end;

Create without worrying of destroy a component

Problem/Question/Abstract:

How can I prevent resources leak.

Answer:

Make use of Interface characteristic where when the reference goes out of scope it will free itself.

type
  IAutoClean = interface
    ['{61D9CBA6-B1CE-4297-9319-66CC86CE6922}']
  end;

  TAutoClean = class(TInterfacedObject, IAutoClean)
  private
    FObj: TObject;
  public
    constructor Create(AObj: TObject);
    destructor Destroy; override;
  end;

implementation

constructor TAutoClean.Create(AObj: TObject);
begin
  FObj := AObj;
end;

destructor TAutoClean.Destroy;
begin
  FreeAndNil(FObj);
  inherited;
end;

Application....

procedure TForm1.Button1Click(Sender: TObject);
var
  a: IAutoClean;
    //must declare as local variable, so when this procedure finished, it's out of scope
  o: TOpenDialog; //any component
begin
  o := TOpenDialog.Create(self);
  a := TAutoClean.Create(o);
  if o.Execute then
    ShowMessage(o.FileName);
end;

Achieve Record locking with MSSQL 7 or later

Problem/Question/Abstract:

How would you like to be able to determine if a record has been locked in MSSQL Server and not get that annoying 'Record has been changed by another User' when you finally try to post your changes? There is an easy approach (quite easy) but it has to be implemented programatically.

Answer:

For every record you want to lock to this:
Create a global temporary table that is named after the table on which the record is, together with the Unique Id of the table. For example, if you have a table named customers, with a unique id field called Uid and you want to lock the record with uid=14, create the table using this query:

  Create table ##Customers14 (id int null)

When you want to unlock the record just drop that table:

  Drop table ##Customers14

Now lets say that another user wants to use the same record. His client program tries to create the same global temporary table, but fails with an exception, because no two global temporary tables can have the same name. Trap the exception in a try-except clause and you are home free.

TIPS.

Use this only for SQLServer 7 and above. SQL 6.5 and below have a terrible way of handling Temprorary tables that gives a lot of overhead.

You can create any kind of collumn in your temporary table, so you can have info like what time the record was locked and by what user.

Never use this approach if there is a chance someone will forget his computer open on a record for hours, and that computer is located lets say 100 miles  from the server!!!

If the connection is lost by lets say an application error, the table is automatically droped by the SQL Server.

If the computer shutsdown by a power failure, the SQL Server waits for about 15 minutes and then drops the temporary table, or if the computer logs on again  the table is droped automatically.

If you don't want to have to handle an exception you can also check for the existance of the Temporary table in the Master database.