الموضوع: أكواد الدلفي 2

السلام عليكم ورحمة الله تعالى وبركاته

جأتكم بأكواد الدلفي 2 أرجو أن تفيدكم

Printing a Form

The following code prints all visible TLabel, TEdit, TMemo, TDBText, TDBEdit and TDBMemo components on the form with proper place, size and font. Set the Form Scrollbar.Range to 768 Horz and 1008 Vert for a 8 X 10.5 page at 96formPPI.

uses Printers;

procedure TForm1.SpeedButton1Click(Sender: TObject);
var
C : array[0..255] of char;
CLen, ScaleX, ScaleY, I : integer;
Format : Word; DC : HDC;
MComp : TMemo; R: TRect;
begin
Printer.BeginDoc;
DC := Printer.Canvas.Handle;
ScaleX := GetDeviceCaps(DC, LOGPIXELSX) div PixelsPerInch;
ScaleY := GetDeviceCaps(DC, LOGPIXELSY) div PixelsPerInch;
for I := 0 to ComponentCount-1 do
if (Components[I] is TCustomLabel) or (Components[I] is TCustomEdit) then
begin
MComp := TMemo(Components[I]);
if (MComp.visible) then
begin
Printer.Canvas.Font := MComp.Font;
DC := Printer.Canvas.Handle; {so DrawText knows about font}
R := MComp.BoundsRect;
R.Top := (R.Top + VertScrollBar.Position) * ScaleY;
R.Left := (R.Left + HorzScrollBar.Position) * ScaleX;
R.Bottom := (R.Bottom + VertScrollBar.Position) * ScaleY;
R.Right := (R.Right + HorzScrollBar.Position) * ScaleY;
if (not(Components[I] is TCustomLabel)) and (MComp.BorderStyle = bsSingle)
then Printer.Canvas.Rectangle(R.Left,R.Top,R.Right,R.Bo ttom);
Format := DT_LEFT;
if (Components[I] is TEdit) or (Components[I] is TCustomMaskEdit) then
Format := Format or DT_SINGLELINE or DT_VCENTER
else
begin
if MComp.WordWrap then Format := DT_WORDBREAK;
if MComp.Alignment = taCenter then Format := Format or DT_CENTER;
if MComp.Alignment = taRightJustify then Format := Format or DT_RIGHT;
R.Bottom := R.Bottom + Printer.Canvas.Font.Height + 1;
end;
CLen := MComp.GetTextBuf(C,255);
R.Left := R.Left + ScaleX + ScaleX;
DrawText(DC, C, CLen, R, Format);
end;
end;
Printer.EndDoc;
end;
----------------------------------------------------------------------
Detecting the CPU type includes (Pentium)

{ This code comes from Intel, and has been modified for Delphi's inline assembler. }

unit Cpu;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,
Buttons;

type
{ All the types currently known. As new types are created, add suitable names, and extend the
case statement in the GetCpuType function.}

TCPUType = (i8086CPU, i286CPU, i386CPU, i486CPU, iPentiumCPU);

TForm1 = class(TForm)
Edit1: TEdit;
Label1: TLabel;
BitBtn1: TBitBtn;
procedure FormCreate(Sender: TObject);
procedure BitBtn1Click(Sender: TObject);
private
{ Return the type of the current CPU }
function CpuType: TCPUType;
{ Return the type as a string }
function GetCPUType: String;
public
end;

var
Form1: TForm1;

{ Define the winFlags variable for 286 check }
winFlags: Longint;

implementation

{$R *.DFM}

{ Get CPU type }
function TForm1.GetCPUType: String;
var
kind: TCPUType;
begin
if winFlags and WF_CPU286 > 0 then
Result := '80286'
else
begin
kind := CpuType;
case kind of
i8086CPU:
Result := '8086';
i386CPU:
Result := '80386';
i486CPU:
Result := '80486';
iPentiumCPU:
Result := 'Pentium';

else
{ Try to be flexible for future cpu types, e.g., P6. }
Result := Format('P%d', [Ord(kind)]);
end;
end;
end;

{ Assembly function to get CPU type including Pentium and later }
function TForm1.CpuType: TCPUType; assembler;
asm
push DS
{ First check for an 8086 CPU }
{ Bits 12-15 of the FLAGS register are always set on the 8086 processor. }
pushf { save EFLAGS }
pop bx { store EFLAGS in BX }

mov ax,0fffh { clear bits 12-15 }
and ax,bx { in EFLAGS }
push ax { store new EFLAGS value on stack }
popf { replace current EFLAGS value }
pushf { set new EFLAGS }
pop ax { store new EFLAGS in AX }
and ax,0f000h { if bits 12-15 are set, then CPU }
cmp ax,0f000h { is an 8086/8088 }
mov ax, i8086CPU { turn on 8086/8088 flag }

je @@End_CpuType

{ 80286 CPU check }
{ Bits 12-15 of the FLAGS register are always clear on the 80286 processor. }
{ Commented out because 'pop ax' crashes it to the DOS prompt when running }
{ with a Delphi form on some Machines.}
{ or bx,0f000h } { try to set bits 12-15 }
{ push bx }
{ popf }
{ pushf }
{ pop ax } { This crashes Delphi programs on some machines }

{ and ax,0f000h } { if bits 12-15 are cleared, CPU=80286 }
{ mov ax, i286CPU } { turn on 80286 flag }
{ jz @@End_CpuType }

{ To test for 386 or better, we need to use 32 bit instructions,
but the 16-bit Delphi assembler does not recognize the 32 bit opcodes
or operands. Instead, use the 66H operand size prefix to change
each instruction to its 32-bit equivalent. For 32-bit immediate
operands, we also need to store the high word of the operand immediately

following the instruction. The 32-bit instruction is shown in a comment
after the 66H instruction.
}

{ i386 CPU check }
{ The AC bit, bit #18, is a new bit introduced in the EFLAGS }
{ register on the i486 DX CPU to generate alignment faults. }
{ This bit can not be set on the i386 CPU. }

db 66h { pushfd }
pushf
db 66h { pop eax }
pop ax { get original EFLAGS }
db 66h { mov ecx, eax }

mov cx,ax { save original EFLAGS }
db 66h { xor eax,40000h }
xor ax,0h { flip AC bit in EFLAGS }
dw 0004h
db 66h { push eax }
push ax { save for EFLAGS }
db 66h { popfd }
popf { copy to EFLAGS }
db 66h { pushfd }
pushf { push EFLAGS }
db 66h { pop eax }
pop ax { get new EFLAGS value }
db 66h { xor eax,ecx }

xor ax,cx { can't toggle AC bit, CPU=Intel386 }
mov ax, i386CPU { turn on 386 flag }
je @@End_CpuType

{ i486 DX CPU / i487 SX MCP and i486 SX CPU checking }
{ Checking for ability to set/clear ID flag (Bit 21) in EFLAGS }
{ which indicates the presence of a processor }
{ with the ability to use the CPUID instruction. }
db 66h { pushfd }
pushf { push original EFLAGS }
db 66h { pop eax }

pop ax { get original EFLAGS in eax }
db 66h { mov ecx, eax }
mov cx,ax { save original EFLAGS in ecx }
db 66h { xor eax,200000h }
xor ax,0h { flip ID bit in EFLAGS }
dw 0020h
db 66h { push eax }
push ax { save for EFLAGS }
db 66h { popfd }
popf { copy to EFLAGS }
db 66h { pushfd }
pushf { push EFLAGS }

db 66h { pop eax }
pop ax { get new EFLAGS value }
db 66h { xor eax, ecx }
xor ax, cx
mov ax, i486CPU { turn on i486 flag }
je @@End_CpuType { if ID bit cannot be changed, CPU=486 }
{ without CPUID instruction functionality }

{ Execute CPUID instruction to determine vendor, family, }
{ model and stepping. The use of the CPUID instruction used }
{ in this program can be used for B0 and later steppings }

{ of the P5 processor. }
db 66h { mov eax, 1 }
mov ax, 1 { set up for CPUID instruction }
dw 0
db 66h { cpuid }
db 0Fh { Hardcoded opcode for CPUID instruction }
db 0a2h
db 66h { and eax, 0F00H }
and ax, 0F00H { mask everything but family }
dw 0
db 66h { shr eax, 8 }
shr ax, 8 { shift the cpu type down to the low byte }

sub ax, 1 { subtract 1 to map to TCpuType }

@@End_CpuType:
pop ds
end;


{ Get the Windows Flags to check for 286. The 286 assembly code crashes due to a problem when
using with Delphi Forms on some machines. This method is safer.}

procedure TForm1.FormCreate(Sender: TObject);
begin
winFlags := GetWinFlags;
end;

{ Call the CPU function and assign it to the Edit box }
procedure TForm1.BitBtn1Click(Sender: TObject);
begin
Edit1.Text := GetCPUType;
end;

end.
------------------------------------------------------------------
Changing Forms according to Screen Resolution

When designing forms, it is sometimes helpful to write the code so that the screen and all of its objects are displayed at the same size no matter what the screen resolution is. Here is some code to show how that is done:


implementation
const
ScreenWidth: LongInt = 800; {I designed my form in 800x600 mode.}
ScreenHeight: LongInt = 600;

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
scaled := true;
if (screen.width <> ScreenWidth) then
begin
height := longint(height) * longint(screen.height) DIV ScreenHeight;
width := longint(width) * longint(screen.width) DIV ScreenWidth;
scaleBy(screen.width, ScreenWidth);
end;
end;

Then, you will want to have something that checks to see that the font sizes are OK. Before you change the font's size, you would need to ensure the object actually has a font property by checking the RTTI. This can be done as follows:


uses typinfo; {Add this to your USES statement.}

var
i: integer;
begin
for i := componentCount - 1 downto 0 do
with components[i] do
begin
if GetPropInfo(ClassInfo, 'font') <> nil then
font.size := (NewFormWidth DIV OldFormWidth) * font.size;
end;
end;

{This is the long way to do the same thing.}
var
i: integer;
p: PPropInfo;
begin
for i := componentCount - 1 downto 0 do
with components[i] do
begin
p := GetPropInfo(ClassInfo, 'font');
if assigned(p) then
font.size := (NewFormWidth DIV OldFormWidth) * font.size;
end;
end;

---------------------------------------------------------------------
Detect whether a drive exists or not

The following are functions to detect whether a drive exists or not. All of them essentially do the same thing.

function DoesDriveExist(DriveLetter: char): string;
var
i: integer;
begin
if DriveLetter in ['A'..'Z'] then {Make it lower case.}
DriveLetter := chr(ord(DriveLetter) or $20);
i := GetDriveType(ord(DriveLetter) - ord('a'));
case i of
DRIVE_REMOVABLE: result := 'floppy';
DRIVE_FIXED: result := 'hard disk';
DRIVE_REMOTE: result := 'network drive';
else result := 'does not exist';
end;
end;

function DoesDriveExist(DriveLetter: char): boolean;
var
drives: TDriveComboBox;
i: integer;
begin
result := false;
drives := TDriveComboBox.create(application);
drives.parent := form1;
form1.listbox1.items := drives.items;
for i := drives.items.count - 1 downto 0 do
{Note: this is case sensitive: lower case.}
if drives.items.strings[i][1] = DriveLetter then result := true;
drives.free; {...so that the combobox doesn't show.}
end;

Also, DiskFree() will return -1 if the drive does not exist.

function DirExists(const S : String): Boolean;
var
OldMode : Word;
OldDir : String;
begin
Result := True;
GetDir(0, OldDir); {save old dir for return}
OldMode := SetErrorMode(SEM_FAILCRITICALERRORS); {if drive empty, except}
try
try
ChDir(S);
except
on EInOutError DO Result := False;
end;
finally
ChDir(OldDir); {return to old dir}
SetErrorMode(OldMode); {restore old error mode}
end;
end;


-----------------------------------------------------------------------
How to stop Windows from displaying critical error messages
When performing certain functions it is necessary for your program to take full control over error messages. For example, if your program wants to "quietly" check if a floppy drive has a floppy disk in it, you may not want Windows to display a "critical error" if in fact the floppy drive is empty.
You can control which error messages Windows display by using the "SetErrorMode()" Win API function as follows:

var
wOldErrorMode : Word;
begin
{
tell windows to ignore critical
errors and save current error mode
}
wOldErrorMode :=
SetErrorMode(
SEM_FAILCRITICALERRORS );
try
{
code that might generate a
critical error goes here...
}
finally
{
go back to previous error mode
}
SetErrorMode( wOldErrorMode );
end;
end;


-------------------------------------------------------------
Better way to display [error] messages

If you display more than a few [error] messages in your application, using a simple method such as the following may not be the best approach:
Application.MessageBox(
'File not found', 'Error', mb_OK );


Above method of displaying errors will make it harder to modify actual messages since they are distributed all over your application source code. It may be better to have a "centralized" function that can display error messages, or better yet, a centralized function that can display replaceable error messages. Consider the following example:

type
cnMessageIDs =
(
nMsgID_NoError,
nMsgID_FileNotFound,
nMsgID_OutOfMemory,
nMsgID_ExitProgram
// list your other error
// IDs here...
);

const
csMessages_ShortVersion
: array [ Low( cnMessageIDs )..
High( cnMessageIDs ) ]
of PChar =
(
'No error',
'File not found',
'Out of memory',
'Exit program?'
// other error messages...
);

csMessages_DetailedVersion
: array [ Low( cnMessageIDs )..
High( cnMessageIDs ) ]
of PChar =
(
'No error; please ignore!',

'File c:\config.sys not found.'+
'Contact your sys. admin.',

'Out of memory. You need '+
'at least 4M for this function',

'Exit program? '+
'Save your data first!'
// other error messages...
);


procedure MsgDisplay(
cnMessageID : cnMessageIDs );
begin
// set this to False to display
// short version of the messages
if( True )then
Application.MessageBox(
csMessages_DetailedVersion[
cnMessageID ],
'Error',
mb_OK )
else
Application.MessageBox(
csMessages_ShortVersion[
cnMessageID ],
'Error',
mb_OK );
end;


Now, whenever you want to display an error message, you can call the MsgDisplay() function with the message ID rather than typing the message itself:

MsgDisplay( nMsgID_FileNotFound );


MsgDisplay() function will not only let you keep all your error messages in one place -- inside one unit for example, but it will also let you keep different sets of error messages -- novice/expert, debug/release, and even different sets for different languages.



---------------------------------------------------------------
No screen savers for me please
If your program needs all the attention of the computer, you might want to temporarily turn off screen savers -- at lease while your program is running. Rather than actually disabling and enabling the Windows screen saver, you can simply tell Windows that you've already handled the call for the default screen saver -- SC_SCREENSAVE.
Insert the following code into the "Public declarations" section of your main form:

procedure AppMessage(
var Msg : TMsg;
var bHandled : boolean );


In the "implementation" section, insert the following code (don't forget to change TForm1 to the [type=mwadah] name of your form):

procedure TForm1.AppMessage(
var Msg : TMsg;
var bHandled : boolean );
begin
if((WM_SYSCOMMAND = Msg.Message) and
(SC_SCREENSAVE = Msg.wParam) )then
bHandled := True;
end;



---------------------------------------------------------------


How to maximize without maximizing
When you maximize a Windows program, it will usually resize to fill up the full screen (minus the space occupied by primary controls such as the task bar). What if you don't want your application to change it's size to the size of the screen, yet you don't want to disable the maximize function? All you have to do is catch and handle the WM_GetMinMaxInfo message.
Assuming that the name of your main form's class is TForm1 and that you want your application to "maximize" to half the size of the screen:

Add the following declaration to the interface section of your application's main form (inside the private, public or protected declarations section):

procedure _WM_GETMINMAXINFO(
var mmInfo : TWMGETMINMAXINFO );
message wm_GetMinMaxInfo;


In the implementation section, type in the following code:

procedure TForm1._WM_GETMINMAXINFO(
var mmInfo : TWMGETMINMAXINFO );
begin
//
// set the position and the size of
// your form when maximized:
//
with mmInfo.minmaxinfo^ do
begin
ptmaxposition.x :=
Screen.Width div 4;
ptmaxposition.y :=
Screen.Height div 4;

ptmaxsize.x :=
Screen.Width div 2;
ptmaxsize.y :=
Screen.Height div 2;
end;
end;
---------------------------------------------------------

بارك الله فيك
شكرا شكرا شكرا