TIPS
How to draw background image in a MDI master form.....
How to Launch External EXE's.....
Get Computer name.....
Get connected user.....
How to capture output of a DOS application...
How to send PCL escape code in Quick Report....
How to save/load object properties to/from registry....
=========================================================================
How to draw background image in a MDI master form..... Top
Add this code to your form definition
private
OldWndProc: TFarProc;
NewWndProc: Pointer;
PROCEDURE ClientWndProc(VAR Message: TMessage);
Add this code to your form create method
procedure TForm1.FormCreate(Sender: TObject);
begin
...
NewWndProc := MakeObjectInstance(ClientWndProc);
OldWndProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(NewWndProc));
...
end;
Drop a Timage Component on your form, assign a picture to it, then add this method
PROCEDURE TForm1.ClientWndProc(VAR Message: TMessage);
VAR
MyDC : hDC;
W, H : Word;
begin
with Message do
case Msg of
WM_ERASEBKGND:
begin
MyDC := TWMEraseBkGnd(Message).DC;
H := (ClientHeight -Image1.Picture.Height ) div 2;
W := (clientWidth -Image1.Picture.Width ) div 2;
Canvas.Brush.Color:=clBtnFace;
FillRgn(mydc,CreateRECTrgn(0,0,clientWidth,ClientHeight),Canvas.Brush.Handle);
BitBlt(MyDC, W,H,
Image1.Picture.Width, Image1.Picture.Height,
Image1.Picture.Bitmap.Canvas.Handle, 0, 0, SRCCOPY);
Result := 1;
end
else
Result := CallWindowProc(OldWndProc, ClientHandle, Msg, wParam, lParam);
end;
end;
The image will be drawn on center of the MDI master form;
How to Launch External EXE's..... Top
This function permit to launch an external Exe and eventually wait for termination
Function LaunchExtEXE(Pgm:string;Params:string;Wait:Boolean): Cardinal;
var
t:pchar;
st:_STARTUPINFOa;
pi:_PROCESS_INFORMATION;
res:Boolean;
begin
zeromemory(@st,sizeof(st));
t:=pchar(pgm+' '+parametri);
res:=CreateProcess(
nil, // pointer to name of executable module
t, // pointer to command line string
nil, // pointer to process security attributes
nil, // pointer to thread security attributes
true, // handle inheritance flag
0, // creation flags
nil, // pointer to new environment block
nil, // pointer to current directory name
st, // pointer to STARTUPINFO
pi // pointer to PROCESS_INFORMATION
);
If not Res then
begin
Result:=GetLastError;
showmessage('ERR "'+inttostr(result)+'" -> '+t);
end
else
Result:=0;
if Wait then
begin
WaitforSingleObject(PI.hProcess,INFINITE);
GetExitCodeProcess(Pi.hProcess,Result);
CloseHandle( Pi.hProcess);
CloseHandle( Pi.hThread);
end;
end;
Get Computer name..... Top
function GetCompName: string;
var
buf: array[ 0 .. 31 ] of char;
i: Cardinal;
begin
i := 31;
GetComputerName( @buf, i );
Result := buf;
end;
Get connected user..... Top
function GetNetUser: string;
var
buf: array[ 0 .. 31 ] of char;
i: Cardinal;
begin
i := 31;
GetUserName( @buf, i );
Result := buf;
end;
How to capture output of a DOS application.... Top
This function run a CommandLine App (like DOS app) and return the output of the program as a String
Function RunDosApp(Pgm:string;Parms:string;Wait:Boolean): String;
var
t:pchar;
st:_STARTUPINFOa;
pi:_PROCESS_INFORMATION;
res:Boolean;
sec:_SECURITY_ATTRIBUTES;
ReadHandle,WriteHandle:Cardinal;
Read:Cardinal;
Buffer:array[0..8191] of char;
begin
t:=pchar(pgm+' '+Parms);
sec.nLength:=SIZEOF(sec);
sec.lpSecurityDescriptor:=Nil;
sec.bInheritHandle:=true;
CreatePipe(ReadHandle,WriteHandle,@sec,8192);
FillChar(St, SizeOf(St), #0);
St.cb := SizeOf(St);
St.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
St.wShowWindow := SW_HIDE;
St.hStdOutput := WriteHandle;
res:=CreateProcess(
nil, // pointer to name of executable module
t, // pointer to command line string
nil, // pointer to process security attributes
nil, // pointer to thread security attributes
true, // handle inheritance flag
0, // creation flags
nil, // pointer to new environment block
nil, // pointer to current directory name
st, // pointer to STARTUPINFO
pi // pointer to PROCESS_INFORMATION
);
If not Res then
begin
Result:='ERR "'+Inttostr(GetLastError)+'" -> '+t;
exit;
end;
if Wait then
begin
WaitforSingleObject(PI.hProcess,INFINITE);
GetExitCodeProcess(Pi.hProcess,Read);
CloseHandle( Pi.hProcess);
CloseHandle( Pi.hThread);
end;
ReadFile(ReadHandle,Buffer,8192,read,nil);
result:=StrPas(Buffer);
end;
How to send PCL escape code in Quick Report.... Top
This function send PCL codes to the printer in Quick Report. Good place to put call in is in the StartPage event
procedure SendPclCode(Report:TCustomQuickRep;ToSend:String);
type
TPrnBuffRec = Record
BuffLength: Word;
Buffer: Array[0..255] Of Char;
End;
var
Buff : TPrnBuffRec;
function CheckPrinter : boolean;
var
TestInt: integer;
begin
{ Test to see if the "PASSTHROUGH" escape is supported }
TestInt := PASSTHROUGH;
Result:=Escape(Report.QRPrinter.Canvas.Handle, QUERYESCSUPPORT,sizeof(TestInt), @TestInt, Nil) > 0);
end;
begin
{If Api is unsupported, then exit}
if not CheckPrinter then Exit;
StrPCopy(Buff.Buffer,#27+ToSend);
{ Set the buffer length }
Buff.BuffLength := StrLen(Buff.Buffer);
{ Make the escape}
Escape(Report.QRPrinter.Canvas.Handle,
PASSTHROUGH,
0,
@Buff,
Nil);
end;
How to save/load object properties to/from registry.... Top
This two procedure permit to save object properties to the registry and then reload it.
First add this to your source code:
....
uses typinfo;
....
Procedure SaveObj(BaseName:String;Obj:TPersistent;Reg:Tregistry);
Var i:integer;
plist:PPropList;
j:integer;
Begin
j:=GetPropList(Obj,plist);
for i:=0 to j -1 Do
Reg.WriteString(BaseName+'.'+plist^[i].Name,Vartostr(GetPropValue(obj,plist^[i].Name)));
End;
Procedure LoadObj(BaseName:String;Obj:TPersistent;Reg:Tregistry);
Var i:integer;
plist:PPropList;
v:variant;
j:integer;
Begin
j:=GetPropList(obj,plist);
for i:=0 to j -1 Do
Begin
Try
v:=Reg.ReadString(BaseName+'.'+plist^[i].Name);
SetPropValue(Obj,plist^[i].Name,v);
Except
End;
End;
End;
Then you can call function as :
Procedure TMyForm.SaveParms;
Var
Reg: TRegistry;
Begin
Reg := TRegistry.Create;
Try
Reg.RootKey := HKEY_LOCAL_MACHINE;
If Reg.OpenKey('\Software\Myprogram', True) Then
Begin
SaveObj('MyFont',MyComponent.Font,reg);
End;
Finally
Reg.Free;
End;
End;
Procedure TMyForm.RetrieveParms;
Var
Reg: TRegistry;
Begin
Reg := TRegistry.Create;
Try
Reg.RootKey := HKEY_LOCAL_MACHINE;
If Reg.OpenKey('\Software\Myprogram', True) Then
Begin
LoadObj('MyFont',MyComponent.Font,reg);
End;
Finally
Reg.Free;
End;
End;