نکاتی ساده در برنامه نویسی ( دلفی )

[آبجی]

باز و بسته کردن سیدی درایو
با استفاده از این فانکشن میتونید در هر نوع سیدی درایوی رو باز و بسته کنید
در اثر فشارهای مکرر دوستان من ترجمه فارسی توضیحات رو هم به کدها اضافه کردم



uses
MMSystem;

procedure TForm1.Button1Click(Sender: TObject);
begin
{باز کردن سیدی رام: در صورت موفقیت 0 برمیگرداند}
{ open CD-ROM drive; returns 0 if successfull }
mciSendString('set cdaudio door open wait', nil, 0, handle);

{ close the CD-ROM drive; returns 0 if successfull }
{بستن سیدی رام: در صورت موفقیت 0 برمیگرداند}
mciSendString('set cdaudio door closed wait', nil, 0, handle);
end;

[آبجی]

تغییر Volume ویندوز

یک TrackBar در فرم خود قرار دهید و Max value را به 15 تغییر دهید و در رویداد OnChange آن کد زیر را قرار دهید:




procedure TForm1.TrackBar1Change(Sender: TObject);
var
Count, i: integer;
begin
Count := waveOutGetNumDevs;
for i := 0 to Count do
begin
waveOutSetVolume(i,longint(TrackBar1.Position*4369 )*65536+longint(TrackBar1.Position*4369));
end;
end;
و با TrackBar بازی کنید ...

[آبجی]

به دست آوردن لیست سیدی درایوهای متصل به کامپیوتر
یک فانشکن مینویسیم که یک استرینگ بر میگرداند



Function GetCDList : String;
Var
I : Integer;
Drives: Integer;
Tmp : String;
begin
Drives := GetLogicalDrives;
Result := '';
// units A=0 to el Z=25
For I := 0 To 25 Do
If (((1 Shl I) And Drives)<>0) Then
Begin
Tmp := Char(65+I)+':\';
If (GetDriveType(PChar(Tmp))=DRIVE_CDROM) Then
Result := Result+Char(65+I);
End;
End;
نتیجه یک استرینگ است که لیست سیدی درایوها را بترتیب نشان میدهد

[آبجی]

تغییر Resolution مونیتور

باید یک پروسیجر به شکل زیر بنویسیم:




procedure SetResolution(ResX, ResY: DWord);
var
lDeviceMode : TDeviceMode;
begin
EnumDisplaySettings(nil, 0, lDeviceMode);
lDeviceMode.dmFields:=DM_PELSWIDTH or DM_PELSHEIGHT;
lDeviceMode.dmPelsWidth :=ResX;
lDeviceMode.dmPelsHeight:=ResY;
ChangeDisplaySettings(lDeviceMode, 0);
end;

[آبجی]

قرار دادن یک Bitmap در یک متافایل




procedure TForm1.Button1Click(Sender: TObject);
var
m : TmetaFile;
mc : TmetaFileCanvas;
b : tbitmap;
begin
m := TMetaFile.Create;
b := TBitmap.create;
b.LoadFromFile('C:\SomePath\SomeBitmap.BMP');
m.Height := b.Height;
m.Width := b.Width;
mc := TMetafileCanvas.Create(m, 0);
mc.Draw(0, 0, b);
mc.Free;
b.Free;
m.SaveToFile('C:\SomePath\Test.emf');
m.Free;
Image1.Picture.LoadFromFile('C:\SomePath\Test.emf' );
end;

[آبجی]

بدست آوردن Serial Number درایو



procedure TForm1.Button1Click(Sender: TObject);
var
VolumeName,
FileSystemName : array [0..MAX_PATH-1] of Char;
VolumeSerialNo : DWord;
MaxComponentLength,
FileSystemFlags : Integer;
begin
GetVolumeInformation('C:\',VolumeName,MAX_PATH,@Vo lumeSerialNo,
MaxComponentLength,FileSystemFlags,
FileSystemName,MAX_PATH);
Memo1.Lines.Add('VName = '+VolumeName);
Memo1.Lines.Add('SerialNo = $'+IntToHex(VolumeSerialNo,8));
Memo1.Lines.Add('CompLen = '+IntToStr(MaxComponentLength));
Memo1.Lines.Add('Flags = $'+IntToHex(FileSystemFlags,4));
Memo1.Lines.Add('FSName = '+FileSystemName);
end;



(http://solevahshi.persianblog.ir/page/taghziye) (http://solevahshi.persianblog.ir/page/taghziye)

[آبجی]

از بین بردن یک Task در ویندوز
با استفاده از این فانکشن کوچولو میتونید هر نوع برنامه اجرا شده ای رو که پسوند .Exe دارد، از لیست Task Manager ویندوز پاک کنید
مثلا:



KillTask('notepad.exe');
KillTask('iexplore.exe'); }

uses
Tlhelp32, Windows, SysUtils;

function KillTask(ExeFileName: string): integer;
const
PROCESS_TERMINATE=$0001;
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
begin
result := 0;

FSnapshotHandle := CreateToolhelp32Snapshot
(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := Sizeof(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle,
FProcessEntry32);

while integer(ContinueLoop) <> 0 do
begin
if ((UpperCase(ExtractFileName(FProcessEntry32.szExeF ile)) =
UpperCase(ExeFileName))
or (UpperCase(FProcessEntry32.szExeFile) =
UpperCase(ExeFileName))) then
Result := Integer(TerminateProcess(OpenProcess(
PROCESS_TERMINATE, BOOL(0),
FProcessEntry32.th32ProcessID), 0));
ContinueLoop := Process32Next(FSnapshotHandle,
FProcessEntry32);
end;

CloseHandle(FSnapshotHandle);
end;

[آبجی]

شناسایی یک فایل



function GetCheckSum (FileName : string) : DWORD;
var
F : File of DWORD;
Fsize : DWORD;
Buffer : Array [0..500] of DWORD;
P : Pointer;
begin
FileMode := 0;
AssignFile ( F , FileName);
Reset ( F );
Seek ( F , FileSize ( F ) div 2);
Fsize := FileSize( F )-1-FilePos( F );
if Fsize > 500 then Fsize := 500;
BlockRead ( F, Buffer, Fsize);
Close ( F );
P:=@Buffer;
asm
xor eax, eax
xor ecx, ecx
mov edi , p
@again:
add eax, [edi + 4*ecx]
inc ecx
cmp ecx, fsize
jl @again
mov @result, eax
end;
end;

[آبجی]

عملیات قابل انجام روی فلاپی دیسک
این کد کلیه فانکشکنهایی که برای کار با فلاپی درایو مورد نیاز است را در بردارد.

کد:

================================================== ===========
unit lDrives;
interface
uses Forms, Messages, Classes, WinProcs, WinTypes, SysUtils,
Dialogs, Controls;

const
MsgAskDefault = 'Please insert a disk on drive %s:';
MsgWProtected = 'Error: The disk %s is write-protected.';

type
TDriveType = (dtAll,dtFixed,dtRemovable,dtRemote{$IFDEF WIN32},dtCDRom,dtRamDisk{$ENDIF});

function ComposeFileName (Dir,Name:string):string;
function HasDiskSpace({$IFDEF WIN32}Drive: string{$ELSE}Drive: char{$ENDIF}; MinRequired: LongInt): boolean;
function GetDirectorySize(const Path: string): LongInt;
function GetFileSizeByName(const Filename: string): longInt;
function IsDiskRemovable(Drive: char): boolean;
function IsDiskInDrive(Drive: char): boolean;
function IsDiskWriteProtected(Drive: char): boolean;
function AskForDisk(Drive: char; Msg: string; CheckWriteProtected: boolean): boolean;
procedure GetAvailableDrives(DriveType: TDriveType; Items: TStrings);

implementation

function ComposeFileName (Dir,Name:string):string;
var
Separator: string[1];
begin
if (length(Dir) > 0) and (Dir[length(Dir)]='\') then
delete(Dir, length(Dir), 1);
if (length(Name) > 0) and (Name[1]='\') then
delete(Name, 1, 1);
if Name='' then Separator:='' else Separator:='\';
result:=format('%s%s%s',[Dir,Separator,Name]);
end;

function HasDiskSpace(Drive: {$IFDEF WIN32}string{$ELSE}char{$ENDIF}; MinRequired: LongInt): boolean;
begin
if Drive='' then Drive:='C';
{$IFDEF WIN32}
result:=((GetDriveType(PChar(Drive))<>0) and
(SysUtils.DiskFree(Ord(UpCase(Drive[1]))-$40)=-1) or
(SysUtils.DiskFree(Ord(UpCase(Drive[1]))-$40)>=MinRequired));
{$ELSE}
result:=((GetDriveType(Ord(UpCase(Drive))-$40)<>0) and
(DiskFree(Ord(UpCase(Drive))-$40)=-1) or
(DiskFree(Ord(UpCase(Drive))-$40)>=MinRequired));
{$ENDIF}
end;

function GetDirectorySize(const Path: string): LongInt;
var
S: TSearchRec;
TotalSize: LongInt;
begin
TotalSize:=0;
if FindFirst(ComposeFileName(Path,'*.*'), faAnyFile, S)=0 then
repeat
Inc(TotalSize, S.Size);
until FindNext(S)<>0;
result:=TotalSize;
end;

function GetFileSizeByName(const Filename: string): longInt;
var
F: File;
begin
AssignFile(F, Filename);
Reset(F,1);
result:=FileSize(F);
CloseFile(F);
end;

function IsDiskRemovable(Drive: char): boolean;
begin
{$IFDEF WIN32}
result:=GetDriveType(PChar(Drive+':\'))=DRIVE_REMO VABLE;
{$ELSE}
result:=GetDriveType(ord(UpCase(Drive))-65)=DRIVE_REMOVABLE;
{$ENDIF}
end;

function IsDiskInDrive(Drive: char): Boolean;
var
ErrorMode: word;
begin
Drive:=Upcase(Drive);
if not (Drive in ['A'..'Z']) then
begin
Result:=False;
Exit;
end;
ErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
try
if DiskSize(Ord(Drive) - 64) = -1 then
Result := False
else
Result := True;
finally
SetErrorMode(ErrorMode);
end;
end;

function IsDiskWriteProtected(Drive: char): Boolean;
var
F: File;
ErrorMode: Word;
begin
ErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
AssignFile(F,Drive+':\_$.$$$');
try
try
Rewrite(F);
CloseFile(F);
Erase(F);
Result:=False;
except
Result:=True;
end;
finally
SetErrorMode(ErrorMode);
end;
end;

{$IFDEF WIN32}
procedure GetAvailableDrives(DriveType: TDriveType; Items: TStrings);
var
Drive: Integer;
DriveLetter: string;
begin
Items.Clear;
for Drive := 0 to 25 do
begin
DriveLetter := Chr(Drive + ord('A'))+':\';
case DriveType of
dtAll : if GetDriveType(PChar(DriveLetter)) in [DRIVE_REMOVABLE,DRIVE_FIXED,DRIVE_REMOTE,
DRIVE_CDROM,DRIVE_RAMDISK] then
Items.Add(DriveLetter);
dtRemovable: if GetDriveType(PChar(DriveLetter))=DRIVE_REMOVABLE then
Items.Add(DriveLetter);
dtFixed : if GetDriveType(PChar(DriveLetter))=DRIVE_FIXED then
Items.Add(DriveLetter);
dtRemote : if GetDriveType(PChar(DriveLetter))=DRIVE_REMOTE then
Items.Add(DriveLetter);
dtCDRom : if GetDriveType(PChar(DriveLetter))=DRIVE_CDROM then
Items.Add(DriveLetter);
dtRamDisk : if GetDriveType(PChar(DriveLetter))=DRIVE_RAMDISK then
Items.Add(DriveLetter);
end;
end;
end;
{$ELSE}
procedure GetAvailableDrives(DriveType: TDriveType; Items: TStrings);
var
Drive: Integer;
DriveLetter: char;
begin
Items.Clear;
for Drive := 0 to 25 do
begin
DriveLetter := Chr(Drive + ord('A'));
case DriveType of
dtAll : if GetDriveType(Drive) in [DRIVE_REMOVABLE,DRIVE_FIXED,DRIVE_REMOTE] then
Items.Add(DriveLetter+':\');
dtRemovable: if GetDriveType(Drive)=DRIVE_REMOVABLE then
Items.Add(DriveLetter+':\');
dtFixed : if GetDriveType(Drive)=DRIVE_FIXED then
Items.Add(DriveLetter+':\');
dtRemote : if GetDriveType(Drive)=DRIVE_REMOTE then
Items.Add(DriveLetter+':\');
end;
end;
end;
{$ENDIF}

function AskForDisk(Drive: char; Msg: string; CheckWriteProtected: boolean): boolean;
var
Ready : boolean;
begin
Ready:=false; Result:=false;
if Msg='' then Msg:=Format(MsgAskDefault,[Drive]);
while not(Ready) do
try
if IsDiskRemovable(Drive) then
case MessageDlg(Msg, mtConfirmation, [mbOk,mbCancel],0) of
mrOk : ready:=IsDiskInDrive(Drive);
mrCancel: exit;
end
else
Ready:=true;
except
result:=false;
exit;
end;
ready:=false;
while not(Ready) do
try
if CheckWriteProtected and IsDiskWriteProtected(Drive) then
begin
ready:=false;
if MessageDlg(Format(MsgWProtected,[Upcase(Drive)+':']),mtError,[mbRetry,mbCancel],0)=mrCancel then
exit;
end
else
ready:=true;
except
result:=false;
exit;
end;
result:=Ready;
end;

end.

[آبجی]

اضافه کردن تکست به Log Files



function AddTextToFile(const aFileName, aText: string; AddCRLF: Boolean): Boolean;
var
lF: Integer;
lS: string;
begin
Result := False;
if FileExists(aFileName) then lF := FileOpen(aFileName, fmOpenWrite + fmShareDenyNone)
else lF := FileCreate(aFileName);
if (lF >= 0) then
try
FileSeek(lF, 0, 2);
if AddCRLF then lS := aText + #13#10
else lS := aText;
FileWrite(lF, lS[1], Length(lS));
finally
FileClose(lF);
end;
end;

[آبجی]

دیالوگ برای Select Directory



uses FileCtrl; // for SelectDirectory

var
Dir: string;
(...)
Dir := 'C:\Windows';
if SelectDirectory(Dir, [sdAllowCreate, sdPerformCreate,
sdPrompt], 0) then
Label1.Caption := Dir;

[آبجی]

روش چرخاندن یک نقطه در فضای دو بعدی حول یک نقطه دوبعدی دیگر:




const
PIDiv180 = 0.017453292519943295769236907684886;

procedure Rotate(RotAng: Double; x, y, ox, oy: Double; var Nx, Ny: Double);
begin
Rotate(RotAng, x - ox, y - oy, Nx, Ny);
Nx := Nx + ox;
Ny := Ny + oy;
end;
(* End Of Rotate Cartesian Point About Origin *)


procedure Rotate(RotAng: Double; x, y: Double; var Nx, Ny: Double);
var
SinVal: Double;
CosVal: Double;
begin
RotAng := RotAng * PIDiv180;
SinVal := Sin(RotAng);
CosVal := Cos(RotAng);
Nx := x * CosVal - y * SinVal;
Ny := y * CosVal + x * SinVal;
end;

[آبجی]

Screen Shots
با استفاده از این کد میتوانید تصویر Screen را در یک فایل Bitmap ذخیره نمائید. اگر نمیخواهید از یک برنامه فعال دلفی استفاده کنید میتوانید یک 'Application.Minimize;' در Beginning پروسیجر وارد کنید.


uses
Windows, Graphics, Forms;

procedure TForm1.Button1Click(Sender: TObject);
var
DC: HDC;
Canvas: TCanvas;
MyBitmap: TBitmap;
begin
Canvas := TCanvas.Create;
MyBitmap := TBitmap.Create;
DC := GetDC(0);

try
Canvas.Handle := DC;
with Screen do
begin
{ detect the actual height and with of the screen }
MyBitmap.Width := Width;
MyBitmap.Height := Height;

{ copy the screen content to the bitmap }
MyBitmap.Canvas.CopyRect(Rect(0, 0, Width, Height), Canvas,
Rect(0, 0, Width, Height));
{ stream the bitmap to disk }
MyBitmap.SaveToFile('c:\windows\desktop\screen.bmp ');
end;

[آبجی]

محاسبه سن یک فرد


function CalculateAge(Birthday, CurrentDate: TDate): Integer;
var
Month, Day, Year, CurrentYear, CurrentMonth, CurrentDay: Word;
begin
DecodeDate(Birthday, Year, Month, Day);
DecodeDate(CurrentDate, CurrentYear, CurrentMonth, CurrentDay);

if (Year = CurrentYear) and (Month = CurrentMonth) and (Day = CurrentDay) then
begin
Result := 0;
end
else
begin
Result := CurrentYear - Year;
if (Month > CurrentMonth) then
Dec(Result)
else
begin
if Month = CurrentMonth then
if (Day > CurrentDay) then
Dec(Result);
end;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption := Format('Your age is %d', [CalculateAge(StrToDate('01.01.1903'), Date)]);
end;

[آبجی]

محاسبه لگاریتم با پایه متغیر


function Log(x, b: Real): Real;
begin
Result := ln(x) / ln(b);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(Format('%f', [Log(10, 10)]));
end;

[آبجی]

ضرب اعداد صحیح بزرگ




type
IntNo = record
Low32, Hi32: DWORD;
end;

function Multiply(p, q: DWORD): IntNo;
var
x: IntNo;
begin
asm
MOV EAX,[p]
MUL [q]
MOV [x.Low32],EAX
MOV [x.Hi32],EDX
end;
Result := x
end;



var

[آبجی]

استفاده از الگوریتم Base64 جهت Encoding و Decoding


function Decode(const S: AnsiString): AnsiString;
const
Map: array[Char] of Byte = (0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 62, 0, 0, 0, 63, 52, 53,
54, 55, 56, 57, 58, 59, 60, 61, 0, 0, 0, 0, 0, 0, 0, 0, 1, 2,
3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19,
20, 21, 22, 23, 24, 25, 0, 0, 0, 0, 0, 0, 26, 27, 28, 29, 30,
31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45,
46, 47, 48, 49, 50, 51, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0);
var
I: LongInt;
begin
case Length(S) of
2:
begin
I := Map[S[1]] + (Map[S[2]] shl 6);
SetLength(Result, 1);
Move(I, Result[1], Length(Result))
end;
3:
begin
I := Map[S[1]] + (Map[S[2]] shl 6) + (Map[S[3]] shl 12);
SetLength(Result, 2);
Move(I, Result[1], Length(Result))
end;
4:
begin
I := Map[S[1]] + (Map[S[2]] shl 6) + (Map[S[3]] shl 12) +
(Map[S[4]] shl 18);
SetLength(Result, 3);
Move(I, Result[1], Length(Result))
end
end
end;

function Encode(const S: AnsiString): AnsiString;
const
Map: array[0..63] of Char = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' +
'abcdefghijklmnopqrstuvwxyz0123456789+/';
var
I: LongInt;
begin
I := 0;
Move(S[1], I, Length(S));
case Length(S) of
1:
Result := Map[I mod 64] + Map[(I shr 6) mod 64];
2:
Result := Map[I mod 64] + Map[(I shr 6) mod 64] +
Map[(I shr 12) mod 64];
3:
Result := Map[I mod 64] + Map[(I shr 6) mod 64] +
Map[(I shr 12) mod 64] + Map[(I shr 18) mod 64]
end
end;

[آبجی]

محاسبه فاکتوریل یک عدد




function FacIterative(n: Word): Longint;
var
f: LongInt;
i: Integer;
begin
f := 1;
for i := 2 to n do f := f * i;
Result := f;
end;



function FacRecursive(n: Word): LongInt;
begin
if n > 1 then
Result := n * FacRecursive(n-1)
else
Result := 1;
end;

[آبجی]

محاسبه معکوس یک ماتریس


type
RCOMat = array of array of Extended;

var
DimMat: integer;

procedure InvertMatrix(var aa: RCOMat);
var
numb, nula1, ipiv, indxr, indxc: array of Integer;
i, j, l, kod, jmax, k, ll, icol, irow: Integer;
amax, d, c, pomos, big, dum, pivinv: Double;
ind: Boolean;
begin
for j := 0 to Pred(DimMat) do ipiv[j] := 0;

irow := 1;
icol := 1;
for i := 0 to Pred(DimMat) do
begin
big := 0;

for j := 0 to Pred(DimMat) do
begin
if (ipiv[j] <> 1) then
begin
for k := 0 to Pred(DimMat) do
begin
if (ipiv[k] = 0) then
if (Abs(aa[j, k]) >= big) then
begin
big := Abs(aa[j, k]);
irow := j;
icol := k;
end
else;
end;
end;
end;

ipiv[icol] := ipiv[icol] + 1;
if (irow <> icol) then
begin
for l := 0 to Pred(DimMat) do
begin
dum := aa[irow, l];
aa[irow, l] := aa[icol, l];
aa[icol, l] := dum;
end;
for l := 0 to Pred(DimMat) do
begin
dum := aa[irow + DimMat + 1, l];
aa[irow + DimMat + 1, l] := aa[icol + DimMat + 1, l];
aa[icol + DimMat + 1, l] := dum;
end;
end;
indxr[i] := irow;
indxc[i] := icol;
if (aa[icol, icol] = 0) then;
pivinv := 1.0 / aa[icol, icol];
aa[icol, icol] := 1.0;
for l := 0 to Pred(DimMat) do aa[icol, l] := aa[icol, l] * pivinv;
for l := 0 to Pred(DimMat) do aa[icol + DimMat + 1, l] :=
aa[icol + DimMat + 1, l] * pivinv;
for ll := 0 to Pred(DimMat) do
begin
if (ll <> icol) then
begin
dum := aa[ll, icol];
aa[ll, icol] := 0.0;
for l := 0 to Pred(DimMat) do aa[ll, l] := aa[ll, l] - aa[icol, l] * dum;
for l := 0 to Pred(DimMat) do aa[ll + DimMat + 1, l] :=
aa[ll + DimMat + 1, l] - aa[icol + DimMat + 1, l] * dum;
end;
end;
end;

for l := Pred(DimMat) downto 0 do
begin
if (indxr[l] <> indxc[l]) then
begin
for k := 0 to Pred(DimMat) do
begin
dum := aa[k, indxr[l]];
aa[k, indxr[l]] := aa[k, indxc[l]];
aa[k, indxc[l]] := dum;
end;
end;
end;
end;

[آبجی]

تعیین اول بودن یک عدد


unction IsPrime(N: Cardinal): Boolean; register;
// test if N is prime, do some small Strong Pseudo Prime test in certain bounds
// copyright (c) 2000 Hagen Reddmann, don't remove
asm
TEST EAX,1 { Odd(N) ?? }
JNZ @@1
CMP EAX,2 { N == 2 ?? }
SETE AL
RET
@@1: CMP EAX,73 { N JB @@C }
JE @@E { N == 73 ?? }
PUSH ESI
PUSH EDI
PUSH EBX
PUSH EBP
PUSH EAX { save N as Param for @@5 }
LEA EBP,[EAX - 1] { M == N -1, Exponent }
MOV ECX,32 { calc remaining Bits of M and shift M' }
MOV ESI,EBP
@@2: DEC ECX
SHL ESI,1
JNC @@2
PUSH ECX { save Bits as Param for @@5 }
PUSH ESI { save M' as Param for @@5 }
CMP EAX,08A8D7Fh { N = 9080191 ?? }
JAE @@3
// now if (N MOV EAX,31
CALL @@5 { 31^((N-1)(2^s)) mod N }
JC @@4
MOV EAX,73 { 73^((N-1)(2^s)) mod N }
PUSH OFFSET @@4
JMP @@5
// now if (N @@3: MOV EAX,2
CALL @@5
JC @@4
MOV EAX,7
CALL @@5
JC @@4
MOV EAX,61
CALL @@5
@@4: SETNC AL
ADD ESP,4 * 3
POP EBP
POP EBX
POP EDI
POP ESI
RET
// do a Strong Pseudo Prime Test
@@5: MOV EBX,[ESP + 12] { N on stack }
MOV ECX,[ESP + 8] { remaining Bits }
MOV ESI,[ESP + 4] { M' }
MOV EDI,EAX { T = b, temp. Base }
@@6: DEC ECX
MUL EAX
DIV EBX
MOV EAX,EDX
SHL ESI,1
JNC @@7
MUL EDI
DIV EBX
AND ESI,ESI
MOV EAX,EDX
@@7: JNZ @@6
CMP EAX,1 { b^((N -1)(2^s)) mod N == 1 mod N ?? }
JE @@A
@@8: CMP EAX,EBP { b^((N -1)(2^s)) mod N == -1 mod N ?? , EBP = N -1 }
JE @@A
DEC ECX { second part to 2^s }
JNG @@9
MUL EAX
DIV EBX
CMP EDX,1
MOV EAX,EDX
JNE @@8
@@9: STC
@@A: RET
@@B: DB 3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67 ,71
@@C: MOV EDX,OFFSET @@B
MOV ECX,18
@@D: CMP AL,[EDX + ECX]
JE @@E
DEC ECX
JNL @@D
@@E: SETE AL
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if IsPrime(3453451) then
ShowMessage('yes');
end;

{**** Another function ***}

function IsPrime(Prim: Longint): Boolean;
var
Z: Real;
Max: LongInt;
Divisor: LongInt;
begin
Prime := False;
if (Prim and 1) = 0 then Exit;
Z := Sqrt(Prim);
Max := Trunc(Z) + 1;
Divisor := 3;
while Max > Divisor do
begin
if (Prim mod Divisor) = 0 then Exit;
Inc(Divisor, 2);
if (Prim mod Divisor) = 0 then Exit;
Inc(Divisor, 4);
end;
Prime := True;
end;

[آبجی]

تغییر مبنای یک عدد از مبنای هشت به Integer


function OctToInt(Value: string): Longint;
var
i: Integer;
int: Integer;
begin
int := 0;
for i := 1 to Length(Value) do
begin
int := int * 8 + StrToInt(Copy(Value, i, 1));
end;
Result := int;
end;

[آبجی]

تغییر مبنای یک عدد Integer به مبنای هشت


function IntToOct(Value: Longint; digits: Integer): string;
var
rest: Longint;
oct: string;
i: Integer;
begin
oct := '';
while Value <> 0 do
begin
rest := Value mod 8;
Value := Value div 8;
oct := IntToStr(rest) + oct;
end;
for i := Length(oct) + 1 to digits do
oct := '0' + oct;
Result := oct;
end;

[آبجی]

تعیین شماره روز در سال


function GetDays(ADate: TDate): Extended;
var
FirstOfYear: TDateTime;
begin
FirstOfYear := EncodeDate(StrToInt(FormatDateTime('yyyy', now)) - 1, 12, 31);
Result := ADate - FirstOfYear;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption := 'Today is the ' + FloatToStr(GetDays(Date)) + '. day of the year';
end;

[آبجی]

تبدیل یک عدد هگزادسیمال به باینری


function HexToBin(Hexadecimal: string): string;
const
BCD: array [0..15] of string =
('0000', '0001', '0010', '0011', '0100', '0101', '0110', '0111',
'1000', '1001', '1010', '1011', '1100', '1101', '1110', '1111');
var
i: integer;
begin
for i := Length(Hexadecimal) downto 1 do
Result := BCD[StrToInt('$' + Hexadecimal[i])] + Result;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(HexToBin('FFA1'));
// Returns 1111111110100001
end;

[آبجی]

تغییر مقیاس یک تصویر


.... }

private
function ScalePercentBmp(bitmp: TBitmap; iPercent: Integer): Boolean;

{ .... }

function TForm1.ScalePercentBmp(bitmp: TBitmap;
iPercent: Integer): Boolean;
var
TmpBmp: TBitmap;
ARect: TRect;
h, w: Real;
hi, wi: Integer;
begin
Result := False;
try
TmpBmp := TBitmap.Create;
try
h := bitmp.Height * (iPercent / 100);
w := bitmp.Width * (iPercent / 100);
hi := StrToInt(FormatFloat('#', h)) + bitmp.Height;
wi := StrToInt(FormatFloat('#', w)) + bitmp.Width;
TmpBmp.Width := wi;
TmpBmp.Height := hi;
ARect := Rect(0, 0, wi, hi);
TmpBmp.Canvas.StretchDraw(ARect, Bitmp);
bitmp.Assign(TmpBmp);
finally
TmpBmp.Free;
end;
Result := True;
except
Result := False;
end;
end;


// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
ScalePercentBmp(Image1.Picture.Bitmap, 33);
end;

[آبجی]

رندر متن یک TrichEdit در یک Canvas


procedure RichEditToCanvas(RichEdit: TRichEdit; Canvas: TCanvas; PixelsPerInch: Integer);
var
ImageCanvas: TCanvas;
fmt: TFormatRange;
begin
ImageCanvas := Canvas;
with fmt do
begin
hdc:= ImageCanvas.Handle;
hdcTarget:= hdc;
// rect needs to be specified in twips (1/1440 inch) as unit
rc:= Rect(0, 0,
ImageCanvas.ClipRect.Right * 1440 div PixelsPerInch,
ImageCanvas.ClipRect.Bottom * 1440 div PixelsPerInch
);
rcPage:= rc;
chrg.cpMin := 0;
chrg.cpMax := RichEdit.GetTextLen;
end;
SetBkMode(ImageCanvas.Handle, TRANSPARENT);
RichEdit.Perform(EM_FORMATRANGE, 1, Integer(@fmt));
// next call frees some cached data
RichEdit.Perform(EM_FORMATRANGE, 0, 0);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
RichEditToCanvas(RichEdit1, Image1.Canvas, Self.PixelsPerInch);
Image1.Refresh;
end;

[آبجی]

تغییر وضوح یک Jpg


procedure GetResJpg(JPGFile: string);
const
BufferSize = 50;
var
Buffer: string;
Index: integer;
FileStream: TFileStream;
HorzRes, VertRes: Word;
DP: Byte;
Measure: string;
begin
FileStream := TFileStream.Create(JPGFile,
fmOpenReadWrite);
try
SetLength(Buffer, BufferSize);
FileStream.Read(buffer[1], BufferSize);
Index := Pos('JFIF' + #$00, buffer);
if Index > 0 then
begin
FileStream.Seek(Index + 6, soFromBeginning);
FileStream.Read(DP, 1);
case DP of
1: Measure := 'DPI'; //Dots Per Inch
2: Measure := 'DPC'; //Dots Per Cm.
end;
FileStream.Read(HorzRes, 2); // x axis
HorzRes := Swap(HorzRes);
FileStream.Read(VertRes, 2); // y axis
VertRes := Swap(VertRes);
end
finally
FileStream.Free;
end;
end;

procedure SetResJpg(name: string; dpix, dpiy: Integer);
const
BufferSize = 50;
DPI = 1; //inch
DPC = 2; //cm
var
Buffer: string;
index: INTEGER;
FileStream: TFileStream;
xResolution: WORD;
yResolution: WORD;
_type: Byte;
begin
FileStream := TFileStream.Create(name,
fmOpenReadWrite);
try
SetLength(Buffer, BufferSize);
FileStream.Read(buffer[1], BufferSize);
index := POS('JFIF' + #$00, buffer);
if index > 0
then begin
FileStream.Seek(index + 6, soFromBeginning);
_type := DPI;
FileStream.write(_type, 1);
xresolution := swap(dpix);
FileStream.write(xresolution, 2);
yresolution := swap(dpiy);
FileStream.write(yresolution, 2);
end
finally
FileStream.Free;
end;
end;

[آبجی]

اعمال فیلتر Emboss روی یک تصویر


procedure Emboss(ABitmap : TBitmap; AMount : Integer);
var
x, y, i : integer;
p1, p2: PByteArray;
begin
for i := 0 to AMount do
begin
for y := 0 to ABitmap.Height-2 do
begin
p1 := ABitmap.ScanLine[y];
p2 := ABitmap.ScanLine[y+1];
for x := 0 to ABitmap.Width do
begin
p1[x*3] := (p1[x*3]+(p2[(x+3)*3] xor $FF)) shr 1;
p1[x*3+1] := (p1[x*3+1]+(p2[(x+3)*3+1] xor $FF)) shr 1;
p1[x*3+2] := (p1[x*3+1]+(p2[(x+3)*3+1] xor $FF)) shr 1;
end;
end;
end;
end;