Delphi Magic: 1/8/08

Delphi magic packet : wake on lan

//Function HexToInt used in this procedure is defined in
//the category "Conversions" of this web

PROCEDURE WakeUPComputer(aMacAddress: STRING);
VAR
i, j: Byte;
//lBuffer: array[1..116] of Byte;
lBuffer: SysUtils.TBytes;
lUDPClient: TIDUDPClient;
BEGIN
TRY
FOR i := 1 TO 6 DO BEGIN
lBuffer[i] := HexToInt(aMacAddress[(i * 2) - 1] + aMacAddress[i * 2]); END;
lBuffer[7] := $00;
lBuffer[8] := $74;
lBuffer[9] := $FF;
lBuffer[10] := $FF;
lBuffer[11] := $FF;
lBuffer[12] := $FF;
lBuffer[13] := $FF;
lBuffer[14] := $FF;
FOR j := 1 TO 16 DO BEGIN
FOR i := 1 TO 6 DO BEGIN
lBuffer[15 + (j - 1) * 6 + (i - 1)] := lBuffer[i];
END;
END;
lBuffer[116] := $00;
lBuffer[115] := $40;
lBuffer[114] := $90;
lBuffer[113] := $90;
lBuffer[112] := $00;
lBuffer[111] := $40;
TRY
lUDPClient := TIdUDPClient.Create(NIL);
lUDPClient.BroadcastEnabled := true;
lUDPClient.Host := '255.255.255.255';
lUDPClient.Port := 2050;
// d6 lUDPClient.SendBuffer(lBuffer, 116);
lUDPClient.SendBuffer(lUDPClient.Host, lUDPClient.Port, tidbytes(lBuffer));
FINALLY
lUDPClient.Free;
END;
EXCEPT
RAISE;
END;
END;

Compose an HTML email with Outlook from Delphi

uses
Windows, ComObj, ActiveX;
const
olMailItem = 0;
var
Outlook, NmSpace, Folder: OleVariant;
miMail: Variant;
begin
Outlook := CreateOleObject('Outlook.Application');
miMail := Outlook.CreateItem(olMailItem);
miMail.Recipients.Add('billy@boy.com');
miMail.Subject := 'Hello Bill';
// use this to send a plain text email (all versions of Outlook)
miMail.Body := 'Attached is the list of email addresses.';
// alternatively send an HTML email (not in Outlook 97)
miMail.HTMLBody := 'Attached is the list of email addresses.';
miMail.Attachments.Add('C:\temp\list.txt', EmptyParam, EmptyParam, EmptyParam);
miMail.Send;
//...
end;

Accessing HotMail from Delphi

program dummy;
uses
ShellAPI;
var
ToAddress: String;
EightSpaces: String;
begin
ToAddress := 'john@pacbell.net';
// Don't know why but this is required to get the
// correct compose address...
EightSpaces := ' ';
ShellExecute(Handle, PChar('open'), PChar('rundll32.exe'),
PChar('C:\PROGRA~1\INTERN~1\HMMAPI.DLL,MailToProtocolHandler'
+ EightSpaces + ToAddress), nil, SW_NORMAL)
end.

Detect your MAC address using NetBIOS in Delphi

program GetMAC;

uses

Dialogs, SysUtils, nb30;

function GetMACAddress(PCName: string) : string;

type

TASTAT = packed record

adapt: nb30.TADAPTERSTATUS;

NameBuff: array [0..30] of TNAMEBUFFER;

end;

var

NCB: TNCB;

Tmp: String;

pASTAT: Pointer;

AST: TASTAT;

begin

// The IBM NetBIOS 3.0 specifications defines four basic

// NetBIOS environments under the NCBRESET command. Win32

// follows the OS/2 Dynamic Link Routine (DLR) environment.

// This means that the first NCB issued by an application

// must be a NCBRESET, with the exception of NCBENUM.

// The Windows NT implementation differs from the IBM

// NetBIOS 3.0 specifications in the NCB_CALLNAME field.

FillChar(NCB, SizeOf(NCB), 0);

NCB.ncb_command := Chr(NCBRESET);

NetBios(@NCB);

// To get the Media Access Control (MAC) address for an

// ethernet adapter programmatically, use the Netbios()

// NCBASTAT command and provide a "*" as the name in the

// NCB.ncb_CallName field (in a 16-chr string).

// NCB.ncb_callname = "* "

FillChar(NCB, SizeOf(NCB), 0);

FillChar(NCB.ncb_callname[0], 16, ' ');

Move(PCName[1], NCB.ncb_callname[0], Length(PCName));

NCB.ncb_command := Chr(NCBASTAT);

// For machines with multiple network adapters you need to

// enumerate the LANA numbers and perform the NCBASTAT

// command on each. Even when you have a single network

// adapter, it is a good idea to enumerate valid LANA numbers

// first and perform the NCBASTAT on one of the valid LANA

// numbers. It is considered bad programming to hardcode the

// LANA number to 0 (see the comments section below).

NCB.ncb_lana_num := #0;

NCB.ncb_length := SizeOf(AST);

GetMem(pASTAT, NCB.ncb_length);

if pASTAT=nil then

begin

result := 'memory allocation failed!';

exit;

end;

NCB.ncb_buffer := pASTAT;

NetBios(@NCB);

Move(NCB.ncb_buffer, AST, SizeOf(AST));

with AST.adapt do

Tmp := Format('%.2x-%.2x-%.2x-%.2x-%.2x-%.2x',

[ord(adapter_address[0]), ord(adapter_address[1]), ord(adapter_address[2]),

ord(adapter_address[3]), ord(adapter_address[4]), ord(adapter_address[5])]);

FreeMem(pASTAT);

Result := Tmp;

end;

begin

ShowMessage(GetMACAddress('*'));

end.

How to take a snapshot from the GLScene viewer

Sample code using GLSceneViewer1.Buffer.CreateSnapShot

procedure TForm1.TakeSnapShot;
var bm : TBitmap;
bmp32 : TGLBitmap32;
begin
bmp32:=GLSceneViewer1.Buffer.CreateSnapShot;
try
bm:=bmp32.Create32BitsBitmap;
try
SavePictureDialog1.DefaultExt := GraphicExtension(TBitmap);
SavePictureDialog1.Filter := GraphicFilter(TBitmap);
if SavePictureDialog1.Execute then
bm.SaveToFile(SavePictureDialog1.FileName);
finally
bm.Free;
end;
finally
bmp32.Free;
end;
end;

Theres also a demo in your GLScene folder...\Demos\rendering\tobitmap

Free textures

Check out this site for free textures:http://www.3dlinks.com/links.cfm?categoryid=10&subcategoryid=94

Turbosquid is a commercial site that sells textures but they also host free ones. You need to open a free account here.http://www.turbosquid.com/

Where to get free 3D models

For hundreds of free static models (eg an apple) http://www.3dcafe.com/

NTU 3D Model Database has a massive database of wavefront free models:http://3d.csie.ntu.edu.tw/~dynamic/database/index.html

Turbosquid is a commercial site that sells 3D models but they also host free ones. You need to open a free account here.http://www.turbosquid.com/

Also from the NTU 3D Model Database but with pictures and also only has the first 1000 models from the database:http://www.skinhat.com/freemodels

For actors (eg Quake, Half life models) - Currently down :http://www.planetquake.com/polycount/

LIBROS:

Autocad 3D, DIBUJO Y MODELADO

3D con Photoshop

Aprender Maya, nivel avanzado, ejemplos y ejercicios

Aprender 3DS Max 2017 con 100 ejercicios prácticos

Programación en 3D con Java

Aprende Blender, diseño y creatividad

Cutting a hole in terrain

A question that pops up occasionally is 'How to do I cut a transparent hole into my terrain?'. The answer is to apply a superblack transparent texture to your terrain which has pure black where you want the hole. For your terrain texture set blendingmode to bmTransparent and set imageAlpha to tiaSuperblacktransparent. Remember jpegs arent lossless which means that where your image may be 100% black, when it saves it it may actually be saved as 99% black. When you view your terrain you could see an ugly black outline around the terrain hole. The solution is to use bmp, tga or jp2 files which are lossless.

How to get FPS in full screen

Most of the coders think that FPS procedures like FramesPerSecond and ResetPerformanceCounter are only the properties of TGLSceneViewer but actually they are the part of TGLSceneViewer.Buffer (TGLSceneBuffer class). As long as TGLFullScreenViewer has this class also, you can access FPS with the following code:

TGLFullScreenViewer.Buffer.FramesPerSecond
TGLFullScreenViewer.Buffer.ResetPerformanceMonitor

How to control the Camera without gimbal errors using Pitch and Turn

In the tutorial section there is a tutorial about using Pitch, Roll and turn on GLScene objects. This tutorial explains the problems with gimbal lock which occurs when you change more that one of the three angle axis (Turn, Pitch and roll).

A simple trick is to make use of dummy cubes to construct a tripot. We start with the base cube. This TDummyCube is used to position the camera in the scene. The base cube can also be used to turn the camera (Rotate about the green Y axis).
Now we add a child TDummyCube to the base cube. Lets call this the pitch cube. This Pitch cube is exclusivly used to only pitch the camera up and down. Finally you add the camera which will be a child to the Pitch cube.

Here the geen cube is the basecube to which position instructions and turn instructions are given. The Red cube is the pitch cube which is used only to change the pitch angle. The arrow in the image represents the camera pointing direction which is added for visualisation purposes.

Tip Note the light attached to the camera. This way it is always where you want it and pointing where the camera points. Make sure to use a position offset for the light to improve the surface shading contrast

To move the camera, turn it towards the subject and pitch it up you code this:

BaseCube.Position.X := BaseCube.Position.X + 1; BaseCube.TurnAngle := BaseCube.TurnAngle + 1; PitchCube.PitchAngle := PitchCube.PitchAngle + 1;

Author Eric Grange

Using multiple viewers

To use multiple viewers in the same application at the same time can be easily achieved. You just have to put your TGLCadencer to the cmManual mode and to use a timer to call the Progress() method of the cadencer in the timer event.

Activating a Shadow (Firebird)

The switch for activating a shadow when a database dies is –ac[tivate]. The syntax is

gfix -ac

Suppose the shadow’s first volume, employee.sh1, is in a directory /opt/
dbshadows. You would activate it with this command:

./gfix -ac /opt/dbshadows/employee.sh1

Finding Limbo Transactions (Firebird)

To list the IDs of all limbo transactions

gfix -l db_name

Validate a database (Firebird)

To validate a database, simply enter the command

gfix -v

Validation will silently locate and free any unassigned pages or misallocated structures

it finds. It will report any corrupt structures but does not attempt to mend them.

To have gfix report faults but not attempt to free the spaces, include the –n[o_update]

switch:

gfix -v -n

You can have the validation ignore checksum errors by adding the –i[gnore]

switch:

gfix -v -i

Libros:

Bases de datos, grado superior

Aprende SQL en un fin de semana

Bases de datos, todo lo que hay que saber!

Sistemas gestores de bases de datos, grado superior

SQL (Manuales imprescindibles)

Make / restore a backup (Firebird)

Make a backup

gbak -t -user sysdba -pass masterkey mibase.fdb mibase.fbk

Restore a backup

gbak -r -user sysdba -pass masterkey mibase.fbk mibase.fdb

Customized tooltips

...
type
TMyHintWindow = class(THintWindow)
constructor Create(AOwner: TComponent); override;
end;
...
constructor TMyHintWindow.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Canvas.Font.Name := ’Arial’;
Canvas.Font.Size := 14;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.ShowHint := false;
HintWindowClass := TMyHintWindow;
Application.ShowHint := true;
end;

Determine the size of a file without opening it

USES
SysUtils;
...


FUNCTION FileSizeByName(CONST AFile: STRING): integer;
VAR
   sr: TSearchRec;
BEGIN
   IF (Pos(AFile, ’ * ’) <> 0) OR (Pos(AFile, ’?’) <> 0) OR
      (FindFirst(AFile, faAnyFile, sr) <> 0)
      THEN result := 1
//file was not found
   ELSE result := sr.Size;
END;

Append items into system menu

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;
end;
...
const
ID_ABOUT = WM_USER + 1;
procedure TForm1.FormCreate(Sender: TObject);
var
hSysMenu: HMENU;
begin
hSysMenu := GetSystemMenu(Handle, false);
AppendMenu(hSysMenu, MF_SEPARATOR, 0, nil);
AppendMenu(hSysMenu, MF_STRING, ID_ABOUT, PChar(’&About...’));
end;

procedure TForm1.WMSysCommand(var Msg: TWMSysCommand);
begin
if Msg.CmdType = ID_ABOUT then
AboutForm.ShowModal
else
inherited;
end;

Drag’n’drop files from Windows Explorer


TYPE
   TForm1 = CLASS(TForm)
      PROCEDURE FormCreate(Sender: TObject);
   PRIVATE
      PROCEDURE WMDropFiles(VAR Msg: TWMDROPFILES); MESSAGE WM_DROPFILES;
   END;
   ...


PROCEDURE TForm1.FormCreate(Sender: TObject);
BEGIN
   DragAcceptFiles(Handle, true);
END;

PROCEDURE TForm1.WMDropFiles(VAR Msg: TWMDROPFILES);
VAR
   buf: ARRAY[0..MAX_PATH] OF char;
   filename: STRING;
BEGIN
   DragQueryFile(Msg.Drop, 0, @buf, sizeof(buf));
   DragFinish(Msg.Drop);
   filename := STRING(buf);
   ...
END;

Show/hide titlebar of a form

...
uses
Forms, Windows;
...
procedure ShowTitlebar(AForm: TForm; AShow: boolean);
var
style: longint;
begin
with AForm do begin
if BorderStyle = bsNone then exit;
style := GetWindowLong(Handle, GWL_STYLE);
if AShow then begin
if (style and WS_CAPTION) = WS_CAPTION then exit;
case BorderStyle of
bsSingle, bsSizeable:
SetWindowLong(Handle, GWL_STYLE, style or WS_CAPTION or WS_BORDER);
bsDialog:
SetWindowLong(Handle, GWL_STYLE, style or WS_CAPTION or DS_MODALFRAME or
WS_DLGFRAME);
end;
end else begin
if (style and WS_CAPTION) = 0 then exit;
case BorderStyle of
bsSingle, bsSizeable:
SetWindowLong(Handle, GWL_STYLE, style and (not(WS_CAPTION)) or WS_BORDER)
;
bsDialog:
SetWindowLong(Handle, GWL_STYLE, style and (not(WS_CAPTION)) or
DS_MODALFRAME or WS_DLGFRAME);
end;
end;
SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_NOZORDER
or SWP_FRAMECHANGED or SWP_NOSENDCHANGING);
end;
end;

Check whether a mouse button is being pressed

...
uses
Windows;
...
function IsBtnPressed(ABtn: integer): boolean;
//ABtn can be either VK_LBUTTON, VK_MBUTTON, or VK_RBUTTON
begin
result := (GetAsyncKeyState(ABtn) and $8000) = $8000;
end

Drawing rotated text

uses
Windows, Graphics;
...
procedure AngleTextOut(ACanvas: TCanvas; Angle, X, Y: integer; AStr: string);
var
LogFont: TLogFont;
hOldFont, hNewFont: HFONT;
begin
GetObject(ACanvas.Font.Handle, SizeOf(LogFont), Addr(LogFont));
LogFont.lfEscapement := Angle * 10;
LogFont.lfOrientation := Angle * 10;
hNewFont := CreateFontIndirect(LogFont);
hOldFont := SelectObject(ACanvas.Handle, hNewFont);
ACanvas.TextOut(X, Y, AStr);
hNewFont := SelectObject(ACanvas.Handle, hOldFont);
DeleteObject(hNewFont);
end;

Open a file using its associated application

The result is the same as if the file were double-clicked in Windows Explorer.


FUNCTION OpenFile(AFile: STRING; ADir: STRING = NIL; AParams: STRING = NIL):
   boolean;
BEGIN
   result := ShellExecute(Application.Handle, ’open’, PChar(AFile), ADir, AParams,
      SW_SHOWNORMAL) >= 32;
END;

Disable (gray out) Close button of a form

procedure TForm1.FormCreate(Sender: TObject);

var

hSysMenu: HMENU;

begin

hSysMenu := GetSystemMenu(Handle, false);

EnableMenuItem(hSysMenu, SC_CLOSE, MF_BYCOMMAND or MF_GRAYED);

end;

Get a list of system fonts

procedure TForm1.FormCreate(Sender: TObject);
begin
ComboBox1.Items.Assign(Screen.Fonts);
end;

Send a file to Recycle bin

uses
ShellApi.pas;
...



FUNCTION RecycleFile(CONST AFile: STRING): boolean;
VAR
   foStruct: TSHFileOpStruct;
BEGIN
   WITH foStruct DO BEGIN
      wnd := 0;
      wFunc := FO_DELETE;
      pFrom := PChar(AFile + #0#0);
      pTo := NIL;
      fFlags := FOF_ALLOWUNDO OR FOF_NOCONFIRMATION OR FOF_SILENT;
      fAnyOperationsAborted := false;
      hNameMappings := NIL;
   END;
   Result := SHFileOperation(foStruct) = 0;
END;

Set a form to stay on top of all other (non-topmost) windows

...
uses
Forms, Windows;
...
procedure SetTopmost(AForm: TForm; ATop: boolean);
begin

if ATop then
SetWindowPos(AForm.Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE)
else
SetWindowPos(AForm.Handle, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
SWP_NOSIZE);
end

Capture Maximize/Minimize/Close button clicks

...

type

TForm1 = class(Form)

...

public

procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;

...

procedure TForm1.WMSysCommand(var Msg: TWMSysCommand);

begin

if Msg.CmdType = SC_MINIMIZE) or (Msg.CmdType = SC_MAXIMIZE) or (Msg.CmdType =

SC_CLOSE) then

...

else

DefaultHandler(Msg);

end;

Make transparent form

uses
Windows, Forms, Classes, Controls, ComCtrls;
type
TForm1 = class(TForm)
TrackBar1: TTrackBar;
procedure TrackBar1Change(Sender: TObject);
end;
...
procedure SetTransparent(hWnd: longint; value: Byte);
// opaque: value=255; fully transparent: value=0
var
iExStyle: Integer;
begin
iExStyle := GetWindowLong(hWnd, GWL_EXSTYLE);
if value < 255 then begin
iExStyle := iExStyle Or WS_EX_LAYERED;
SetWindowLong(hWnd, GWL_EXSTYLE, iExStyle);
SetLayeredWindowAttributes(hWnd, 0, value, LWA_ALPHA);
end else begin
iExStyle := iExStyle xor WS_EX_LAYERED;
SetWindowLong(hWnd, GWL_EXSTYLE, iExStyle);
end;
end;
procedure TForm1.TrackBar1Change(Sender: TObject);
begin
SetTransparent(Handle, TrackBar1.Position);
end;

Find if you are connected to the Internet

uses IWinInet;
...
procedure CheckConnection;
var
dwFlags: DWORD;
begin
if InternetGetConnectedState(@dwFlags, 0) then begin
if (dwFlags and INTERNET_CONNECTION_MODEM)=INTERNET_CONNECTION_MODEM then
ShowMessage(’Connected through modem’)
else if (dwFlags and INTERNET_CONNECTION_LAN) = INTERNET_CONNECTION_LAN then
ShowMessage(’Connected through LAN’)
else if (dwFlags and INTERNET_CONNECTION_PROXY) = INTERNET_CONNECTION_PROXY
then
ShowMessage(’Connected through Proxy’)
else if (dwFlags and INTERNET_CONNECTION_MODEM_BUSY) =
INTERNET_CONNECTION_MODEM_BUSY then
ShowMessage(’Modem is busy’);
end else
ShowMessage(’Offline’);
end;

Drawing transparent text

The backround of the text drawn onto a canvas is filled with the current brush.
Canvas.Brush.Style := bsClear;
Canvas.TextOut(100,100,’Hello World’);

Capture mouse clicks at statusbar

uses
Windows, Messages, Forms, Classes, SysUtils, Controls, ComCtrls, Commctrl;
type
TForm1 = class(TForm)
StatusBar1: TStatusBar;
procedure FormCreate(Sender: TObject);
private
procedure WMNotify(var AMsg: TWMNotify); message WM_NOTIFY;
end;
...
procedure TForm1.FormCreate(Sender: TObject);
var
i: integer;
begin
for i := 0 to 3 do
with StatusBar1.Panels.Add do begin
Width := 100;
Text := Format(’Panel %d’,[i]);
end;
end;
procedure TForm1.WMNotify(var AMsg: TWMNotify);
var
pNMM: PNMMouse;
ctrl: TWinControl;
hWindow: HWND;
iPanel: integer;
begin
inherited;
pNMM := PNMMouse(AMsg.NMHdr);
hWindow := pNMM^.hdr.hwndFrom;
ctrl := FindControl(hWindow);
iPanel := pNMM^.dwItemSpec;
case pNMM^.hdr.code of
NM_CLICK:
Caption := Format(’%s was clicked at panel %d’,[ctrl.Name,iPanel]);
NM_DBLCLK:
Caption := Format(’%s was doubleclicked
at panel %d’,[ctrl.Name,iPanel]);
NM_RCLICK:
Caption := Format(’%s was rightclicked
at panel %d’,[ctrl.Name,iPanel]);
NM_RDBLCLK:
Caption := Format(’%s was rightdoubleclicked
at panel %d’,[ctrl.Name,
iPanel]);
end;
end;

Retrive the path of the Windows directory

uses
Windows, StrUtils;
...
function GetWinDir: string;
var
buffer: array[0..MAX_PATH] of char;;
begin
GetWindowsDirectory(buffer, MAX_PATH);
result := string(buffer);
if RightStr(

Repositioning common dialogs

procedure TForm1.OpenDialog1Show(Sender: TObject);
var
hwnd: THandle;
rect: TRect;
dlgWidth, dlgHeight: integer;
begin
hwnd := GetParent(OpenDialog1.Handle);
GetWindowRect(hwnd, rect);
dlgWidth := rect.Rightrect.
Left;
dlgHeight := rect.Bottomrect.
Top;
MoveWindow(hwnd, Left+(WidthdlgWidth)
div 2, Top+(HeightdlgHeight)
div 2,
dlgWidth, dlgHeight, true);
Abort;
end;

Disabling the movement of a form

uses
Windows, Forms;
type
TForm1 = class(TForm)
public
procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;
end;
...
procedure TForm1.WMNCHitTest(var Msg: TWMNCHitTest);
begin
inherited;
with Msg do
if

Detect the movement of a form

uses
Windows, Forms;
type
TForm1 = class(TForm)
Edit1: TEdit;
Edit2: TEdit;
public
procedure WMMove(var Msg: TWMMove); message WM_MOVE;
end;
...
procedure TForm1.WMMove(var Msg: TWMMove);
begin
Edit1.Text := IntToStr(Left);
Edit2.Text := IntToStr(Top);
end;

Monitor the changes of clipboard’s content



USES
   Windows, Forms, Clipbrd;
TYPE
   TForm1 = CLASS(TForm)
      Image1: TImage;
      PROCEDURE FormCreate(Sender: TObject);
   PUBLIC
      PROCEDURE WMDrawClipboard(VAR Msg: TWMDrawClipBoard); MESSAGE WM_DRAWCLIPBOARD
         ;
   END;



PROCEDURE TForm1.FormCreate(Sender: TObject);
BEGIN
   SetClipboardViewer(Handle);
END;

PROCEDURE TForm1.WMDrawClipboard(VAR Msg: TWMDrawClipBoard);
BEGIN
   IF Clipboard.HasFormat(CF_BITMAP) THEN
      Image1.Picture.Assign(Clipboard);
END;

Converting between decimal, binary, and hexadecimal representation



USES
   StrUtils, SysUtils;

FUNCTION DecToBin(N: int64): STRING;
VAR
   i: integer;
   neg: boolean;
BEGIN
   IF N = 0 THEN BEGIN
      result := ’0’;
      exit
   END;
   SetLength(result, SizeOf(N) * 8);
   neg := N < 0;
   9
      N := Abs(N);
   i := 1;
   WHILE N <> 0 DO BEGIN
      IF N AND 1 = 1 THEN
         result[i] := ’1’
      ELSE
         result[i] := ’0’;
      N := N SHR 1;
      Inc(i);
   END;
   IF neg THEN BEGIN
      result[i] := ’’;
      Inc(i);
   END;
   Delete(result, i, length(result));
   result := ReverseString(result);
END;

FUNCTION DecToHex(N: int64): STRING;
BEGIN
   IF N < 0 THEN
      result := ’’
         + Format(’%0x’, [Abs(N)])
   ELSE
      result := Format(’%0x’, [N]);
END;

How to format a disk

const
SHFMT_DRV_A = 0;
SHFMT_DRV_B = 1;
SHFMT_ID_DEFAULT = $FFFF;
SHFMT_OPT_QUICKFORMAT = 0;
SHFMT_OPT_FULLFORMAT = 1;
SHFMT_OPT_SYSONLY = 2;
SHFMT_ERROR = -1;
SHFMT_CANCEL = -2;
SHFMT_NOFORMAT = -3;

function SHFormatDrive(hWnd: HWND;
Drive: Word;
fmtID: Word;
Options: Word): Longint
stdcall; external 'Shell32.dll' Name 'SHFormatDrive';

procedure TForm1.Button1Click(Sender: TObject);
var
FmtRes: Longint;
begin
try
FmtRes := ShFormatDrive(Handle,
SHFMT_DRV_A,
SHFMT_ID_DEFAULT,
SHFMT_OPT_QUICKFORMAT);
case FmtRes of
SHFMT_ERROR: ShowMessage('Error formatting the drive');
SHFMT_CANCEL: ShowMessage('User canceled formatting the drive');
SHFMT_NOFORMAT: ShowMessage('No Format')
else
ShowMessage('Disk has been formatted!');
end;
except
ShowMessage('Error Occured!');
end;
end;
{
Normally, if a diskette is not in the drive when SHFormatDrive is called,
the system displays a critical error dialog box that asks the user
to Abort, Retry, or Ignore.
You can prevent the system from displaying this dialog box by calling
the SetErrorMode API with SEM_FAILCRITICALERRORS.
}
var
EMode: Word;
begin
EMode := SetErrorMode(SEM_FAILCRITICALERRORS);
SetErrorMode(EMode);
end;

How do I make a splash screen for my application?

First make a new form, this will be your SpashSreen.

Set Name to "Splash".
Set BorderStyle to "bsNone".
Put an image or whatever on it.
Make sure it is not auto-created. (Shift-Ctrl-F11)

Now edit your main program body:

program MyApp;
{... }
begin
Application.Initialize;
{ ---------- PUT THIS IN: ------------- }
Splash := TSplash.Create(Application);
Splash.Show;
Splash.Refresh;
{ ------------------------------------- }
..
Application.CreateForm(...);
Application.Run;
end;

Now edit the OnShow event of your main form:

procedure TMainForm.FormShow(Sender: TObject);
begin

{...}

{ Free Splash screen }
Splash.Free;
end;

You now have a splash screen!
Tip: If you place the Spash.Free in a OnTimer event, you can control how long the user sees your splash screen.

How to delete Temporary Internet files.

uses
WinInet;
procedure DeleteIECache;
var
lpEntryInfo: PInternetCacheEntryInfo;
hCacheDir: LongWord;
dwEntrySize: LongWord;
begin
dwEntrySize := 0;
FindFirstUrlCacheEntry(nil, TInternetCacheEntryInfo(nil^), dwEntrySize);
GetMem(lpEntryInfo, dwEntrySize);
if dwEntrySize > 0 then
lpEntryInfo^.dwStructSize := dwEntrySize;
hCacheDir := FindFirstUrlCacheEntry(nil, lpEntryInfo^, dwEntrySize);
if hCacheDir <> 0 then
begin
repeat
DeleteUrlCacheEntry(lpEntryInfo^.lpszSourceUrlName);
FreeMem(lpEntryInfo, dwEntrySize);
dwEntrySize := 0;
FindNextUrlCacheEntry(hCacheDir, TInternetCacheEntryInfo(nil^), dwEntrySize);
GetMem(lpEntryInfo, dwEntrySize);
if dwEntrySize > 0 then
lpEntryInfo^.dwStructSize := dwEntrySize;
until not FindNextUrlCacheEntry(hCacheDir, lpEntryInfo^, dwEntrySize);
end;
FreeMem(lpEntryInfo, dwEntrySize);
FindCloseUrlCache(hCacheDir);
end;

Example:

procedure TForm1.Button1Click(Sender: TObject);
begin
DeleteIECache;
end;

Detect your own IP Address

uses
WinSock; // type PHostEnt
function My_IP_Address: longint;
var
buf: array[0..255] of char;
RemoteHost: PHostEnt;
begin
Winsock.GetHostName(@buf, 255);
RemoteHost := Winsock.GetHostByName(buf);
if RemoteHost = nil then
My_IP_Address := winsock.htonl($07000001) { 127.0.0.1 }
else
My_IP_Address := longint(pointer(RemoteHost^.h_addr_list^)^);
Result := Winsock.ntohl(Result);
end;

Detect an HTTP proxy

If you write a core http client, e.g. from socket level, you may need to detect whether there is an http proxy used. This includes the name of the proxy server and the port number it operates on. Such proxy servers are often used where a firewall is installed.
Luckily IE is installed on many Windows systems, and IE puts this information in the registry under

\Software\Microsoft\Windows\CurrentVersion\Internet Settings

The following procedure GetProxy retrieves the host name, port number and whether the proxy is enabled. You can use it as shown in the FormCreate() event handler.
Note: The value ProxyEnable should be a DWord, but sometimes it may be stored as binary or as a string, depending on the version of IE that the user has installed. The code below evaluates the type and reads it appropriately.

unit fProxy;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Registry;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
function GetProxy(var Host: string; var Port: integer; var ProxyEnabled: boolean): boolean;
var
s: string;
p: integer;
begin
with TRegistry.Create do
begin
RootKey := HKEY_CURRENT_USER;
ProxyEnabled := false;
s := '';
OpenKey('\Software\Microsoft\Windows\CurrentVersion\Internet Settings', True);
if ValueExists('ProxyServer') then
s := ReadString('ProxyServer');
if s <> '' then
begin
p := pos(':', s);
if p = 0 then
p := length(s) + 1;
Host := copy(s, 1, p - 1);
try
Port := StrToInt(copy(s, p + 1, 999));
except
Port := 80;
end;
ProxyEnabled := true;
end;
if ValueExists('ProxyEnable') then
begin
case GetDataType(sProxyEnable) of
rdString,
rdExpandString:
begin
sPortTmp := AnsiLowerCase(ReadString(sProxyEnable));
ProxyEnabled := true;
if pos(' ' + sPortTmp + ' ', ' yes true t enabled 1 ') > 0 then
ProxyEnabled := true
else if pos(' ' + sPortTmp + ' ', ' no false f none disabled 0 ') > 0 then
ProxyEnabled := false
end;
rdInteger:
begin
ProxyEnabled := ReadBool(sProxyEnable);
end;
rdBinary:
begin
ProxyEnabled := true;
ReadBinaryData(sProxyEnable, ProxyEnabled, 1);
end;
end;
end;
Free;
end;
Result := s <> '';
end;
procedure TForm1.FormCreate(Sender: TObject);
var
Host: string;
Port: integer;
ProxyEnabled: boolean;
const
YesNo: array[false..true] of string = (' not ', '');
begin
// get proxy information
if GetProxy(Host, Port, ProxyEnabled) then
ShowMessage(Format('Your proxy is %s on port %d, it is%s enabled.', [Host, Port, YesNo[ProxyEnabled]]))
else
ShowMessage('No proxy detected');
end;
end.

Author: Tomas Rutkauskas
Product: Delphi 7.x (or higher)

Get the keyboard input language

When my application starts, I need to switch the keyboard language to Greek. Currently I use the statement ActivateKeyboardlayout(0, 0). When I need to switch to English (when the application terminates) I execute the same statement one more time. This works fine, but only if the language before the application's execution is English. So, before the call of the statement, I need to know if the language is Greek or English. How can do this?

I usually use the following cycle:
{ ... }
GetKeyboardLayoutName(@t);
y := string(t);
repeat
ActivateKeyboardLayout(HKL_NEXT, 0);
GetKeyboardLayoutName(@t);
x := string(t);
until
((x = y) or (x = '00000405'));

{ ... }
Using this, the English keyboard will give the KeyboardLayoutName '00000409' and the Greek one the '000000408'. These are standard language identifiers. They're the same on any Windows machine.
To display the information, you could use this little trick:
{ ... }
var
kbd: array[0..2] of Char;
begin
GetLocaleInfo(loWord(GetKeyboardLayout(0)), LOCALE_SENGLANGUAGE, kbd, 2);
Form1.Caption := kbd;
{ ... }

Author: Lou Adler
Product: Delphi 7.x (or higher)

Determine ADO and DAO Versions installed

Function to determine the highest version of DAO installed on the machine. If no DAO is installed then 0.0 is returned. Typical return values are 3.5 or 3.6 for DAO v3.5 and v3.6.
Function to return the current version of ADO installed. A typical return value is 2.7. If ADO is not available then 0.0 is retuened.

Both functions also support a String result function as well.
function GetDaoVersion: double;
function GetDaoVersionStr: string;
function GetAdoVersion: double;
function GetAdoVersionStr: string;

// Add to uses clause
uses Math, ComObj;
// ======================================
// Get Highest DAO ver installed
// ======================================
function GetDaoVersion: double;
var
sPath: string;
iError, iResult: integer;
rDirInfo: TSearchRec;
begin
iResult := 0;
sPath := ExtractFileDrive(WindowsDir) +
'\Program Files\Common Files\' +
'Microsoft Shared\DAO\dao*.dll';
// Loop thru to find the MAX DLL version on disk
iError := FindFirst(sPath, faAnyFile, rDirInfo);
while iError = 0 do
begin
iResult := Max(iResult, StrToIntDef(copy(rDirInfo.Name, 4, 3), 0));
iError := FindNext(rDirInfo);
if iError <> 0 then
FindClose(rDirInfo);
end;
Result := (iResult / 100.0);
end;
function GetDaoVersionStr: string;
begin
Result := FormatFloat('##0.00', GetDaoVersion);
end;
// =====================
// Get ADO Version
// =====================
function GetAdoVersion: double;
var
oADO: OLEVariant;
begin
try
oADO := CreateOLEObject('adodb.connection');
Result := StrToFloat(oADO.Version);
oADO := Unassigned;
except
Result := 0.0;
end;
end;
function GetAdoVersionStr: string;
begin
Result := FormatFloat('##0.00', GetAdoVersion);
end;

Author: Mike Heydon
Product: Delphi 5.x (or higher)

How to create a non-rectangular TShape that accepts mouse clicks only in the shape's region itself

This will show you how to do a TShape that has mouse clicks only in the shape itself and not it's surrounding box.

unit NoMouseShape;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls;
type
TNoMouseShape = class(TShape)
private
{ Private declarations }
protected
{ Protected declarations }
procedure CMHitTest(var Message: TCMHitTest); message CM_HITTEST;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
published
{ Published declarations }
function ValidPoint(pt: TPoint): Boolean;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('EXS', [TNoMouseShape]);
end;
constructor TNoMouseShape.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Shape := stCircle;
end;
function TNoMouseShape.ValidPoint(pt: TPoint): Boolean;
var
i, j: Integer;
begin
Result := False;
for i := 0 to Width do
for j := 0 to Height do
if (Self.Canvas.Pixels[pt.x, pt.y] = clWhite) or (Self.Canvas.Pixels[pt.x, pt.y] = clBlack) then
Result := True;
end;
procedure TNoMouseShape.CMHitTest(var Message: TCMHitTest);
begin
if ValidPoint(SmallPointToPoint(Message.Pos)) then
Message.Result := HTCLIENT {Handle the message}
else
Message.Result := HTNOWHERE; {pass on to parent}
end;
end.

Now, if you want a real non-rectangular area, using SetWindowRgn would be the way to go. You do not have to derive from TWinControl, drive it from TCustomControl as TCustomControl provides a canvas and handles paint messages. Then you will need to re-write the ValidPoint function to use the PtInRegion API function.

Encrypting an image

How can I encrypt an image?

procedure EncryptBMP(const BMP: TBitmap; Key: Integer);
var
BytesPorScan: Integer;
w, h: integer;
p: pByteArray;
begin
try
BytesPorScan := Abs(Integer(BMP.ScanLine[1]) -
Integer(BMP.ScanLine[0]));
except
raise Exception.Create('Error');
end;
RandSeed := Key;
for h := 0 to BMP.Height - 1 do
begin
P := BMP.ScanLine[h];
for w := 0 to BytesPorScan - 1 do
P^[w] := P^[w] xor Random(256);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
EncryptBMP(Image1.Picture.Bitmap, 623);
Image1.Refresh;
end;

Call the function again to decrypt it

Determine the processor speed in MHz

Here is a handy routine which will return an estimated core processor speed (CPU speed) of your PC. Read the comment to see how to use it.

function GetCpuSpeed: Comp;

{ function to return the CPU clock speed only. }

{ Usage: MessageDlg(Format('%.1f MHz', [GetCpuSpeed]), mtConfirmation, [mbOk], 0); }

var

t: DWORD;

mhi, mlo, nhi, nlo: DWORD;

t0, t1, chi, clo, shr32: Comp;

begin

shr32 := 65536;

shr32 := shr32 * 65536;

t := GetTickCount;

while t = GetTickCount do

begin

end;

asm

DB 0FH

DB 031H

mov mhi,edx

mov mlo,eax

end;

while GetTickCount < (t + 1000) do

begin

end;

asm

DB 0FH

DB 031H

mov nhi,edx

mov nlo,eax

end;

chi := mhi;

if mhi < 0 then

chi := chi + shr32;

clo := mlo;

if mlo < 0 then

clo := clo + shr32;

t0 := chi * shr32 + clo;

chi := nhi;

if nhi < 0 then

chi := chi + shr32;

clo := nlo;

if nlo < 0 then

clo := clo + shr32;

t1 := chi * shr32 + clo;

Result := (t1 - t0) / 1E6;

end;

Get notified: CD in/out

Need to know when the user inserts/extracts a CD?

There's a message you can intercept to know this: WM_DEVICECHANGE
so... the rest is easy on the private section of your form, declare the function:

Private
{ Private declarations }
procedure WMDeviceChange(var Msg: TMessage); message WM_DEVICECHANGE;
the implement it:
procedure TForm1.WMDeviceChange(var Msg: TMessage);
const
CD_IN = $8000;
CD_OUT = $8004;
begin
inherited;
case Msg.wParam of
CD_IN: ShowMessage('CD in'); //or do whatever you want!!
CD_OUT: ShowMessage('CD out')
end
end;

that's it... you'll receive a message when you put a CD in/out... try it then just instead of showing 'CD in'/'CD out'... do whatever you want

Callback function with a DLL

How to make a DLL like a controller and how to write a callback-function with a DLL

First a brief definition: A callback function is a function which you write, but is called by some other program or module, such as windows or DLL's.

For example a DLL (like a watchdog) controls many clients, so when a certain event occurs from the DLL that you called once, the callback function in the client is called (being passed any parameters or signals you need) and when the DLL-callback has completed, control is passed back to the controller-DLL or the client.

By the way, there is almost no possibilitie to make it more OO-like with a class, cause a callback is always an address of a standard procedure or function.

So the reason for this is that windows does not pass back any reference to SELF (means the instance of the class), which is used by classes when deciding which method from the instance to work with.

Let's get back to the framework and create a callback function, you must first:

1) declare a function type

2) the function itself

3) define the DLL reference

4) then implement the function in the client

5) and call the DLL:

Callback example in client unit

1.

interface...

TCallBackFunction = function(sig: integer): boolean;

2.

function callME(sig: integer): boolean;

3.

implement...

procedure TestCallBack(myCBFunction: TCallBackFunction); register;

external('watchcom.dll');

4.

function callMe(sig: integer): boolean;

begin

{whatever you need to do, case of...}

showmessage('I was called with' + inttostr(sig));

end;

5.

procedure TForm1.Button1Click(sender: TObject);

begin

testCallBack(callMe); //subscribe function in DLL

end;

CALLBACK IN THE DLL

In the DLL you would also declare a function type and a procedure (or function) itself, so use it like this:

type

TCallBackFunction = function(sig: integer): boolean;

procedure TestCallBack(clientFunc: TCallBackFunction);

var

sigAlive: boolean;

begin

{timer stuff...

set the signal...}

if (clientFunc(55)) then

sigalive := true;

end;

exports TestCallBack;

Simple Sequence DiagramClient DLL

¦ TestCallBack(clientFunc) ¦

¦---------------------------------------------->¦

¦ clientFunc.callMe(sig) ¦

¦<---------------------------------------------- or="" return="" something="" to="" true="">¦