Delphi

Contents

Creating an Exit button

Creating gradient fill of form background

Registring file types using Windows Registry

Create your own Unrar using unrar.dll

Unicode components in Delphi

Using the Media Player ActiveX control for playing video

Creating an Exit button

 Use this caption for your button: E&xit 
// The letter after & will be a shortcut (and underlined)
The code for exiting af Delphi program is: Close

Creating gradient fill of form background

 procedure TForm1.GradientForm (frm : TForm; startcolor, endcolor : TColor);
// Horizontal gradient fill of form background
var
startr : integer;
startg : integer;
startb : integer;
endr  : integer;
endg  : integer;
endb  : integer;
curr  : integer;
curg  : integer;
curb  : integer;
i   : integer;
r   : TRect;
nolines: byte;
curpct : integer;
bitspix: longint; // bits per pixel
begin
// Convert TColor to RGB
startr := startcolor and $000000FF;
startg := (startcolor and $0000FF00) div 256;
startb := (startcolor and $00FF0000) div 256 div 256;
endr := endcolor and $000000FF;
endg := (endcolor and $0000FF00) div 256;
endb := (endcolor and $00FF0000) div 256 div 256;
// Calc no of rectangles (lines) with different colors
if frm.Height < 250 then
nolines:=frm.Height
else
nolines:=250; // max 250 different rectangles (no more needed)
bitspix:=GetDeviceCaps(frm.Canvas.Handle, BITSPIXEL); // Get bits per pixel
if (bitspix = 8) and (nolines > 50) then // 256 colors
nolines:=50
else if bitspix < 8 then // less than 256 colors
nolines:=4; // poor guy
r.Left:=0; // Left of rectangle
r.Right:=frm.Width; // Right of rectangle
for i:=0 to nolines do // draw gradient
begin
curpct:= (i * 100) div nolines; // % change (gradient)
// calc red for current rectangle
if startr > endr then
curr := startr - (curpct * (startr-endr) div 100)
else
curr := startr + (curpct * (endr-startr) div 100);
// calc green for current rectangle
if startg > endg then
curg := startg - (curpct * (startg-endg) div 100)
else
curg := startg + (curpct * (endg-startg) div 100);
// calc blue for current rectangle
if startb > endb then
curb := startb - (curpct * (startb-endb) div 100)
else
curb := startb + (curpct * (endb-startb) div 100);
// set draw color for current rectangle
frm.Canvas.Brush.Color:=RGB(curr, curg, curb);
// calc rectangle top/bottom
r.Top:=i + (i*(frm.Height div nolines));
r.Bottom:=r.Top + (frm.Height div nolines)+1;
// draw rectangle on canvas
frm.Canvas.FillRect(r);
end;
end; // GradientForm
procedure TForm1.FormPaint(Sender: TObject);
begin 
// lightblue to black - like installers
GradientForm(Form1,RGB(60,60,210), RGB(1,1,2)); 
end;

Registring file types using Windows Registry

 // Declaration
reg : TRegistry; // defined in unit "Registry"
// .txc
Reg := TRegistry.Create;
Reg.RootKey := HKEY_CLASSES_ROOT;
if Reg.OpenKey('.txc', True) then
begin
ShowMessage('test: ' + Reg.ReadString('.txc'));
Reg.WriteString('','txc_auto_file');
end;
Reg.Destroy;
// txc_auto_file
Reg := TRegistry.Create;
Reg.RootKey := HKEY_CLASSES_ROOT;
if Reg.OpenKey('txc_auto_file\shell\open\command', True) then
begin
Reg.WriteString('','C:\Program Files\TextCrypt\TextCrypt.exe %1');
end;
Reg.Destroy;
// icon
Reg := TRegistry.Create;
Reg.RootKey := HKEY_CLASSES_ROOT;
if Reg.OpenKey('txc_auto_file\DefaultIcon', True) then
begin
Reg.WriteString('','C:\Program Files\TextCrypt\TextCrypt.ico');
end;
Reg.Destroy;

Create your own Unrar using unrar.dll

 Uses
..., Unrar;
...
type
CharMAX_PATH = array [0..MAX_PATH] of char;
var
RAROpenArchiveData: TRAROpenArchiveData;
RARHeaderData: TRARHeaderData;
RARExtract: boolean;
RARComment: CharMAX_PATH;
RARPwd: array [0..80] of char;
RARFileName: CharMAX_PATH;
RarDllLoaded: boolean;
ArchivePwd: string;
InstallCancel: Boolean;
lKBWritten := 0;
...
// Load dll file
RarDllLoaded := UnrarDllLoad('unrar.dll');
...
procedure TfrmUnrar.ExtractRARArchive;
var
sDir: string;
s: string;
RARhnd: THandle;
RARrc: integer;
PDestPath: CharMAX_PATH;
Mode: integer;
begin
RARExtract := True;
Mode := RAR_OM_EXTRACT; // open for extracting
lKBWritten := 0;
frmUnrar.pbTotalProgress.Position := 0;
frmUnrar.pbTotalProgress.Max := lTotalSize;
RARStartTime := Time;
RAROpenArchiveData.OpenResult := 99;
RAROpenArchiveData.OpenMode := Mode;
RAROpenArchiveData.ArcName := @RARFileName;
RAROpenArchiveData.CmtBuf := @RARComment; 
RAROpenArchiveData.CmtBufSize := 255; 
// Open RAR archive and allocate memory structures
RARhnd := RAROpenArchive(RAROpenArchiveData);
if RAROpenArchiveData.OpenResult <> 0 then
begin
case RAROpenArchiveData.OpenResult of
ERAR_NO_MEMORY: s := 'Not enough memory to initialize data structures';
ERAR_BAD_DATA: s := 'Archive header broken';
ERAR_BAD_ARCHIVE: s := 'File is not valid RAR archive';
ERAR_EOPEN: s := 'File open error';
end;
MessageDlg('Unable to open rar archive: ' + s + '!', mtError, [mbOK], 0);
Exit;
end;
if ArchivePwd <> '' then // set pwd if specified
RARSetPassword(RARhnd, @RARPwd);
RARSetCallback(RARhnd, RarCallbackProc, integer(@Mode));
StrPCopy(@PDestPath, a2o(EditInstallPath.Text)); // unrar uses oem
sDir := EditInstallPath.Text;
if sDir[Length(sDir)] <> '\' then
sDir := sDir + '\';
repeat
RARrc := RARReadHeader(RARhnd, RARHeaderData); // Read header
if RARrc <> ERAR_END_ARCHIVE then
begin
frmUnrar.pbCurrentFile.Position := 0;
frmUnrar.pbCurrentFile.Max := RARHeaderData.UnpSize;
s := StrPas(RARHeaderData.FileName);
frmUnrar.lblCurrentFile.Caption := s;
lKBytesDone := 0;
frmUnrar.Refresh;
Application.ProcessMessages; // like DoEvents in VB
end;
if RARrc = 0 then
RARrc := RARProcessFile(RARhnd, RAR_EXTRACT, @PDestPath, nil);
if (RARrc <> 0) and (RARrc <> ERAR_END_ARCHIVE) then
begin
if (RARrc = 12) or (RARrc = 16) then
begin // check if file allready exists and if can be deleted
if FileExists(sDir + s) then
begin
if (FileGetAttr(sDir + s)) and (faReadOnly) = 1 then
begin
MessageDlg('Unable to overwrite ' + sDir + s + '!', mtError, [mbOK], 0);
Exit;
end;
RARrc := RARProcessFile(RARhnd, RAR_EXTRACT, @PDestPath, nil);
end;
end;
if (RARrc = 12) then
begin
MessageDlg('An Error occured during extracting of ' + s + '!' + #13#10 +
'RARProcessFile: ' + IntToStr(RARrc), mtError, [mbOK], 0);
Exit;
end
else
RARrc := 0;
end;
Application.ProcessMessages; // like DoEvents in VB
until RARrc <> 0;
// close RAR archive and free memory
if RARCloseArchive(RARhnd) <> 0 then
MessageDlg('Unable to close rar archive!', mtError, [mbOK], 0);
end; // ExtractRARArchive
////////////////////////////////////////////////////////////////////////
function RarCallbackProc(msg: UINT; UserData, P1, P2: integer): integer; stdcall;
var
s: string;
begin
Result := 0;
case msg of
UCM_CHANGEVOLUME:
if (P2 = RAR_VOL_ASK) then
begin
end;
UCM_PROCESSDATA:
begin
if RARExtract then
begin
lKBytesDone := lKBytesDone + P2; // bytes written so far
// Current file progress
frmUnrar.pbCurrentFile.Position := frmUnrar.pbCurrentFile.Position + P2;
frmUnrar.lblBytes.Caption := Bytes2String(lKBytesDone) +
' kb of ' + Bytes2String(RARHeaderData.UnpSize) + ' kb';
// Total progress
lKBWritten := lKBWritten + (P2 div 1024);
frmUnrar.pbTotalProgress.Position := lKBWritten;
frmUnrar.lblTotalMB.Caption := Bytes2String(lKBWritten) +
' mb of ' +
Bytes2String(lTotalSize) + ' mb';
frmUnrar.Refresh; // refresh misc status text
Application.ProcessMessages; // like DoEvents in VB
Result := 1;
end
else
Result := 1;
end;
end;
end; // RarCallbackProc

Unicode components in Delphi

 TUnicodeLabel = class(TLabel)
private { Private declarations }
WideText : WideString;  
procedure SetCaption(Value: WideString);
protected { Protected declarations }
procedure DoDrawText(var Rect: TRect; Flags: Longint); override;
public { Public declarations }
published { Published declarations }
property Caption : WideString read WideText write SetCaption;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TUnicodeLabel]);
end;
procedure TUnicodeLabel.DoDrawText(var Rect: TRect; Flags: Longint);
begin
Canvas.Font := Font;
if not Enabled then
begin
Canvas.Font.Color := clBtnHighlight;
ExtTextOutW(Canvas.Handle, 1,1, ETO_CLIPPED, @Rect,
pWideChar(WideText), Length(WideText), nil);
Canvas.Font.Color := clBtnShadow;
end;
ExtTextOutW(Canvas.Handle, 0,0, ETO_CLIPPED, @Rect,
pWideChar(WideText), Length(WideText), nil);
end;
procedure TUnicodeLabel.SetCaption(Value: WideString);
begin
WideText:=Value;
Invalidate; // repaint
end;

Do also check Mike Lischke's cool and improved implementation of a TTreeview:
Virtual Treeview

Using the Media Player ActiveX control for playing video

 ...
public
dTotalFrames: Double;
dTotalTimeSecs: Double;
dFramerate: Double;
...
if OpenDialog1.Execute then
begin
WMP1.FileName := OpenDialog1.FileName;
while WMP1.ReadyState < 3 do
Application.ProcessMessages;
// Get Length in frames
WMP1.DisplayMode := 1; // 1 = Frames
dTotalFrames := WMP1.Duration;
// Get length in seconds
WMP1.DisplayMode := 0 ; // 0 = Time
dTotalTimeSecs := WMP1.Duration;
// Framerate
if dTotalTimeSecs > 0 then
dFramerate := DTotalFrames / dTotalTimeSecs;
WMP1.Play
end;

Related topics