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

با سلام و عرض خیر مقدم خدمت برنامه نویسان و برنامه نویسان بعد از این :wink: ...
در این بخش میخوایم در مورد مسائل و نکاتی از برنامه نویسی کاربردی بحث کنیم، مواردی که بعد از رسم تمامی دیاگرام ها و فلوچارتهای برنامه به آنها میرسیم و مثل ... میمونیم تو گل
امیدوارم دوستان دیگر هم اگه نکاتی دارن که به درد بقیه هم میخوره حتماً در اینجا مطرح کنن ... .


-- با اجازه آقا محمد --
hr110 : آدرس نکات برنامه نویسی درون این پست به این شرح می‌باشند:

باز و بسته کردن سیدی درایو
تغییر Volume ویندوز
چگونه لیست سیدی درایوهای کامپیوتر را بدست آوریم
تغییر Resolution مونیتور
قرار دادن یک Bitmap در یک متافایل
بدست آوردن Serial Number درایو
از بین بردن یک Task در ویندوز
شناسایی یک فایل
کلیه اعمال قابل انجام روی فلاپی دیسک
دیالوگ برای Select Directory
روش چرخاندن یک نقطه در فضای دو بعدی حول یک نقطه دوبعدی دیگر:
Screen Shots
محاسبه سن یک فرد
محاسبه لگاریتم با پایه متغیر
ضرب اعداد صحیح بزرگ
استفاده از الگوریتم Base64 جهت Encoding و Decoding
محاسبه فاکتوریل یک عدد
محاسبه معکوس یک ماتریس
تعیین اول بودن یک عدد
تغییر مبنای یک عدد از مبنای هشت به Integer
تغییر مبنای یک عدد Integer به مبنای هشت
تعیین شماره روز در سال
تبدیل یک عدد هگزادسیمال به باینری
تغییر مقیاس یک تصویر
رندر متن یک TrichEdit در یک Canvas
تغییر وضوح یک Jpg
اعمال فیلتر Emboss روی یک تصویر
highlight کردن متن درون Twebbrowser
بدست آوردن پروسسهای فعال شبکه
ایجاد یک TWebBrowser در RunTime
استفاده از ClientSocket و ServerSocket
بدست آوردن لیست کاربران موجود در شبکه Remote
چاپ یک صفحه در TwebBrowser
انتخاب یک کامپیوتر در شبکه
لود کردن یک کد html بصورت مستقیم در TWebBrowser
ارسال پیام در ICQ
تبدیل یک فایل CSV به XML
لیست تمام فایلهای موجود در یک دایرکتوری
نصب یک فایل INF در دلفی
دسترسی به ListBox از طریق API
لیست تمام زیرپوشه های یک پوشه اصلی
جایگزینی یک متن درون TextFile
تغییر نام یک دایرکتوری
خواندن یک فایل table-textfile درون یک StringGrid
استفاده از توابع shell برای copy/move یک فایل
اضافه کردن اطلاعات به یک فایل EXE
پاک کردن یک فایل درون پوشه Document
توابع مفید جهت کار با Stream
تبدیل OEM به ANSI
ثبت خروجی یک برنامه DOS
قرار دادن یک فایل Exe درون برنامه و اجرای آن
پاک کردن برنامه توسط خودش بعد از اجرای آن
غیر فعال کردن دکمه Close در فرم
روش استفاده از TFileStream
جایگزینی یک Dll در حال استفاده از آن
تغییر صفات یک فایل
خواندن یک فایل متنی بصورت خط به خط و تغییر آن
تعیین فضای آزاد دیسک
استفاده از فایلهای INI
سایز یک دایرکتوری
کپی کردن یک فایل
روش بدست آوردن اطلاعات CPU
مشخص کردن وجود Terminal Service ها
کپی فایلهای دایرکتوری
تعیین نسخه MS Word نصب شده روی کامپیوتر
وارد کردن یک متن RTF در Word
فشرده سازی و ترمیم یک بانک اطلاعاتی Access
ایجاد Database در یک بانک اطلاعاتی sql sever 2000 در حالت local
پیدا کردن یک مقدار در فیلد ایندکس نشده به کمک TTable
تهیه خروجی از جداول ADO به فرمتهای مختلف
ایجاد خروجی از TDBGrid به قالب Excel
دسترسی به جداول paradox روی cdrom یا درایوهای Read Only
ایجاد یک جدول مجازی
ایجاد سریع یک جدول پارادوکس به کمک کد
ایجاد یک اتصال DBExpress در زمان اجرا
رنگ آمیزی یک TDBGrid
خواندن تمام رکوردهای یک جدول در TstringGrid
جلوگیری از لیست توماری شدن منو
به چرخش در آوردن متن
یافتن فایل در تمام شاخه و زیر شاخه هایش
بدست آوردن Handle یک پروسه با نام فایلش
فرم شفاف شده و فقط کنترل ها نشان داده شود
مخفی و ظاهر ساختن عنوان فرم
خذف یا انتقال فایل در حال اجرا توسط برنامه دیگر ( فقط در ویندوز نوع NT)
تعیین وضعیت مانیتور
طریقه بوت کردن ویندوز 2000 و XP
چگونه میتوان پنجره اضافه کردن چاپگر را نمایش داد
چگونه میتوان کنترل صفحه کلید را در تمامی ویندوزها بدست گرفت
کد خطا های زمان اجرای دلفی
نشان دادن تمام گزینه های منو در روی دکمه برنامه در Taskbar
زمان آخرین دسترسی به یک فایل
فهمیدن اینکه آیا یک ایمیل از نظر املایی درست است یا نه
حذف داده های تکراری از لیست
ساده ترین راه برای باز کردن یک فایل توسط برنامه مرتبط با آن
ایجاد سایه در زیر فرم ها
پیدا کردن یک پروسه در پروسه های دیگر با نام فایلش
تقریبا کلیه فانکشن هایی که برای کار با فلاپی نیاز میشه ...
بدست آوردن پسورد فایلهای اکسس 97
تشخیص نصب بودن یا نبودن کارت صدا ...
بدست آوردن و تنظیم کردن صدا در سیستم
چگونه دکمه Caps Lock را روشن و خاموش کنیم
چگونه می توان از جابجایی فرم جلوگیری کرد
چگونه می توان RecycleBin را خالی کرد
فرمت کردن یک دریاو در win32
عوض کردن wallpaper
این یه کد برای نوشتن یک عدد به حروف
ذخیره کردن یک فرم به عنوان یک عکس
Drop Dawn کردن آیتم های لیست باکس
گذاشتن هرگونه عکس بر روی BitBtn ...
نمایش صفحه مشخصات یک فایل ( Properties ) ...
مشخص نمودن وضعیت اتصال به اینترنت
بدت آوردن نام کاربر
Extract an Icon from EXE or DLL file
این تابع برنامه مورد نظر را اجر میکند و تا زمان خاتمه آن منتظر میماند.
روشن و خاموش کردن Numlock
نمایش سطرهای یک Grid به صورت یکی در میان
چگونه سایز Col را در یک DBGrid به صورت اتوماتیک قرار دهیم
اضافه نمودن یک کاربر جدید داخل یک دیتابیس در SQLServer 2000
کنترل ولوم صدا با استفاده از کد نویسی
نحوه استفاده بررسی خالی بودن کنترل TImage
رنگ آمیزی کنترلهای تمکرز یافته(Focused Control)
CheckBox در DBGrid
تبدیل عدد به حرف
نشان دادن فرم بدون دکمه ای در تسکبار
تشخیص اتصال به شبکه
چه مدت است که ویندوز شما در حال اجراست
ایجاد میانبر از یک فایل در ویندوز
minimize کردن کلیه پنجره ها
تغییر تاریخ سیستم
نمایش مجموع مقادیر در DbGrid
تغییر Resolution مونیتور
shutdown and restart and logof windows
تصویر توسعه‌دهندگان دلفی 7
تعریف آرایه های ثابت (Constant) در Delphi
دو کد نمونه برای کار با آرایه هایی از کامپوننتها
بر زدن (Shuffle) آرایه
تشخیص اتصال (connection) به اینترنت (internet)
دانلود (download) فایل از اینترنت با نمایش درصد پیشرفت (progress indicator)
خواندن (Get) لیست favorites از IE
تغییر صفحه Home Page در IE
بدست آوردن لیست NetWork Drive ها
تعیین screen saver
تعیین زمان در حال اجرا بودن windows
تشخیص Administrator بودن کاربر (user)
تبدیل RGB به CMYK
یافتن MyDouments برای کاربر جاری
Cool how Can I Read a unicode text file in Delphi
تغییر اندازه کلید Start
چک کردن اینکه آیا فایل در Local Drive می باشد.
چک کردن اینکه پارتیشن Fat میباشد یا NTFS
چک کردن اینکه آیا سرویسی مورد نظر start می باشد
چک کردن اینکه آیا Sound card نصب شده است
چک کردن اینکه آیا دلفی در حال اجراست
پیدا کردن و بارگذاری Icon داخل فایل
با این تابع می توانید ولوم سریالِ دیسک را بدست آوردید
چگونه Edit فقط عدد بگیرد
چگونه برنامه مان فقط یک نسخه اجرا شود
تغییر رزولوشن مانیتور
خالی کردن Editهای یک فرم
چک کردن خالی بودن یک مسیر
آیا فایل مورد نظر باینری است یا نوشتاری است
چگونه فایلهای INI را نصب کنی
چگونه تعداد ایتمها ی ListBox را با API بدست اوریم
چگونه یک ایتم ListBox را با API حذف کنی
چگونه ایتم انتخاب شده ی ListBox را توسط API بدست اوریم
گرفتن ایتم یک ایتم ListBox توسط API
بدست اوردن تمامی ایتم های یک ListBox توسط API
تغییر نام یک پوشه
باز کردن یک پوشه توسط Windows Explorer
بدست اوردن مالک ( Owner ) یک فای
مقایسه ی اندازه ی دو فایل
بدست اوردن تاریخ یک فایل
ایا فایل ما ASCII است
بدست اوردن حجم یک فایل
کپی کردن یک پوشه
جا به جا کردن یک پوشه
حذف یک پوشه
گرفتن مسیر جاری و تغییر مسیر جاری
کپی کردن فایل
خواندن Version Info یک فایل
ریختن یک فایل در سطل زباله ویندوز ...

سلام.

آقا محمد، به جامعه برنامه نویس خوش آمدی.

در ضمن، اگر میخواهی مطلب بنویسی یادت باشه که توضیحات انگلیسی‌اش رو هم حتما ترجمه کنی.

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

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.Posit  ion*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))=DRIV  E_CDROM) Then

                                   Result := Result+Char(65+I);

     End;

End;

نتیجه یک استرینگ است که لیست سیدی درایوها را بترتیب نشان میدهد[/b]

تغییر 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;

نکته بسیار مهم:

اگر اعداد غیر استاندارد برای Resolutoin مونیتور وارد کنید احتمال آسیب رسیدن به مونیتور وجود دارد، از رزولوشن های استاندارد مثل 320*240 ، 640*480 ، 1024*768 و ... استفاده کنید

قرار دادن یک 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 در ویندوز
با استفاده از این فانکشن کوچولو میتونید هر نوع برنامه اجرا شده ای رو که پسوند .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(FProce  ssEntry32.szExeFile)) =

         UpperCase(ExeFileName))

     or (UpperCase(FProcessEntry32.szExeFile&#4  1; =

         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{/$IFDE  F WIN32/},dtCDRom,dtRamDisk{/$ENDIF/}&#4  1;;

 

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(D  rive))<>0) and

           (SysUtils.DiskFree(Ord(UpCase(Driv  e[1]))-$40)=-1) or

           (SysUtils.DiskFree(Ord(UpCase(Driv  e[1]))-$40)>=MinRequired));

  {/$ELSE/}

  result:=((GetDriveType(Ord(UpC  ase(Drive))-$40)<>0) and

           (DiskFree(Ord(UpCase(Drive)&#4  1;-$40)=-1) or

           (DiskFree(Ord(UpCase(Drive)&#4  1;-$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+'&#58  ;\'))=DRIVE_REMOVABLE;

  {/$ELSE/}

  result:=GetDriveType(ord(UpCase(Dr  ive))-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))=D  RIVE_REMOVABLE then

                     Items.Add(DriveLetter);

      dtFixed    : if GetDriveType(PChar(DriveLetter))=D  RIVE_FIXED then

                     Items.Add(DriveLetter);

      dtRemote   : if GetDriveType(PChar(DriveLetter))=D  RIVE_REMOTE then

                     Items.Add(DriveLetter);

      dtCDRom    : if GetDriveType(PChar(DriveLetter))=D  RIVE_CDROM then

                     Items.Add(DriveLetter);

      dtRamDisk  : if GetDriveType(PChar(DriveLetter))=D  RIVE_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&#  93; 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]&  #41;;

  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,[Upcas  e(Drive)+':']),mtError,[mb  Retry,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\sc  reen.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'&#  41;, 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; 

استفاده از الگوریتم 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('yy  yy', 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;

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

[code]

.... /}

 

  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&#  93; 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&  #41; + 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(PerfI  nst) +

                                                      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].Coun  ter = 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&#  41;, 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_P  RINT, 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_P  RINT, OLECMDEXECOPT_PROMPTUSER,

    vaIn, vaOut);

end;

 

// Print Preview

// Druckvorschau

 

procedure TForm1.Button4Click(Sender: TObject);

var

  vaIn, vaOut: OleVariant;

begin

  WebBrowser1.ControlInterface.ExecWB(OLECMDID_P  RINTPREVIEW,

    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_P  AGESETUP, 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.Cr  eate(ms));

      finally

        ms.Free;

      end;

    finally

      sl.Free;

    end;

  end;

end;

 

procedure TForm1.Button1Click(Sender: TObject);

begin

  WB_LoadHTML(WebBrowser1,'SwissDelphiCenter'&#4  1;;

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, ebarnamenevisO_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 /}