کد سورس هاي مفید و كاربردي در دلفی Delphi

[TAHA]

عکس عمل بالا خارج کردن از حالت فشره
*****************************

Uses ZLib; 
procedure  DecompressStream (aSource, aTarget: TStream) ;
var
decompStream:  TDecompressionStream;
nRead: Integer;
Buffer: array [0..1023] of  Char;
begin
decompStream :=  TDecompressionStream.Create(aSource);
try
repeat
nRead :=  decompStream.Read(Buffer, 1024);
aTarget.Write (Buffer, nRead);
until  nRead = 0;
finally
decompStream.Free;
end;
end; 

[TAHA]

اندازه فايلي که انتخاب ميشود را بر ميگرداند
******************************

procedure  TForm1.Button1Click(Sender: TObject);
var
SearchRec:  TSearchRec;
begin
if OpenDialog1.Execute then
if  FindFirst(OpenDialog1.FileName, faAnyFile, SearchRec) = 0 then
Label1.Caption  := FloatToStrF(SearchRec.Size/1048576, ffFixed, 7, 2)+'  MB';
FindClose(SearchRec);
end;

[TAHA]

رمز کردن مطالب
*********************

function  Encrypt(Text : string; Key1, Key2, Key3, Key4 : Integer)  :
string;
var
BufS, Hexa, Hexa1, Hexa2 : string;
BufI, BufI2, Sc,  Sl, Num1, Num2, Num3, Num4, Res1, Res2, Res3, Res4
: Integer;
begin
Sl  := Length(Text);
Sc := 0;
BufS := '';
if (Key1 in [1 .. 120]) and (Key2  in [1 .. 120]) and (Key3 in [1 ..
120]) and (Key4 in [1 .. 120])  then
begin
BufI := Key1 * Key4;
BufI2 := Key3 * Key2;
BufI := BufI -  BufI2;
if BufI = 0 then
begin
Result :=  '';
Exit;
end;
end
else
begin
Result :=  '';
Exit;
end;
repeat
Inc(Sc);
if Sc > Sl then Num1 := 0 else  Num1 := Ord(Text[Sc]);
Inc(Sc);
if Sc > Sl then Num2 := 0 else Num2 :=  Ord(Text[Sc]);
Inc(Sc);
if Sc > Sl then Num3 := 0 else Num3 :=  Ord(Text[Sc]);
Inc(sc);
if Sc > Sl then Num4 := 0 else Num4 :=  Ord(Text[Sc]);
Res1 := Num1 * Key1;
BufI := Num2 * Key3;
Res1 := Res1 +  BufI;
Res2 := Num1 * Key2;
BufI := Num2 * Key4;
Res2 := Res2 +  BufI;
Res3 := Num3 * Key1;
BufI := Num4 * Key3;
Res3 := Res3 +  BufI;
Res4 := Num3 * Key2;
BufI := Num4 * Key4;
Res4 := Res4 +  BufI;
for BufI := 1 to 4 do
begin
case BufI of
1 : Hexa :=  IntToHex(Res1, 4);
2 : Hexa := IntToHex(Res2, 4);
3 : Hexa :=  IntToHex(Res3, 4);
4 : Hexa := IntToHex(Res4, 4);
end;
Hexa1 := '$' +  Hexa[1] + Hexa[2];
Hexa2 := '$' + Hexa[3] + Hexa[4];
if (Hexa1 = '$00')  and (Hexa2 = '$00') then
begin
Hexa1 := '$FF';
Hexa2 :=  '$FF';
end;
if Hexa1 = '$00' then Hexa1 := '$FE';
if Hexa2 = '$00'  then
begin
Hexa2 := Hexa1;
Hexa1 := '$FD';
end;
BufS := BufS +  Chr(StrToInt(Hexa1)) + Chr(StrToInt(Hexa2));
end;
until Sc >=  Sl;
Result := BufS;
end; 

[TAHA]

رمز گشایی
****************************

function Decrypt(Text : string;  Key1, Key2, Key3, Key4 : Integer) :
string;
var
BufS, Hexa1, Hexa2 :  string;
BufI, BufI2, Divzr, Sc, Sl, Num1, Num2, Num3, Num4, Res1,  Res2,
Res3, Res4 : Integer;
begin
Sl := Length(Text);
Sc :=  0;
BufS := '';
if (Key1 in [1 .. 120]) and (Key2 in [1 .. 120]) and (Key3  in [1 ..
120]) and (Key4 in [1 .. 120]) then
begin
Divzr := Key1 *  Key4;
BufI2 := Key3 * Key2;
Divzr := Divzr - BufI2;
if Divzr = 0  then
begin
Result :=  '';
Exit;
end;
end
else
begin
Result :=  '';
Exit;
end;
repeat
for BufI := 1 to 4  do
begin
Inc(Sc);
Hexa1 := IntToHex(Ord(Text[Sc]),  2);
Inc(Sc);
Hexa2 := IntToHex(Ord(Text[Sc]), 2); 
if Hexa1 = 'FF'  then
begin 
Hexa1 := '00'; 
Hexa2 := '00';
end; 
if Hexa1 = 'FE'  then Hexa1 := '00'; 
if Hexa1 = 'FD' then
begin
Hexa1 := Hexa2;  
Hexa2 := '00';
end; 
case BufI of 
1 : Res1 := StrToInt('$' + Hexa1  + Hexa2);
2 : Res2 := StrToInt('$' + Hexa1 + Hexa2); 
3 : Res3 :=  StrToInt('$' + Hexa1 + Hexa2); 
4 : Res4 := StrToInt('$' + Hexa1 +  Hexa2);
end; 
end; 
BufI := Res1 * Key4;
BufI2 := Res2 * Key3;  
Num1 := BufI - BufI2; 
Num1 := Num1 div Divzr;
BufI := Res2 * Key1;  
BufI2 := Res1 * Key2; 
Num2 := BufI - BufI2;
Num2 := Num2 div  Divzr;
BufI := Res3 * Key4; 
BufI2 := Res4 * Key3;
Num3 := BufI -  BufI2; 
Num3 := Num3 div Divzr; 
BufI := Res4 * Key1;
BufI2 := Res3 *  Key2; 
Num4 := BufI - BufI2; 
Num4 := Num4 div Divzr;
BufS := BufS +  Chr(Num1) + Chr(Num2) + Chr(Num3) + Chr(Num4);
until Sc >= Sl; 
Result  := BufS;
end; 

[TAHA]

از کارانداختيCTRL+C و CTRL +V در memo*
*************************************

uses Clipbrd;
procedure  TForm1.Memo1KeyDown(Sender: TObject; var Key: Word;
Shift:  TShiftState);
begin

if ((Key = ord('V')) and (ssCtrl in Shift)) then  begin
if Clipboard.HasFormat(CF_TEXT) then ClipBoard.Clear;
key :=  0;
end;

if ((Key = ord('C')) and (ssCtrl in Shift)) then begin
if  Clipboard.HasFormat(CF_TEXT) then ClipBoard.Clear;
key := 0;
end;
end;  

[TAHA]

ذخیره عکس در اکسس
************************

procedure  TfrmMain.DataSource1DataChange(Sender: TObject; Field:  TField);
var
BlobStream: TStream;
JPEGImage: TJPegImage;
Ext:  string;
begin
if (Field = nil) or (Field = ADOTable1Image) then  begin
if ADOTable1Imagetype.AsString <> '' then begin
BlobStream :=  ADOTable1.CreateBlobStream(adotable1Image,
bmRead);
try
Ext :=  UpperCase(adotable1ImageType.AsString);
if Ext = '.BMP'  then
Image1.Picture.Bitmap.LoadFromStream(BlobStream)
else if Ext = '.JPG'  then begin
JPEGImage :=  TJPEGImage.Create;
try
JPEGImage.LoadFromStream(BlobStream);
Image1.Picture.Assign(JPEGImage);
finally
JPEGImage.Free;
end;
end;
finally
BlobStream.Free;
end;
end  else
Image1.Picture := nil;
end;
end;



if  OpenPictureDialog1.Execute then  begin
ADOTable1.Edit;
adotable1ImageType.AsString  :=
ExtractFileExt(OpenPictureDialog1.FileName);
adotable1Image.LoadFromFile(OpenPictureDialog1.Fil  eName);
end; 

[TAHA]

عکس ذخیره شده در اکسس را روی هارد ذخیره کنید
*************

if SaveDialog1.Execute  then
adotable1Attachment.SaveToFile(SaveDialog1.FileNam e);

[TAHA]

به چرخش در آوردن متن
***********************

procedure  AngleTextOut(Acanvas:Tcanvas;Angle,x,y:integer;Str  :String);
var
LogRec:TLogFont;
OldFontHandle,
NewFontHandle:Hfont;
begin
GetObject(Acanvas.Font.Handle,SizeOf(LogRec),Addr(  LogRec));
LogRec.lfEscapement:=Angle*10;
NewFontHandle:=CreateFontIndirect(logRec);
OldFontHandle:=SelectObject(Acanvas.handle,NewFont  Handle);
ACanvas.TextOut(x,y,Str);
NewFontHandle:=SelectObject(Acanvas.handle,OldFont  Handle);
DeleteObject(NewFontHandle);
end;

[TAHA]

نحوه استفاده بررسي خالي بودن کنترل TImage
***************************

if Image1.Picture.Graphic.Empty  then
begin
...
end;