صفحه 1 از 11 123 ... آخرآخر
نمایش نتایج 1 تا 40 از 435

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

  1. #1

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

    با سلام و عرض خیر مقدم خدمت برنامه نویسان و برنامه نویسان بعد از این :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 یک فایل
    ریختن یک فایل در سطل زباله ویندوز ...
    آخرین ویرایش به وسیله hr110 : چهارشنبه 28 فروردین 1387 در 08:13 صبح

  2. #2
    بنیان گذار Barnamenevis آواتار مهدی کرامتی
    تاریخ عضویت
    اسفند 1381
    محل زندگی
    کرج، گلشهر
    سن
    46
    پست
    6,379
    سلام.

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

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

  3. #3

    باز و بسته کردن سیدی درایو

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


    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;



    اینجانب بدینوسیله آمادگی پذیرش هر نوع انتقاد، راهنمایی و پیشنهاد را اعلام میدارم ...
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 15:39 عصر

  4. #4

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

    تغییر 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 بازی کنید ...
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 15:40 عصر

  5. #5

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

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

    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]
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 15:41 عصر

  6. #6

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

    تغییر 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 و ... استفاده کنید
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 15:41 عصر

  7. #7

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

    قرار دادن یک 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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 15:42 عصر

  8. #8

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

    بدست آوردن 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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 15:42 عصر

  9. #9

    از بین بردن یک 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(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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 15:44 عصر

  10. #10

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

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

    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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 15:44 عصر

  11. #11

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

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

    ==================================================  ===========
    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.
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 15:47 عصر

  12. #12

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


    اضافه کردن تکست به 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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 15:50 عصر

  13. #13

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

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


    uses FileCtrl; // for SelectDirectory

    var
    Dir: string;
    (...)
    Dir := 'C:\Windows';
    if SelectDirectory(Dir, [sdAllowCreate, sdPerformCreate,
    sdPrompt], 0) then
    Label1.Caption := Dir;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 15:51 عصر

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

    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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 15:51 عصر

  15. #15

    Screen Shots

    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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 15:53 عصر

  16. #16
    محاسبه سن یک فرد
    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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 15:55 عصر

  17. #17
    محاسبه لگاریتم با پایه متغیر
    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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 15:55 عصر

  18. #18
    ضرب اعداد صحیح بزرگ
    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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 15:56 عصر

  19. #19
    استفاده از الگوریتم 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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 15:56 عصر

  20. #20
    محاسبه فاکتوریل یک عدد
    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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 15:57 عصر

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

    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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 15:59 عصر

  22. #22
    تعیین اول بودن یک عدد

    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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:00 عصر

  23. #23
    تغییر مبنای یک عدد از مبنای هشت به 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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:00 عصر

  24. #24
    تغییر مبنای یک عدد 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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:01 عصر

  25. #25
    تعیین شماره روز در سال
    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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:02 عصر

  26. #26
    تبدیل یک عدد هگزادسیمال به باینری
    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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:02 عصر

  27. #27
    تغییر مقیاس یک تصویر

    [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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:03 عصر

  28. #28
    رندر متن یک 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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:04 عصر

  29. #29
    تغییر وضوح یک 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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:05 عصر

  30. #30
    اعمال فیلتر 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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:06 عصر

  31. #31
    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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:06 عصر

  32. #32
    بدست آوردن پروسسهای فعال شبکه
    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.
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:07 عصر

  33. #33
    ایجاد یک 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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:08 عصر

  34. #34
    استفاده از 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.
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:10 عصر

  35. #35
    بدست آوردن لیست کاربران موجود در شبکه 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.
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:11 عصر

  36. #36
    چاپ یک صفحه در 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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:12 عصر

  37. #37
    انتخاب یک کامپیوتر در شبکه



    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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:14 عصر

  38. #38
    لود کردن یک کد 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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:14 عصر

  39. #39
    ارسال پیام در 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;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:15 عصر

  40. #40
    تبدیل یک فایل 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 /}
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:15 عصر

صفحه 1 از 11 123 ... آخرآخر

برچسب های این تاپیک

قوانین ایجاد تاپیک در تالار

  • شما نمی توانید تاپیک جدید ایجاد کنید
  • شما نمی توانید به تاپیک ها پاسخ دهید
  • شما نمی توانید ضمیمه ارسال کنید
  • شما نمی توانید پاسخ هایتان را ویرایش کنید
  •