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

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

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

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;

 

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

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

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; ​

 

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

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

کد:

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; ​

 

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

از کارانداختي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; ​

 

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

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

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; ​

 

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

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

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

 

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

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

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;

 

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

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

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