تمامی مسائل و مباحث در مورد دلفی

خوب در این تاپیک در مورد سورس کدها و کتابها بحث و گفتگو می کنیم.
از همه دوستان همکاری لازم را می خواهم.

مجموعه تبدیل تاریخ میلادی به شمسی

تبدیل تاریخ میلادی به شمسی و همچنین شمسی به میلادی به طور کاملا دقیق
آزمایش شده از هر جهت و بدون خطا
استفاده از قالب استاندارد دلفی TDateTime
وجود توابع بسیار داخلی برای مدیریت تاریخ
توانایی کار با زمان در کنار تاریخ
توضیح توابع پر کابرد را در [ برای مشاهده لینک ، با نام کاربری خود وارد شوید یا ثبت نام کنید ] مطالعه نمایید.
همراه با کد و کاملا رایگان.
در یافت برنامه از [ برای مشاهده لینک ، با نام کاربری خود وارد شوید یا ثبت نام کنید ]

ایجاد جلوه Fade در هنگام ظاهر و مخفی شدن فرم

با استفاده از این کامپوننت می توانید هنگام ظاهر یا مخفی شدن فرم آن را به صورت Fade in یا Fade out نمایش دهید.

این جاوه زیبایی به فرم شما خواهد داد.

این کامپوننت در ویندوز های 2000 به بالا کار خواهد کرد.

همراه با کد و کاملا رایگان.
دریافت از [ برای مشاهده لینک ، با نام کاربری خود وارد شوید یا ثبت نام کنید ] .

ترکیب کننده چندین فایل مختلف در یک فایل

AnyFileCollector


ترکیب چندین فایل مخلف در یک فایل.

ذخیره نام فایلها برای استخراج راحتتر فایل ها.

استخراج فایلها به صورت کامل.

همراه با کد و کاملا رایگان.
دریافت از [ برای مشاهده لینک ، با نام کاربری خود وارد شوید یا ثبت نام کنید ] .

پخش کننده فایل صوتی توسط
PlayDirectSound


پخش فایلهای wav با استفاده از تکنولوژی DirectSound

توانایی پخش فایلها به طور همزمان

امکان مدیریت کامل بر نحوه پخش فایل

همراه با کد و کاملا رایگان
دریافت برنامه از [ برای مشاهده لینک ، با نام کاربری خود وارد شوید یا ثبت نام کنید ]

برنامه استخراج ایمیل ها از کامپیوتر
Email lister




توانایی استخراج ایمیل ها از درون کامپیوتر شما که این توانایی را دارد که در میان سایتهایی که بازدید کرده اید به دنبال ایمیل بگردد!

حذف ایمیل های تکراری و بررسی صحت ساختار آنها.

ذخیره ایملها در یک فایل متنی.

همراه با کد به زبان VB و صد در صد رایگان!
دریافت برنامه از [ برای مشاهده لینک ، با نام کاربری خود وارد شوید یا ثبت نام کنید ]
.

اولين راه استفاده از OCX مربوط به شركت kylix soft مي باشد .

لینک سایتش زیر می باشد. [ برای مشاهده لینک ، با نام کاربری خود وارد شوید یا ثبت نام کنید ]

[ برای مشاهده لینک ، با نام کاربری خود وارد شوید یا ثبت نام کنید ]

مجموعه 100 سوال دلفی همراه با جواب .
امیدوارم به دردتون بخوره

باز و بسته كردن سيدي درايو
با استفاده از اين فانكشن ميتونيد در هر نوع سيدي درايوي رو باز و بسته كنيد

کد:

---

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;

---

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

کد:

---

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;

---

قرار دادن يك 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,@VolumeSerialNo,
                      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;

---

از بين بردن يك Task در ويندوز
از بين بردن يك 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.szExeFile)) =
        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_REMOVABLE;
  {$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;

  finally
    { free memory }
    ReleaseDC(0, DC);
    MyBitmap.Free;
    Canvas.Free
  end;
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
  r: IntNo;
begin
  r := Multiply(40000000, 80000000);
  ShowMessage(IntToStr(r.Hi32) + ', ' + IntToStr(r.low32))
end;

---

استفاده از الگوريتم ------ جهت 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;

---

highlight كردن متن درون Twebbrowser

کد:

---

{....}

private
  procedure SearchAndHighlightText(aText: string);
   
{....}

uses mshtml;

{ .... }


procedure TForm1.SearchAndHighlightText(aText: string);
var
  tr: IHTMLTxtRange; //TextRange Object
begin
  if not WebBrowser1.Busy then
  begin
    tr := ((WebBrowser1.Document as IHTMLDocument2).body as IHTMLBodyElement).createTextRange;
    //Get a body with IHTMLDocument2 Interface and then a TextRang obj. with IHTMLBodyElement Intf.

    while tr.findText(aText, 1, 0) do //while we have result
    begin
      tr.pasteHTML('<span style="background-color: Lime; font-weight: bolder;">' +
        tr.htmlText + '</span>');
      //Set the highlight, now background color will be Lime
      tr.scrollIntoView(True);
      //When IE find a match, we ask to scroll the window... you dont need this...
    end;
  end;
end;

// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
  SearchAndHighlightText('delphi');
end;

---

بدست آوردن پروسسهاي فعال شبكه

کد:

---

unit PerfInfo;

interface

uses
  Windows, SysUtils, Classes;

type
  TPerfCounter = record
    Counter: Integer;
    Value: TLargeInteger;
  end;

  TPerfCounters = Array of TPerfCounter;

  TPerfInstance = class
  private
    FName: string;
    FCounters: TPerfCounters;
  public
    property Name: string read FName;
    property Counters: TPerfCounters read FCounters;
  end;

  TPerfObject = class
  private
    FList: TList;
    FObjectID: DWORD;
    FMachine: string;
    function GetCount: Integer;
    function GetInstance(Index: Integer): TPerfInstance;
    procedure ReadInstances;
  public
    property ObjectID: DWORD read FObjectID;
    property Item[Index: Integer]: TPerfInstance
      read GetInstance; default;
    property Count: Integer read GetCount;
    constructor Create(const AMachine: string; AObjectID: DWORD);
    destructor Destroy; override;
  end;

procedure GetProcesses(const Machine: string; List: TStrings);

implementation

type
  PPerfDataBlock = ^TPerfDataBlock;
  TPerfDataBlock = record
    Signature: array[0..3] of WCHAR;
    LittleEndian: DWORD;
    Version: DWORD;
    Revision: DWORD;
    TotalByteLength: DWORD;
    HeaderLength: DWORD;
    NumObjectTypes: DWORD;
    DefaultObject: Longint;
    SystemTime: TSystemTime;
    PerfTime: TLargeInteger;
    PerfFreq: TLargeInteger;
    PerfTime100nSec: TLargeInteger;
    SystemNameLength: DWORD;
    SystemNameOffset: DWORD;
  end;

  PPerfObjectType = ^TPerfObjectType;
  TPerfObjectType = record
    TotalByteLength: DWORD;
    DefinitionLength: DWORD;
    HeaderLength: DWORD;
    ObjectNameTitleIndex: DWORD;
    ObjectNameTitle: LPWSTR;
    ObjectHelpTitleIndex: DWORD;
    ObjectHelpTitle: LPWSTR;
    DetailLevel: DWORD;
    NumCounters: DWORD;
    DefaultCounter: Longint;
    NumInstances: Longint;
    CodePage: DWORD;
    PerfTime: TLargeInteger;
    PerfFreq: TLargeInteger;
  end;

  PPerfCounterDefinition = ^TPerfCounterDefinition;
  TPerfCounterDefinition = record
    ByteLength: DWORD;
    CounterNameTitleIndex: DWORD;
    CounterNameTitle: LPWSTR;
    CounterHelpTitleIndex: DWORD;
    CounterHelpTitle: LPWSTR;
    DefaultScale: Longint;
    DetailLevel: DWORD;
    CounterType: DWORD;
    CounterSize: DWORD;
    CounterOffset: DWORD;
  end;

  PPerfInstanceDefinition = ^TPerfInstanceDefinition;
  TPerfInstanceDefinition = record
    ByteLength: DWORD;
    ParentObjectTitleIndex: DWORD;
    ParentObjectInstance: DWORD;
    UniqueID: Longint;
    NameOffset: DWORD;
    NameLength: DWORD;
  end;

  PPerfCounterBlock = ^TPerfCounterBlock;
  TPerfCounterBlock = record
    ByteLength: DWORD;
  end;


{Navigation helpers}

function FirstObject(PerfData: PPerfDataBlock): PPerfObjectType;
begin
  Result := PPerfObjectType(DWORD(PerfData) + PerfData.HeaderLength);
end;


function NextObject(PerfObj: PPerfObjectType): PPerfObjectType;
begin
  Result := PPerfObjectType(DWORD(PerfObj) + PerfObj.TotalByteLength);
end;


function FirstInstance(PerfObj: PPerfObjectType): PPerfInstanceDefinition;
begin
  Result := PPerfInstanceDefinition(DWORD(PerfObj) + PerfObj.DefinitionLength);
end;


function NextInstance(PerfInst: PPerfInstanceDefinition): PPerfInstanceDefinition;
var
  PerfCntrBlk: PPerfCounterBlock;
begin
  PerfCntrBlk := PPerfCounterBlock(DWORD(PerfInst) + PerfInst.ByteLength);
  Result := PPerfInstanceDefinition(DWORD(PerfCntrBlk) + PerfCntrBlk.ByteLength);
end;


function FirstCounter(PerfObj: PPerfObjectType): PPerfCounterDefinition;
begin
  Result := PPerfCounterDefinition(DWORD(PerfObj) + PerfObj.HeaderLength);
end;


function NextCounter(PerfCntr: PPerfCounterDefinition): PPerfCounterDefinition;
begin
  Result := PPerfCounterDefinition(DWORD(PerfCntr) + PerfCntr.ByteLength);
end;


{Registry helpers}

function GetPerformanceKey(const Machine: string): HKey;
var
  s: string;
begin
  Result := 0;
  if Length(Machine) = 0 then
    Result := HKEY_PERFORMANCE_DATA
  else
  begin
    s := Machine;
    if Pos('\\', s) <> 1 then
      s := '\\' + s;
    if RegConnectRegistry(PChar(s), HKEY_PERFORMANCE_DATA, Result) <> ERROR_SUCCESS then
      Result := 0;
  end;
end;


{TPerfObject}

constructor TPerfObject.Create(const AMachine: string; AObjectID: DWORD);
begin
  inherited Create;
  FList := TList.Create;
  FMachine := AMachine;
  FObjectID := AObjectID;
  ReadInstances;
end;


destructor TPerfObject.Destroy;
var
  i: Integer;
begin
  for i := 0 to FList.Count - 1 do
    TPerfInstance(FList[i]).Free;
  FList.Free;
  inherited Destroy;
end;


function TPerfObject.GetCount: Integer;
begin
  Result := FList.Count;
end;


function TPerfObject.GetInstance(Index: Integer): TPerfInstance;
begin
  Result := FList[Index];
end;


procedure TPerfObject.ReadInstances;
var
  PerfData: PPerfDataBlock;
  PerfObj: PPerfObjectType;
  PerfInst: PPerfInstanceDefinition;
  PerfCntr, CurCntr: PPerfCounterDefinition;
  PtrToCntr: PPerfCounterBlock;
  BufferSize: Integer;
  i, j, k: Integer;
  pData: PLargeInteger;
  Key: HKey;
  CurInstance: TPerfInstance;
begin
  for i := 0 to FList.Count - 1 do
    TPerfInstance(FList[i]).Free;
  FList.Clear;
  Key := GetPerformanceKey(FMachine);
  if Key = 0 then Exit;
  PerfData := nil;
  try
    {Allocate initial buffer for object information}
    BufferSize := 65536;
    GetMem(PerfData, BufferSize);
    {retrieve data}
    while RegQueryValueEx(Key,
      PChar(IntToStr(FObjectID)),  {Object name}
      nil, nil, Pointer(PerfData), @BufferSize) = ERROR_MORE_DATA do
    begin
      {buffer is too small}
      Inc(BufferSize, 1024);
      ReallocMem(PerfData, BufferSize);
    end;
    RegCloseKey(HKEY_PERFORMANCE_DATA);
    {Get the first object type}
    PerfObj := FirstObject(PerfData);
    {Process all objects}
    for i := 0 to PerfData.NumObjectTypes - 1 do
    begin
      {Check for requested object}
      if PerfObj.ObjectNameTitleIndex = FObjectID then
      begin
        {Get the first counter}
        PerfCntr := FirstCounter(PerfObj);
        if PerfObj.NumInstances > 0  then
        begin
          {Get the first instance}
          PerfInst := FirstInstance(PerfObj);
          {Retrieve all instances}
          for k := 0 to PerfObj.NumInstances - 1 do
          begin
            {Create entry for instance}
            CurInstance := TPerfInstance.Create;
            CurInstance.FName := WideCharToString(PWideChar(DWORD(PerfInst) +
                                                      PerfInst.NameOffset));
            FList.Add(CurInstance);
            CurCntr := PerfCntr;
            {Retrieve all counters}
            SetLength(CurInstance.FCounters, PerfObj.NumCounters);
            for j := 0 to PerfObj.NumCounters - 1 do
            begin
              PtrToCntr := PPerfCounterBlock(DWORD(PerfInst) + PerfInst.ByteLength);
              pData := Pointer(DWORD(PtrToCntr) + CurCntr.CounterOffset);
              {Add counter to array}
              CurInstance.FCounters[j].Counter := CurCntr.CounterNameTitleIndex;
              CurInstance.FCounters[j].Value := pData^;
              {Get the next counter}
              CurCntr := NextCounter(CurCntr);
            end;
            {Get the next instance.}
            PerfInst := NextInstance(PerfInst);
          end;
        end;
      end;
      {Get the next object type}
      PerfObj := NextObject(PerfObj);
    end;
  finally
    {Release buffer}
    FreeMem(PerfData);
    {Close remote registry handle}
    if Key <> HKEY_PERFORMANCE_DATA then
      RegCloseKey(Key);
  end;
end;


procedure GetProcesses(const Machine: string; List: TStrings);
var
  Processes: TPerfObject;
  i, j: Integer;
  ProcessID: DWORD;
begin
  Processes := nil;
  List.Clear;
  try
    Processes := TPerfObject.Create(Machine, 230);  {230 = Process}
    for i := 0 to Processes.Count - 1 do
      {Find process ID}
      for j := 0 to Length(Processes[i].Counters) - 1 do
        if (Processes[i].Counters[j].Counter = 784) then
        begin
          ProcessID := Processes[i].Counters[j].Value;
          if ProcessID <> 0 then
            List.AddObject(Processes[i].Name, Pointer(ProcessID));
          Break;
        end;
  finally
    Processes.Free;
  end;
end;

end.

---

ايجاد يك TWebBrowser در RunTime

کد:

---

procedure TForm1.Button1Click(Sender: TObject);
var
 wb: TWebBrowser;
begin
  wb := TWebBrowser.Create(Form1);
  TWinControl(wb).Name := 'MyWebBrowser';
  TWinControl(wb).Parent := Form1;
  wb.Align := alClient;
  // TWinControl(wb).Parent := TabSheet1; ( To put it on a TabSheet )
  wb.Navigate('http://www.swissdelphicenter.ch');
end;

---

استفاده از ClientSocket و ServerSocket

کد:

---

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, ScktComp;

type
  TForm1 = class(TForm)
    Clientsocket1: TClientSocket;
    StatusBar1: TStatusBar;
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    Label1: TLabel;
    Button3: TButton;
    CheckBox1: TCheckBox;
    Checkbox2: TCheckBox;
    procedure Button1Click(Sender : TObject);
    procedure Button2Click(Sender : TObject);
    procedure Clientsocket1Error(Sender : TObject; Socket : TCustomWinSocket;
      ErrorEvent : TErrorEvent; var ErrorCode : integer);
    procedure Clientsocket1Disconnect(Sender : TObject;
      Socket : TCustomWinSocket);
    procedure Clientsocket1Connect(Sender : TObject;
      Socket : TCustomWinSocket);
    procedure Button3Click(Sender : TObject);
    procedure FormClose(Sender : TObject; var Action : TCloseAction);
    procedure FormDestroy(Sender : TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1 : TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender : TObject);
begin
  Clientsocket1.Active := True;
end;

procedure TForm1.Button2Click(Sender : TObject);
begin
  Clientsocket1.Active := False;
end;

procedure TForm1.Clientsocket1Error(Sender : TObject;
  Socket : TCustomWinSocket; ErrorEvent : TErrorEvent;
  var ErrorCode : integer);
begin
  errorcode := 0;
  StatusBar1.SimpleText := 'Error';
end;

procedure TForm1.Clientsocket1Disconnect(Sender : TObject;
  Socket : TCustomWinSocket);
begin
  StatusBar1.SimpleText := 'Disconnect';
end;

procedure TForm1.Clientsocket1Connect(Sender : TObject;
  Socket : TCustomWinSocket);
begin
  StatusBar1.SimpleText := Clientsocket1.Address;
end;

procedure TForm1.Button3Click(Sender : TObject);
var
  ukaz : string;
  orders : string;
  Text : string;
  box : string;
begin
  ukaz := edit1.Text;
  Clientsocket1.Socket.SendText(ukaz);
  if checkbox1.Checked = True then
  begin
    orders := 'power';
    Clientsocket1.Socket.SendText(orders);
  end;
  if Checkbox2.Checked = True then
  begin
    Text := 'reset';
    Clientsocket1.Socket.SendText(Text);
  end;
end;

procedure TForm1.FormClose(Sender : TObject; var Action : TCloseAction);
begin
  Clientsocket1.Active := False;
end;

procedure TForm1.FormDestroy(Sender : TObject);
begin
  Clientsocket1.Active := False;
end;

end.


// Client Program

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ScktComp, StdCtrls, ShellApi;

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Serversocket1: TServerSocket;
    procedure FormClose(Sender : TObject; var Action : TCloseAction);
    procedure FormDestroy(Sender : TObject);
    procedure FormCreate(Sender : TObject);
    procedure Serversocket1ClientError(Sender : TObject;
      Socket : TCustomWinSocket; ErrorEvent : TErrorEvent;
      var ErrorCode : integer);
    procedure Serversocket1ClientRead(Sender : TObject;
      Socket : TCustomWinSocket);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1 : TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormClose(Sender : TObject; var Action : TCloseAction);
begin
  Serversocket1.Active := False;
end;

procedure TForm1.FormDestroy(Sender : TObject);
begin
  Serversocket1.Active := False;
end;

procedure TForm1.FormCreate(Sender : TObject);
begin
  Serversocket1.Active := True;
end;

procedure TForm1.Serversocket1ClientError(Sender : TObject;
  Socket : TCustomWinSocket; ErrorEvent : TErrorEvent;
  var ErrorCode : integer);
begin
  errorcode := 0;
end;

procedure TForm1.Serversocket1ClientRead(Sender : TObject;
  Socket : TCustomWinSocket);
var
  ukaz : string;
  orders : string;
  Text : string;
  box : string;
begin
  ukaz := socket.ReceiveText;
  label1.Caption := 'reciving...';
  ShellExecute(Handle, 'open', PChar(ukaz), PChar(''), nil, sw_show);
  Text := socket.ReceiveText;
  orders := socket.ReceiveText;
  if orders = 'power' then
  begin
    ShellExecute(Handle, 'open', PChar('shutdown.exe'), PChar('-s'), nil, sw_show);
    Application.MessageBox('You will be turned off', 'Warning', mb_iconexclamation);
    Serversocket1.Active := False;
    Form1.Close;
  end;
  if Text = 'reset' then
  begin
    ShellExecute(Handle, 'open', PChar('shutdown.exe'), PChar('-r'), nil, sw_show);
    Application.MessageBox('You will be reset', 'Warning', mb_iconexclamation);
    Serversocket1.Active := False;
    Form1.Close;
  end;
end;


end.

---

بدست آوردن ليست كاربران موجود در شبكه Remote

کد:

---

unit GetUser;

interface

uses
  Windows
    , Messages
    , SysUtils
    , Dialogs;

type
  TServerBrowseDialogA0 = function(hwnd: HWND; pchBuffer: Pointer;
    cchBufSize: DWORD): bool;
  stdcall;
  ATStrings = array of string;


procedure Server(const ServerName: string);
function ShowServerDialog(AHandle: THandle): string;


implementation

uses Client, ClientSkin;

procedure Server(const ServerName: string);
const
  MAX_NAME_STRING = 1024;
var 
  userName, domainName: array[0..MAX_NAME_STRING] of Char;
  subKeyName: array[0..MAX_PATH] of Char;
  NIL_HANDLE: Integer absolute 0;
  Result: ATStrings;
  subKeyNameSize: DWORD;
  Index: DWORD;
  userNameSize: DWORD;
  domainNameSize: DWORD;
  lastWriteTime: FILETIME;
  usersKey: HKEY;
  sid: PSID;
  sidType: SID_NAME_USE;
  authority: SID_IDENTIFIER_AUTHORITY;
  subAuthorityCount: BYTE;
  authorityVal: DWORD;
  revision: DWORD;
  subAuthorityVal: array[0..7] of DWORD;


  function getvals(s: string): Integer;
  var 
    i, j, k, l: integer;
    tmp: string;
  begin
    Delete(s, 1, 2);
    j  := Pos('-', s);
    tmp := Copy(s, 1, j - 1);
    val(tmp, revision, k);
    Delete(s, 1, j);
    j := Pos('-', s);
    tmp := Copy(s, 1, j - 1);
    val('$' + tmp, authorityVal, k);
    Delete(s, 1, j);
    i := 2;
    s := s + '-';
    for l := 0 to 7 do 
    begin
      j := Pos('-', s);
      if j > 0 then 
      begin
        tmp := Copy(s, 1, j - 1);
        val(tmp, subAuthorityVal[l], k);
        Delete(s, 1, j);
        Inc(i);
      end 
      else 
        break;
    end;
    Result := i;
  end;
begin
  setlength(Result, 0);
  revision    := 0;
  authorityVal := 0;
  FillChar(subAuthorityVal, SizeOf(subAuthorityVal), #0);
  FillChar(userName, SizeOf(userName), #0);
  FillChar(domainName, SizeOf(domainName), #0);
  FillChar(subKeyName, SizeOf(subKeyName), #0);
  if ServerName <> '' then 
  begin
    usersKey := 0;
    if (RegConnectRegistry(PChar(ServerName), HKEY_USERS, usersKey) <> 0) then
      Exit;
  end 
  else 
  begin
    if (RegOpenKey(HKEY_USERS, nil, usersKey) <> ERROR_SUCCESS) then
      Exit;
  end;
  Index          := 0;
  subKeyNameSize := SizeOf(subKeyName);
  while (RegEnumKeyEx(usersKey, Index, subKeyName, subKeyNameSize,
    nil, nil, nil, @lastWriteTime) = ERROR_SUCCESS) do 
  begin
    if (lstrcmpi(subKeyName, '.default') <> 0) and (Pos('Classes', string(subKeyName)) = 0) then 
    begin
      subAuthorityCount := getvals(subKeyName);
      if (subAuthorityCount >= 3) then 
      begin
        subAuthorityCount := subAuthorityCount - 2;
        if (subAuthorityCount < 2) then subAuthorityCount := 2;
        authority.Value[5] := PByte(@authorityVal)^;
        authority.Value[4] := PByte(DWORD(@authorityVal) + 1)^;
        authority.Value[3] := PByte(DWORD(@authorityVal) + 2)^;
        authority.Value[2] := PByte(DWORD(@authorityVal) + 3)^;
        authority.Value[1] := 0;
        authority.Value[0] := 0;
        sid := nil;
        userNameSize := MAX_NAME_STRING;
        domainNameSize := MAX_NAME_STRING;
        if AllocateAndInitializeSid(authority, subAuthorityCount,
          subAuthorityVal[0], subAuthorityVal[1], subAuthorityVal[2],
          subAuthorityVal[3], subAuthorityVal[4], subAuthorityVal[5],
          subAuthorityVal[6], subAuthorityVal[7], sid) then 
        begin
          if LookupAccountSid(PChar(ServerName), sid, userName, userNameSize,
            domainName, domainNameSize, sidType) then 
          begin
            setlength(Result, Length(Result) + 1);
            Result[Length(Result) - 1] := string(domainName) + '\' + string(userName);

            // Hier kann das Ziel eingetragen werden
            Form1.label2.Caption := string(userName);
            form2.label1.Caption := string(userName);
          end;
        end;
        if Assigned(sid) then FreeSid(sid);
      end;
    end;
    subKeyNameSize := SizeOf(subKeyName);
    Inc(Index);
  end;
  RegCloseKey(usersKey);
end;

function ShowServerDialog(AHandle: THandle): string;
var
  ServerBrowseDialogA0: TServerBrowseDialogA0;
  LANMAN_DLL: DWORD;
  buffer: array[0..1024] of char;
  bLoadLib: Boolean;
begin
  bLoadLib := False;
  LANMAN_DLL := GetModuleHandle('NTLANMAN.DLL');
  if LANMAN_DLL = 0 then
  begin
    LANMAN_DLL := LoadLibrary('NTLANMAN.DLL');
    bLoadLib := True;
  end;
  if LANMAN_DLL <> 0 then
  begin @ServerBrowseDialogA0 := GetProcAddress(LANMAN_DLL, 'ServerBrowseDialogA0');
    DialogBox(HInstance, MAKEINTRESOURCE(101), AHandle, nil);
    ServerBrowseDialogA0(AHandle, @buffer, 1024);
    if buffer[0] = '\' then
    begin
      Result := buffer;
    end;
    if bLoadLib = True then
      FreeLibrary(LANMAN_DLL);
  end;
end;


end.

---

چاپ يك صفحه در TwebBrowser

کد:

---

procedure TForm1.Button1Click(Sender: TObject);
begin
  WebBrowser1.Navigate('http://www.SwissDelphiCenter.com');
end;

// Print without Printer Dialog
// Drucken ohne Druckerauswahldialog

procedure TForm1.Button2Click(Sender: TObject);
var
  vaIn, vaOut: OleVariant;
begin
  WebBrowser1.ControlInterface.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER,
    vaIn, vaOut);
end;

// Print with Printer Dialog
// Drucken mit Druckerauswahldialog

procedure TForm1.Button3Click(Sender: TObject);
var
  vaIn, vaOut: OleVariant;
begin
  WebBrowser1.ControlInterface.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_PROMPTUSER,
    vaIn, vaOut);
end;

// Print Preview
// Druckvorschau

procedure TForm1.Button4Click(Sender: TObject);
var
  vaIn, vaOut: OleVariant;
begin
  WebBrowser1.ControlInterface.ExecWB(OLECMDID_PRINTPREVIEW,
    OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
end;

// Page Setup Dialog
// Seite einrichten Dialog

procedure TForm1.Button5Click(Sender: TObject);
var
  vaIn, vaOut: OleVariant;
begin
  WebBrowser1.ControlInterface.ExecWB(OLECMDID_PAGESETUP, OLECMDEXECOPT_PROMPTUSER,
    vaIn, vaOut);
end;

---

انتخاب يك كامپيوتر در شبكه

کد:

---

type
  TServerBrowseDialogA0 = function(hwnd: HWND; pchBuffer: Pointer; cchBufSize: DWORD): bool; 
  stdcall;


function ShowServerDialog(AHandle: THandle): string;
var
  ServerBrowseDialogA0: TServerBrowseDialogA0;
  LANMAN_DLL: DWORD;
  buffer: array[0..1024] of char;
  bLoadLib: Boolean;
begin
  LANMAN_DLL := GetModuleHandle('NTLANMAN.DLL');
  if LANMAN_DLL = 0 then
  begin
    LANMAN_DLL := LoadLibrary('NTLANMAN.DLL');
    bLoadLib := True;
  end;
  if LANMAN_DLL <> 0 then
  begin @ServerBrowseDialogA0 := GetProcAddress(LANMAN_DLL, 'ServerBrowseDialogA0');
    DialogBox(HInstance, MAKEINTRESOURCE(101), AHandle, nil);
    ServerBrowseDialogA0(AHandle, @buffer, 1024);
    if buffer[0] = '\' then
    begin
      Result := buffer;
    end;
    if bLoadLib then
      FreeLibrary(LANMAN_DLL);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  label1.Caption := ShowServerDialog(Form1.Handle);
end;

---

لود كردن يك كد html بصورت مستقيم در TWebBrowser

کد:

---

uses
  ActiveX;

procedure WB_LoadHTML(WebBrowser: TWebBrowser; HTMLCode: string);
var
  sl: TStringList;
  ms: TMemoryStream;
begin
  WebBrowser.Navigate('about:blank');
  while WebBrowser.ReadyState < READYSTATE_INTERACTIVE do
  Application.ProcessMessages;

  if Assigned(WebBrowser.Document) then
  begin
    sl := TStringList.Create;
    try
      ms := TMemoryStream.Create;
      try
        sl.Text := HTMLCode;
        sl.SaveToStream(ms);
        ms.Seek(0, 0);
        (WebBrowser.Document as IPersistStreamInit).Load(TStreamAdapter.Create(ms));
      finally
        ms.Free;
      end;
    finally
      sl.Free;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  WB_LoadHTML(WebBrowser1,'SwissDelphiCenter');
end;

---

ارسال پيام در ICQ

کد:

---

var
  Form1: TForm1;
  csend: string;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
  cSend := 'POST http://wwp.icq.com/scripts/WWPMsg.dll HTTP/2.0' + chr(13) + chr(10);
  cSend := cSend + 'Referer: http://wwp.mirabilis.com' + chr(13) + chr(10);
  cSend := cSend + 'User-Agent: Mozilla/4.06 (Win95; I)' + chr(13) + chr(10);
  cSend := cSend + 'Connection: Keep-Alive' + chr(13) + chr(10);
  cSend := cSend + 'Host: wwp.mirabilis.com:80' + chr(13) + chr(10);
  cSend := cSend + 'Content-type: application/x-www-form-urlencoded' + chr(13) + chr(10);
  cSend := cSend + 'Content-length:8000' + chr(13) + chr(10);
  cSend := cSend + 'Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, */*' +
    chr(13) + chr(10) + chr(13) + chr(10);
  cSend := cSend + 'from=' + edit1.Text + ' &fromemail=' + edit2.Text +
    ' &fromicq:110206786' + ' &body=' + memo1.Text + ' &to=' + edit3.Text + '&Send=';
  clientsocket1.Active := True;
end;

procedure TForm1.ClientSocket1Connect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  clientsocket1.Socket.SendText(csend);
  clientsocket1.Active := False;
end;

---

تبديل يك فايل CSV به XML

کد:

---

procedure CSVToXML(const csvfilename, xmlfilename: string;
  const aSeparator: Char;
  const aRootNodeName: string;
  const columnnames: TStrings = nil;
  const onProgress: TProgressNotification = nil);

  function DoProgress(currentline, totallines: Integer): Boolean;
  begin
    if Assigned(onProgress) then
      Result := onProgress(currentline, totallines)
    else
      Result := true;
  end;

  procedure WriteDataline(const line: string; header: TStringlist; xml: TXMLGenerator);
  var
    elements: TStringlist;
    i, max: Integer;
  begin
    elements := TStringlist.Create;
    try
      elements.Delimiter := aSeparator;
      elements.Delimitedtext := line;
      if elements.count > header.count then
        max := header.count
      else
        max := elements.count;
      for i := 0 to max - 1 do begin
        xml.StartTag(header[i]);
        xml.AddData(elements[i]);
        xml.StopTag;
      end; { For }
    finally
      elements.Free;
    end;
  end;

  procedure WriteData(data: TStringlist; xml: TXMLGenerator);
  var
    header: TStringlist;
    firstline: Integer;
    i: Integer;
  begin
    header := Tstringlist.Create;
    try
      firstline := 0;
      if assigned(columnnames) then
        header.Assign(columnnames)
      else begin
        header.Delimiter := aSeparator;
        header.DelimitedText := data[0];
        firstline := 1;
      end; { Else }
      for i := firstline to data.count - 1 do begin
        WriteDataline(data[i], header, xml);
        if not DoProgress(i, data.count) then
          Break;
      end; { For }
    finally
      header.Free;
    end;
  end;

  procedure SaveStringToFile(const S, filename: string);
  var
    fs: TFilestream;
  begin
    fs := TFileStream.Create(filename, fmCreate);
    try
      if Length(S) > 0 then
        fs.WriteBuffer(S[1], Length(S));
    finally
      fs.free
    end;
  end; { SaveStringToFile }


var
  xml: TXMLGenerator; // from xml_generator unit by Berend de Boers
  datafile: Tstringlist;
begin { CSVToXML }
  if not FileExists(csvfilename) then
    raise Exception.CreateFmt('Input file %s not found', [csvfilename]);
  datafile := Tstringlist.Create;
  try
    datafile.LoadfromFile(csvfilename);
    xml := TXMLGenerator.CreateWithEncoding(16 * 1024, encISO_8859_1);
    try
      xml.StartTag(aRootNodeName);
      if datafile.count > 0 then
        WriteData(datafile, xml);
      xml.StopTag;
      SaveStringToFile(xml.AsLatin1, xmlfilename);
    finally
      xml.Free;
    end;
  finally
    datafile.free;
  end;
end; { CSVToXML }

---

ليست تمام فايلهاي موجود در يك دايركتوري

کد:

---

procedure ListFileDir(Path: string; FileList: TStrings);
var
  SR: TSearchRec;
begin
  if FindFirst(Path + '*.*', faAnyFile, SR) = 0 then
  begin
    repeat
      if (SR.Attr <> faDirectory) then
      begin
        FileList.Add(SR.Name);
      end;
    until FindNext(SR) <> 0;
    FindClose(SR);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ListFileDir('C:\WINDOWS\', ListBox1.Items);
end;

---