صفحه 2 از 3 اولاول 123 آخرآخر
نمایش نتایج 41 تا 80 از 120

نام تاپیک: مرجع توابع دلفی

  1. #41

    Lightbulb توابع كار با فايل


    ChangeFileExt function
    Changes the extension part of a string containing full path and file name.
    ExcludeTrailingBackslash function
    Removes '\' from the end of a string if it is there.
    ExpandFileName function
    Retrieves the full path and filename of a specified (relative) file.
    ExpandUNCFileName function
    Retrieves the full path and filename of a specified (relative) file using Universal Naming Convention for network files.
    ExtractFileDir function
    Returns only only directory or drive information parts of a string containing full path and file name.
    ExtractFileDrive function
    Returns only drive part of a string containing full path and file name.
    ExtractFileName function
    Returns only file name and extension parts of a string containing full path and file name.
    ExtractFileExt function
    Returns the extension part of a string containing full path and file name.
    ExtractFilePath function
    Returns the drive and directory parts of a string containing full path and file name.
    ExtractShortPathName function
    Returns 8.3 format for a given full path and file name.
    MinimizeName function
    Returns a shortened version of a filename (using dots for folders) that fits into some pixel length.
    IncludeTrailingBackslash function
    Adds '\' to the end of a string if it is not already there.
    IsPathDelimiter function
    Returns true if a specified character in a string is the backslash (\) character.
    MatchesMask function
    Returns True is a string value matches a format specifed by a mask.
    ProcessPath procedure
    Parses a full file name into its drive, path, and file name.


  2. #42

    Lightbulb تابع جستجوي كلمه در داخل يك رشته



    function ExistWordInString(aString:PWideChar;aSearchString: string;aSearchOptions: TStringSearchOptions): Boolean;
    var
    Size : Integer;
    begin
    Size:=StrLen(aString);
    result := SearchBuf(aString, Size, 0, 0, aSearchString, aSearchOptions)<>nil;
    end;

  3. #43

    Lightbulb تابع چاپ مورب نوشته بر روي فرم


    procedure AngleTextOut(ACanvas: TCanvas;Angle,X,Y: Integer;Str: string);
    var
    LogRec : TLogFont;
    OldFontHandle,NewFontHandle :HFONT;
    begin
    GetObject(ACanvas.Font.Handle,SizeOf(LogRec),Addr( LogRec));
    LogRec.lfEscapement := Angle * 10;
    NewFontHandle := CreateFontIndirect(LogRec);
    OldFontHandle := SelectObject(ACanvas.Handle,NewFontHandle);
    ACanvas.TextOut(X,Y,str);
    NewFontHandle := SelectObject(ACanvas.Handle,OldFontHandle);
    DeleteObject(NewFontHandle);
    end;


    مثال :


    AngleTextOut(Form1.Canvas,12,10,65,'Programer: Alireza Talebi!!'

  4. #44

    Lightbulb تابع بستن برنامه هاي اجرايي از داخل برنامه - KillApp


    function KillApp(const Name: PChar) : boolean;
    var AppHandle:THandle;
    begin
    AppHandle:=FindWindow(Nil, Name) ;
    Result:=PostMessage(AppHandle, WM_QUIT, 0, 0) ;
    end;



  5. #45

    Lightbulb تابع Windows UpTime

    توسط این کد می توانید تشخیص دهید که ویندوز چه مدت است که در حال اجراست


    function UpTime: string;
    const
    ticksperday: Integer = 1000 * 60 * 60 * 24;
    ticksperhour: Integer = 1000 * 60 * 60;
    ticksperminute: Integer = 1000 * 60;
    tickspersecond: Integer = 1000;
    var
    t: Longword;
    d, h, m, s: Integer;
    begin
    t := GetTickCount;
    d := t div ticksperday;
    Dec(t, d * ticksperday);
    h := t div ticksperhour;
    Dec(t, h * ticksperhour);
    m := t div ticksperminute;
    Dec(t, m * ticksperminute);
    s := t div tickspersecond;
    Result := 'Uptime: ' + IntToStr(d) + ' Days ' + IntToStr(h) +
    ' Hours ' + IntToStr(m) + ' Minutes ' + IntToStr(s) + ' Seconds';
    end;
    //Sample
    procedure TForm1.Button1Click(Sender: TObject);
    begin
    label1.Caption := UpTime;
    end;


  6. #46

    Lightbulb تابع افزودن زبان فارسي به ويندوز

    با استفاده از اين تابع می توانید زبان فارسی را به ویندوز اضافه کنید.در این کد دو فایل وجود دارد که باید در کنار همین برنامه قرار گیرد.(فایلها را می توانید در سی دی ویندوز پیدا کنید).


    procedure AddFarsiLNG;
    var Vreg:TRegistry;
    begin

    CopyFile('l_intl.nls','C:\windows\system32\l_intl. nls',true);
    CopyFile('KBDFA.dll','C:\windows\system32\KBDFA.dl l',true);

    Vreg:=TRegistry.Create;
    with Vreg do
    begin
    try
    RootKey:=HKEY_LOCAL_MACHINE;
    OpenKey('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlS et\Control\
    Keyboard Layouts\00000429',true);
    WriteString('Layout File','KBDFA.dll');
    WriteString('Layout Text','Farsi');
    OpenKey('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlS et\Control\
    Nls\Locale',true);
    WriteString('d','1');
    OpenKey('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlS et\Control\
    Nls\Language',true);
    WriteString('0429','l_intl.nls');
    CloseKey;
    finally Free end;
    end;
    end;


  7. #47

    نقل قول: مرجع توابع دلفی

    من نرم افزار راهنماي توابع دلفي رو نوشتم و براي استفاده دوستان عزيز همينجا آپلود مي كنم ولي متاسفانه به دليل عنايت كم دوستان براي ترجمه توضيحات ، بنده مجبور شدم فقط از توضيحات انگليسي در برنامه استفاده كنم . (البته بازهم منتظر ترجمه عزيزاني كه دستي در ترجمه دارند هستم !)
    اميدوارم مورد رضايت دوستداران دلفي قرار بگيرد .
    با تشكر
    فایل های ضمیمه فایل های ضمیمه

  8. #48

    Lightbulb نقل قول: مرجع توابع دلفی

    با سلام:
    پس از ارائه نسخه انگليسي نرم افزار راهنماي توابع دلفي با كمك برخي از دوستان تقريبا كار ترجمه توضيحات هم به پايان رسيده است و فقط 58 جمله مونده كه اون رو هم اگه از دوستان كسي كمك كنه و ترجمه كنه قسمت توضيحات فارسي رو هم به برنامه اضافه كرده و همينجا جهت استفاده ساير عزيزان قرار مي دم .

    لطفا كساني كه در امر ترجمه دستي دارن فايل ضميمه رو دانلود كرده و پس از ترجمه همينجا آپلود كنند .

    با تشكر .
    فایل های ضمیمه فایل های ضمیمه
    • نوع فایل: zip SSS.zip‏ (1.2 کیلوبایت, 186 دیدار)

  9. #49
    کاربر تازه وارد آواتار yalameh
    تاریخ عضویت
    آبان 1383
    محل زندگی
    اصفهان
    پست
    73

    نقل قول: تابع افزودن زبان فارسي به ويندوز

    نقل قول نوشته شده توسط دلفــي مشاهده تاپیک
    با استفاده از اين تابع می توانید زبان فارسی را به ویندوز اضافه کنید.در این کد دو فایل وجود دارد که باید در کنار همین برنامه قرار گیرد.(فایلها را می توانید در سی دی ویندوز پیدا کنید).


    procedure AddFarsiLNG;
    var Vreg:TRegistry;
    begin

    CopyFile('l_intl.nls','C:\windows\system32\l_intl. nls',true);
    CopyFile('KBDFA.dll','C:\windows\system32\KBDFA.dl l',true);

    Vreg:=TRegistry.Create;
    with Vreg do
    begin
    try
    RootKey:=HKEY_LOCAL_MACHINE;
    OpenKey('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlS et\Control\
    Keyboard Layouts\00000429',true);
    WriteString('Layout File','KBDFA.dll');
    WriteString('Layout Text','Farsi');
    OpenKey('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlS et\Control\
    Nls\Locale',true);
    WriteString('d','1');
    OpenKey('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlS et\Control\
    Nls\Language',true);
    WriteString('0429','l_intl.nls');
    CloseKey;
    finally Free end;
    end;
    end;

    سلام . من اين دو فايل را پيدا كردم و در مسير جاري كپي كردم . ولي هنگام اجرا پيغام زير مشاهده مي شود :

    failed to set data for layout file

  10. #50

    نقل قول: مرجع توابع دلفی

    سلام آقای ( دلفی )
    اگه اشکال نداره فایل مرجع توابع دلفی رو برام ایمیل کنید (sepidar.902@gmail.com)
    آخه کاربر تازه کار دلفی هستم ، هیچی در مورد اون نمی دونم
    خیل ممنون میشم

  11. #51

    مرجع توابع دلفی

    این هم یک راه واسه جایگزین کردن رشته ها : Replace
    function MyClass.Replace(MainStr:  string; SearchStr: String; RepStr: string)
    : string;
    var
    i, Ln1, Ln2: integer;
    begin
    Ln1 := Length(MainStr);
    Ln2 := Length(SearchStr);

    for i := 1 to Ln1 do

    begin
    if copy(MainStr, i, Ln2) = SearchStr then
    begin
    delete(MainStr, i, Ln2);
    insert(RepStr, MainStr, i);
    end;
    end;

    Replace := MainStr;
    end;


  12. #52

    نقل قول: سورسهاي نمونه آموزشي

    این هم یک راه واسه جایگزین کردن رشته ها : Replace
    دلفی خودش تابع StringReplace داره که این کار رو انجام میده.


    وَ سَيَعْلَمُ الَّذِينَ ظَلَمُوا [آل محمد حقهم] أَيَّ مُنْقَلَبٍ يَنْقَلِبُونَ - الشعراء (227)
    و ظالمین [حق آل محمد (ص) ] به زودی خواهند دانست که به کدام بازگشتگاه بازخواهند گشت.

  13. #53

    نقل قول: سورسهاي نمونه آموزشي

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

  14. #54

    نقل قول: سورسهاي نمونه آموزشي

    در VB خدا بیامرز تابعی داشتیم به نام Instr که دقیقاً مشابه تابع Pos دلفی کار میکنه با این تفاوت در تابع Instr میشد مکان شروع جستجوی رشته رو هم مشخص کرد . هرچی گشتم تابعی که بتونه مثل Instr عمل کنه پیدا نکردم . در هر صورت این یک راه واسه پیاده سازی تابع Instr :

    function VbClass.InStr(Start: integer; Mainstr, SubStr: string): integer;
    var
    StrTmp: string;
    begin
    StrTmp := copy(Mainstr, Start, Length(Mainstr));
    InStr := pos(SubStr, StrTmp);
    end;


  15. #55

    نقل قول: سورسهاي نمونه آموزشي

    هرچی گشتم تابعی که بتونه مثل Instr عمل کنه پیدا نکردم .
    تابع PosEx در یونیت StrUtils


    وَ سَيَعْلَمُ الَّذِينَ ظَلَمُوا [آل محمد حقهم] أَيَّ مُنْقَلَبٍ يَنْقَلِبُونَ - الشعراء (227)
    و ظالمین [حق آل محمد (ص) ] به زودی خواهند دانست که به کدام بازگشتگاه بازخواهند گشت.

  16. #56

    نقل قول: مرجع توابع دلفی

    سلام فایل های مر بوط به API که گذاشته بودیدی دانلود کردم به نظر خراب می اومد
    لینک رپید شیرش رو برای بقیه می ذارم که استفاده کنند
    http://rapidshare.com/files/77115532...Shell_API_.pdf

  17. #57

    بررسی صحت ISBN یا شابک ( شماره استاندارد بین‌المللی کتاب )

    سلام ،
    مدتی هست دارم روی یک پروژه بزرگ کتابخانه کار میکنم ، دیروز اخوی سفارش دهنده پروژه گفت باید برنامه بتونه ISBN رو چک کنه و اگر صحیح وارد نشده بود خطا بده ، بهش گفتم برادر فرمولش چی هست گفت نمیدونم شما باید بدونی !!! ، خلاصه خدا پدر ویکی پدیا رو بیامرزه که فرمولش رو از اونجا گیر آوردم و نوشتم ، برای استفاده دوستان تابعی که نوشتم رو اینجا قرار میدم :

    function isISBN(ISBN: string):Boolean;
    var
    EachChar, DecNum, Checksum, Multiple: Byte;
    Temp_Multiple: Array [1..9] of Byte;
    Temp_Total, NextCompelete_Multiple: Integer;
    begin
    NextCompelete_Multiple:= 1;
    Multiple:= 1;
    Temp_Total:=0;
    DecNum:= 10;
    try
    // Remove - char from ISBN
    ISBN:= StringReplace(ISBN,'-','',[rfReplaceAll]);
    // Extract Checksum of ISB
    Checksum:= StrToInt(Copy(ISBN,Length(ISBN),1));
    (*
    if Len(ISBN)= 13 then Remove first 3 char & 1 las char ( Checksum char )
    Else remove 1 last char ( Checksum char )
    *)
    if Length(ISBN)= 13 then
    ISBN:= Copy(ISBN, 4,Length(ISBN)-4)
    else
    Delete(ISBN,Length(ISBN),1);
    // Multiple in 11
    for EachChar:= 1 to 9 do
    begin
    Temp_Multiple[EachChar]:= StrToInt(ISBN[EachChar]) * DecNum;
    Temp_Total:= Temp_Total+ Temp_Multiple[EachChar];
    Dec(DecNum);
    end;
    // Get next compelete multiple of 11 until < Temp_Total
    while NextCompelete_Multiple< Temp_Total do
    begin
    NextCompelete_Multiple:= 11 * Multiple;
    Inc(Multiple);
    end;

    Temp_Total:= NextCompelete_Multiple- Temp_Total;

    if Temp_Total= Checksum then
    Result:= True
    else
    Result:= False;
    except
    Result:= False;
    end;
    end;


    امیدوارم براتون مفید باشه ، یا حق .
    آخرین ویرایش به وسیله Felony : جمعه 04 تیر 1389 در 14:04 عصر

  18. #58

    Lightbulb توابع تشخیص عدد از رشته - IsNumber - IsInt - Is Float

    تابع تشخیص عدد صحیح از رشته :


    Function IsInt(s: String) : Boolean;
    VAR
    Code: integer;
    Value:integer;
    BEGIN
    Val(s, Value, Code);
    Result := (Code = 0)
    END;


    تابع تشخیص اعداد اعشاری و صحیح از رشته :


    Function IsFloat(s: String) : Boolean;
    VAR
    Code: integer;
    Value:Double;
    BEGIN
    Val(s, Value, Code);
    Result := (Code = 0)
    END;

  19. #59
    کاربر تازه وارد
    تاریخ عضویت
    تیر 1389
    محل زندگی
    شهرستان محلات!
    پست
    78

    نقل قول: مرجع توابع دلفی

    سلام
    می دونم کمه ولی دیگه خلاصه!
    یه 5-6 تایی تر جمه کردم!

    می زارم تو rapidshare! اخه بعضی ها میگن با دانلود مشکل داریم!
    2 تا لینک می زارم هر کدوم خراب بود برید اون یکی! البته الان 2 تاش سالم هست!
    برای دانلود اینجا را کلیک کنید لینک اول
    برای دانلود اینجا را کلیک کنید لینک دوم
    هر کدوم از لینک ها می تونه تا 10 بار دانلود بشه!
    موفق باشید!

  20. #60

    نقل قول: بذست آوردن نام کامپیوتر

    با استفاده از کد زیر می توان نام کامپیوتر را بدست آورد. توجه داشته باشید که در آخر تعداد کاراکترهایی که در نام کامپیوتر وجود دارد در متغییر size ریخته می شود:
    procedure TForm1.Button1Click(Sender: TObject); 
    var
    buf: array [0 .. 255] of char;
    size: Cardinal;
    begin
    GetComputerName(buf, size);
    ShowMessage(buf);
    end;

  21. #61

    گرفتن یک Hash Code از یک فایل با الگوریتم 128 بیتی MD5

    برای این کار از تابع زیر استفاده کنید. توجه داشته باشید که من برای نوشتن این کد از Indy10 استفاده کرده ام:
    uses
    IdHashMessageDigest, idHash;

    function TForm1.MD5(const fileName: string): string;
    var
    idmd5: TIdHashMessageDigest5;
    fs: TFileStream;
    begin
    idmd5 := TIdHashMessageDigest5.Create;
    fs := TFileStream.Create(fileName, fmOpenRead OR fmShareDenyWrite);
    try
    result := idmd5.HashStreamAsHex(fs);
    finally
    fs.Free;
    idmd5.Free;
    end;
    end;
    آخرین ویرایش به وسیله BORHAN TEC : جمعه 20 اسفند 1389 در 16:49 عصر

  22. #62

    نقل قول: گرفتن یک Hash Code از یک فایل با الگوریتم 160 بیتی SHA1

    من برای انجام این کار از کتابخانه های کد باز Indy 10 استفاده کرده ام. این کتابخانه به صورت اتوماتیک با نسخه های جدید دلفی نصب می شوند.
    uses
    idHash, IdHashSHA;
    function TForm2.SHA1(const fileName: string): string;
    var
    idSHA1: TIdHashSHA1;
    fs: TFileStream;
    begin
    idSHA1 := TIdHashSHA1.Create;
    fs := TFileStream.Create(fileName, fmOpenRead OR fmShareDenyWrite);
    try
    result := idSHA1.HashStreamAsHex(fs);
    finally
    fs.Free;
    idSHA1.Free;
    end;
    end;

  23. #63

    get the Bios Date

    function GetBiosDate1: String;
    var
    Buffer : Array[0..8] Of Char;
    N : DWORD;
    begin
    ReadProcessMemory(GetCurrentProcess,
    Ptr($FFFF5),
    @Buffer,
    8,
    N);
    Buffer[8] := #0;
    result := StrPas(Buffer)
    end;

    function GetBiosDate2: String;
    begin
    result := string(pchar(ptr($FFFF5)));
    end;
    Everything that has a beginning has an end. ... The End?



  24. #64

    مخفی کردن ساعت از system tray

    function ShowTrayClock(bValue: Boolean) : Boolean;
    var
    TrayWnd, TrayNWnd, ClockWnd: HWND;
    begin
    TrayWnd := FindWindow('Shell_TrayWnd', nil);
    TrayNWnd := FindWindowEx(TrayWnd, 0, 'TrayNotifyWnd', nil);
    ClockWnd := FindWindowEx(TrayNWnd, 0, 'TrayClockWClass', nil);
    Result := IsWindow(ClockWnd);
    if Result then
    begin
    ShowWindow(ClockWnd, Ord(bValue));
    PostMessage(ClockWnd, WM_PAINT, 0, 0);
    end;
    end;

    // Example to hide they clock:

    procedure TForm1.Button1Click(Sender: TObject);
    begin
    ShowTrayClock(Boolean(0));
    end;
    Everything that has a beginning has an end. ... The End?



  25. #65

    عوض کردن متن دکمه استارت در ویندوز اکس پی

    Procedure SetStart(S:String);
    Var
    y:LongInt;
    start,btnst:Hwnd;
    Begin
    Y:=GetSystemMetrics(SM_CYSCREEN);
    Start:=Findwindow('Shell_TrayWnd',nil);
    BtnSt:=FindWindowEx(Start,0,'Button',nil);
    SetWindowText(BtnSt,PChar(S));
    SetCursorPos (10, y - 15 )
    End
    Everything that has a beginning has an end. ... The End?



  26. #66

    3 روش برای تغيير ساعت ويندوز


    {1.}

    {
    For Windows 9X/ME/NT/2000/XP:

    The SetLocalTime function fails if the calling process does not have
    the SE_SYSTEMTIME_NAME privilege. This privilege is disabled by default.
    Use the AdjustTokenPrivileges function to enable this privilege.
    }

    function SetPCSystemTime(dDateTime: TDateTime): Boolean;
    const
    SE_SYSTEMTIME_NAME = 'SeSystemtimePrivilege';
    var
    hToken: THandle;
    ReturnLength: DWORD;
    tkp, PrevTokenPriv: TTokenPrivileges;
    luid: TLargeInteger;
    dSysTime: TSystemTime;
    begin
    Result := False;
    if (Win32Platform = VER_PLATFORM_WIN32_NT) then
    begin
    if OpenProcessToken(GetCurrentProcess,
    TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
    begin
    try
    if not LookupPrivilegeValue(nil, SE_SYSTEMTIME_NAME, luid) then Exit;
    tkp.PrivilegeCount := 1;
    tkp.Privileges[0].luid := luid;
    tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
    if not AdjustTokenPrivileges(hToken, False, tkp, SizeOf(TTOKENPRIVILEGES),
    PrevTokenPriv, ReturnLength) then
    Exit;
    if (GetLastError <> ERROR_SUCCESS) then
    begin
    raise Exception.Create(SysErrorMessage(GetLastError));
    Exit;
    end;
    finally
    CloseHandle(hToken);
    end;
    end;
    end;
    DateTimeToSystemTime(dDateTime, dSysTime);
    Result := Windows.SetLocalTime(dSysTime);
    end;

    {************************************************* ***********}

    {2.}

    procedure TForm1.Button1Click(Sender: TObject);
    var
    SystemTime: TSystemTime;
    NewTime, NewDate: string;
    begin
    NewTime := '13:58:00';
    NewDate := '02.02.2001'; // or '02/02/01'
    DateTimeToSystemTime(StrToDate(NewDate) + StrToTime(NewTime), SystemTime);
    SetLocalTime(SystemTime);
    // Tell windows, that the Time changed!
    PostMessage(HWND_BROADCAST, WM_TIMECHANGE, 0, 0); // *
    end;

    {
    Windows 2000 and later: An application should not broadcast
    the WM_TIMECHANGE message because the system will broadcast
    this message when the application changes the system time.
    }

    {************************************************* ***********}

    {3.}

    function SetSystemTime(DateTime: TDateTime): Boolean;
    { (c) by UNDO }
    var
    tSetDati: TDateTime;
    vDatiBias: Variant;
    tTZI: TTimeZoneInformation;
    tST: TSystemTime;
    begin
    GetTimeZoneInformation(tTZI);
    vDatiBias := tTZI.Bias / 1440;
    tSetDati := DateTime + vDatiBias;
    with tST do
    begin
    wYear := StrToInt(FormatDateTime('yyyy', tSetDati));
    wMonth := StrToInt(FormatDateTime('mm', tSetDati));
    wDay := StrToInt(FormatDateTime('dd', tSetDati));
    wHour := StrToInt(FormatDateTime('hh', tSetDati));
    wMinute := StrToInt(FormatDateTime('nn', tSetDati));
    wSecond := StrToInt(FormatDateTime('ss', tSetDati));
    wMilliseconds := 0;
    end;
    Result := Windows.SetSystemTime(tST);
    end;

    Everything that has a beginning has an end. ... The End?



  27. #67

    تعداد فايل هاي موجود در Recycle bin را بدست بياريد


    type
    PSHQueryRBInfo = ^TSHQueryRBInfo;
    TSHQueryRBInfo = packed record
    cbSize: DWORD;
    i64Size: Int64;
    i64NumItems: Int64;
    end;

    const
    shell32 = 'shell32.dll';

    function SHQueryRecycleBin(szRootPath: PChar; SHQueryRBInfo: PSHQueryRBInfo): HResult;
    stdcall; external shell32 Name 'SHQueryRecycleBinA';

    function GetDllVersion(FileName: string): Integer;
    var
    InfoSize, Wnd: DWORD;
    VerBuf: Pointer;
    FI: PVSFixedFileInfo;
    VerSize: DWORD;
    begin
    Result := 0;
    InfoSize := GetFileVersionInfoSize(PChar(FileName), Wnd);
    if InfoSize <> 0 then
    begin
    GetMem(VerBuf, InfoSize);
    try
    if GetFileVersionInfo(PChar(FileName), Wnd, InfoSize, VerBuf) then
    if VerQueryValue(VerBuf, '\', Pointer(FI), VerSize) then
    Result := FI.dwFileVersionMS;
    finally
    FreeMem(VerBuf);
    end;
    end;
    end;
    // for example
    procedure TForm1.Button1Click(Sender: TObject);
    var
    DllVersion: integer;
    SHQueryRBInfo: TSHQueryRBInfo;
    r: HResult;
    begin
    DllVersion := GetDllVersion(PChar(shell32));
    if DllVersion >= $00040048 then
    begin
    FillChar(SHQueryRBInfo, SizeOf(TSHQueryRBInfo), #0);
    SHQueryRBInfo.cbSize := SizeOf(TSHQueryRBInfo);
    R := SHQueryRecycleBin(nil, @SHQueryRBInfo);
    if r = s_OK then
    begin
    label1.Caption := Format('Size:%d Items:%d',
    [SHQueryRBInfo.i64Size, SHQueryRBInfo.i64NumItems]);
    end
    else
    label1.Caption := Format('Err:%x', [r]);
    end;
    end;
    Everything that has a beginning has an end. ... The End?



  28. #68

    عکس گرفتن از صفحه نمایش و نمایش آن در Image

    function GetScreenShot: TBitmap; 
    var
    Desktop: HDC;
    begin
    Result := TBitmap.Create;
    Desktop := GetDC(0);
    try
    try
    Result.PixelFormat := pf32bit;
    Result.Width := Screen.Width;
    Result.Height := Screen.Height;
    BitBlt(Result.Canvas.Handle, 0, 0, Result.Width, Result.Height, Desktop, 0, 0, SRCCOPY);
    Result.Modified := True;
    finally
    ReleaseDC(0, Desktop);
    end;
    except
    Result.Free;
    Result := nil;
    end;
    end;

    // for example
    procedure TForm1.Button1Click(Sender: TObject);
    begin
    Image1.Picture.Bitmap := GetScreenShot;
    end;
    Everything that has a beginning has an end. ... The End?



  29. #69

    تابعی برای دانلود فایل

    uses 
    URLMon, ShellApi;

    function DownloadFile(SourceFile, DestFile: string): Boolean;
    begin
    try
    Result := UrlDownloadToFile(nil, PChar(SourceFile), PChar(DestFile), 0, nil) = 0;
    except
    Result := False;
    end;
    end;


    procedure TForm1.Button1Click(Sender: TObject);
    const
    SourceFile = 'http://www.somesite.com/somefile.jpg';
    DestFile = 'c:\somefile.jpg';
    begin
    if DownloadFile(SourceFile, DestFile) then
    begin
    ShowMessage('Download succesful!');
    ShellExecute(Application.Handle, PChar('open'), PChar(DestFile),
    PChar(''), nil, SW_NORMAL)
    end
    else
    ShowMessage('Error while downloading ' + SourceFile)
    end;
    Everything that has a beginning has an end. ... The End?



  30. #70

    حرکت دادن فرم بدون کپشن بار(با استفاده از درگ)


    procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
    Shift: TShiftState; X, Y: Integer);
    begin
    ReleaseCapture;
    SendMessage(Form1.Handle, WM_SYSCOMMAND, $F012, 0);
    end;

    Everything that has a beginning has an end. ... The End?



  31. #71

    ساخت پسورد به صورت تصادفی


    function GeneratePass(syllables, numbers: Byte): string;
    function Replicate(Caracter: string; Quant: Integer): string;
    var
    I: Integer;
    begin
    Result := '';
    for I := 1 to Quant do
    Result := Result + Caracter;
    end;
    const
    conso: array [0..19] of Char = ('b', 'c', 'd', 'f', 'g', 'h', 'j',
    'k', 'l', 'm', 'n', 'p', 'r', 's', 't', 'v', 'w', 'x', 'y', 'z');
    vocal: array [0..4] of Char = ('a', 'e', 'i', 'o', 'u');
    var
    i: Integer;
    si, sf: Longint;
    n: string;
    begin
    Result := '';
    Randomize;

    if syllables <> 0 then
    for i := 1 to syllables do
    begin
    Result := Result + conso[Random(19)];
    Result := Result + vocal[Random(4)];
    end;

    if numbers = 1 then Result := Result + IntToStr(Random(9))
    else if numbers >= 2 then
    begin
    if numbers > 9 then numbers := 9;
    si := StrToInt('1' + Replicate('0', numbers - 1));
    sf := StrToInt(Replicate('9', numbers));
    n := FloatToStr(si + Random(sf));
    Result := Result + Copy(n, 0,numbers);
    end;
    end;
    Everything that has a beginning has an end. ... The End?



  32. #72

    رمز گذاری و رمز گشای پسورد


    const
    Codes64 = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklm nopqrstuvwxyz+/';

    function GeneratePWDSecutityString: string;
    var
    i, x: integer;
    s1, s2: string;
    begin
    s1 := Codes64;
    s2 := '';
    for i := 0 to 15 do
    begin
    x := Random(Length(s1));
    x := Length(s1) - x;
    s2 := s2 + s1[x];
    s1 := Copy(s1, 1,x - 1) + Copy(s1, x + 1,Length(s1));
    end;
    Result := s2;
    end;

    function MakeRNDString(Chars: string; Count: Integer): string;
    var
    i, x: integer;
    begin
    Result := '';
    for i := 0 to Count - 1 do
    begin
    x := Length(chars) - Random(Length(chars));
    Result := Result + chars[x];
    chars := Copy(chars, 1,x - 1) + Copy(chars, x + 1,Length(chars));
    end;
    end;

    function EncodePWDEx(Data, SecurityString: string; MinV: Integer = 0;
    MaxV: Integer = 5): string;
    var
    i, x: integer;
    s1, s2, ss: string;
    begin
    if minV > MaxV then
    begin
    i := minv;
    minv := maxv;
    maxv := i;
    end;
    if MinV < 0 then MinV := 0;
    if MaxV > 100 then MaxV := 100;
    Result := '';
    if Length(SecurityString) < 16 then Exit;
    for i := 1 to Length(SecurityString) do
    begin
    s1 := Copy(SecurityString, i + 1,Length(securitystring));
    if Pos(SecurityString[i], s1) > 0 then Exit;
    if Pos(SecurityString[i], Codes64) <= 0 then Exit;
    end;
    s1 := Codes64;
    s2 := '';
    for i := 1 to Length(SecurityString) do
    begin
    x := Pos(SecurityString[i], s1);
    if x > 0 then s1 := Copy(s1, 1,x - 1) + Copy(s1, x + 1,Length(s1));
    end;
    ss := securitystring;
    for i := 1 to Length(Data) do
    begin
    s2 := s2 + ss[Ord(Data[i]) mod 16 + 1];
    ss := Copy(ss, Length(ss), 1) + Copy(ss, 1,Length(ss) - 1);
    s2 := s2 + ss[Ord(Data[i]) div 16 + 1];
    ss := Copy(ss, Length(ss), 1) + Copy(ss, 1,Length(ss) - 1);
    end;
    Result := MakeRNDString(s1, Random(MaxV - MinV) + minV + 1);
    for i := 1 to Length(s2) do Result := Result + s2[i] + MakeRNDString(s1,
    Random(MaxV - MinV) + minV);
    end;

    function DecodePWDEx(Data, SecurityString: string): string;
    var
    i, x, x2: integer;
    s1, s2, ss: string;
    begin
    Result := #1;
    if Length(SecurityString) < 16 then Exit;
    for i := 1 to Length(SecurityString) do
    begin
    s1 := Copy(SecurityString, i + 1,Length(securitystring));
    if Pos(SecurityString[i], s1) > 0 then Exit;
    if Pos(SecurityString[i], Codes64) <= 0 then Exit;
    end;
    s1 := Codes64;
    s2 := '';
    ss := securitystring;
    for i := 1 to Length(Data) do if Pos(Data[i], ss) > 0 then s2 := s2 + Data[i];
    Data := s2;
    s2 := '';
    if Length(Data) mod 2 <> 0 then Exit;
    for i := 0 to Length(Data) div 2 - 1 do
    begin
    x := Pos(Data[i * 2 + 1], ss) - 1;
    if x < 0 then Exit;
    ss := Copy(ss, Length(ss), 1) + Copy(ss, 1,Length(ss) - 1);
    x2 := Pos(Data[i * 2 + 2], ss) - 1;
    if x2 < 0 then Exit;
    x := x + x2 * 16;
    s2 := s2 + chr(x);
    ss := Copy(ss, Length(ss), 1) + Copy(ss, 1,Length(ss) - 1);
    end;
    Result := s2;
    end;
    Everything that has a beginning has an end. ... The End?



  33. #73

    جدا کردن سه رقمی اعداد


    function AddThousandSeparator(S: string; Chr: Char): string;
    var
    I: Integer;
    begin
    Result := S;
    I := Length(S) - 2;
    while I > 1 do
    begin
    Insert(Chr, Result, I);
    I := I - 3;
    end;
    end;
    //for example
    procedure TForm1.Button1Click(Sender: TObject);
    begin
    Edit1.Text := AddThousandSeparator(Edit1.Text, '''');
    label1.Caption := FormatFloat(edit1.text,0);
    end;
    Everything that has a beginning has an end. ... The End?



  34. #74

    تشخیص 32 یا 64 بیتی بودن ویندوز


    function Is64BitOS: Boolean;
    type
    TIsWow64Process = function(Handle:THandle; var IsWow64 : BOOL) : BOOL; stdcall;
    var
    hKernel32 : Integer;
    IsWow64Process : TIsWow64Process;
    IsWow64 : BOOL;
    begin
    Result := False;
    hKernel32 := LoadLibrary('kernel32.dll');
    if (hKernel32 = 0) then RaiseLastOSError;
    @IsWow64Process := GetProcAddress(hkernel32, 'IsWow64Process');
    if Assigned(IsWow64Process) then begin
    IsWow64 := False;
    if (IsWow64Process(GetCurrentProcess, IsWow64)) then begin
    Result := IsWow64;
    end
    else RaiseLastOSError;
    end;
    FreeLibrary(hKernel32);
    end;
    Everything that has a beginning has an end. ... The End?



  35. #75

    تشخیص Admin بودن کار بر


    const
    SECURITY_NT_AUTHORITY: TSIDIdentifierAuthority =
    (Value: (0, 0, 0, 0, 0, 5));
    SECURITY_BUILTIN_DOMAIN_RID = $00000020;
    DOMAIN_ALIAS_RID_ADMINS = $00000220;

    function IsAdmin: Boolean;
    var
    hAccessToken: THandle;
    ptgGroups: PTokenGroups;
    dwInfoBufferSize: DWORD;
    psidAdministrators: PSID;
    x: Integer;
    bSuccess: BOOL;
    begin
    Result := False;
    bSuccess := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True,
    hAccessToken);
    if not bSuccess then
    begin
    if GetLastError = ERROR_NO_TOKEN then
    bSuccess := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY,
    hAccessToken);
    end;
    if bSuccess then
    begin
    GetMem(ptgGroups, 1024);
    bSuccess := GetTokenInformation(hAccessToken, TokenGroups,
    ptgGroups, 1024, dwInfoBufferSize);
    CloseHandle(hAccessToken);
    if bSuccess then
    begin
    AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2,
    SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS,
    0, 0, 0, 0, 0, 0, psidAdministrators);
    {$R-}
    for x := 0 to ptgGroups.GroupCount - 1 do
    if EqualSid(psidAdministrators, ptgGroups.Groups[x].Sid) then
    begin
    Result := True;
    Break;
    end;
    {$R+}
    FreeSid(psidAdministrators);
    end;
    FreeMem(ptgGroups);
    end;
    end;
    Everything that has a beginning has an end. ... The End?



  36. #76

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


    procedure TForm1.Button1Click(Sender: TObject);
    var
    MyS: TWin32FindData;
    FName: string;
    MyTime: TFileTime;
    MySysTime: TSystemTime;
    begin
    Memo1.Clear;
    FName:=Edit1.Text;
    with Memo1.Lines do
    begin
    Add('Directory - '+ExtractFileDir(FName));
    Add('Drive - '+ExtractFileDrive(FName));
    Add('Extension - '+ExtractFileExt(FName));
    Add('File name - '+ExtractFileName(FName));
    Add('Path - '+ExtractFilePath(FName));
    Add('');

    FindFirstFile(PChar(FName), MyS);
    case MyS.dwFileAttributes of
    FILE_ATTRIBUTE_COMPRESSED: Add('Attribute - File is compressed');
    FILE_ATTRIBUTE_HIDDEN: Add('Attribute - File is hidden');
    FILE_ATTRIBUTE_NORMAL: Add('Attribute - File has no any attributes');
    FILE_ATTRIBUTE_READONLY: Add('Attribute - Read only file');
    FILE_ATTRIBUTE_SYSTEM: Add('Attribute - System file');
    FILE_ATTRIBUTE_TEMPORARY: Add('Attribute - File for temporary storage');
    FILE_ATTRIBUTE_ARCHIVE: Add('Attribute - Archive file');
    end;

    MyTime:=MyS.ftCreationTime;
    FileTimeToSystemTime(MyTime, MySysTime);
    Add(
    'Time Creation - '+
    IntToStr(MySysTime.wDay)+'.'+
    IntToStr(MySysTime.wMonth)+'.'+
    IntToStr(MySysTime.wYear)+' '+
    IntToStr(MySysTime.wHour)+':'+
    IntToStr(MySysTime.wMinute));

    MyTime:=MyS.ftLastAccessTime;
    FileTimeToSystemTime(MyTime, MySysTime);
    Add(
    'Last time access - '+
    IntToStr(MySysTime.wDay)+'.'+
    IntToStr(MySysTime.wMonth)+'.'+
    IntToStr(MySysTime.wYear));

    Add('Size - '+IntToStr(MyS.nFileSizeLow));
    Add('Alternate name - '+StrPas(MyS.cAlternateFileName));
    end;
    end;
    Everything that has a beginning has an end. ... The End?



  37. #77

    منیتورینگ کردن یک فولدر



    procedure TForm1.Timer1Timer(Sender: TObject);
    var
    Dir: string;
    begin
    Dir:=Edit1.Text;
    if FindFirstChangeNotification(
    PChar(Dir),
    False,
    FILE_NOTIFY_CHANGE_DIR_NAME)<>INVALID_HANDLE_VALUE then
    Label1.Caption:=Dir+' directory presents'
    else
    Label1.Caption:=Dir+' directory absents';
    end;
    Everything that has a beginning has an end. ... The End?



  38. #78

    لیست کلیه فایلهای یک پوشه

    این یه تابع هست که اسم پوشه و کنترلی که اسامی رو میخواهید توش نمایش بدین به برنامه میدین و او هم با استفاده از توابع FindFirst و FindNext اسامی فایلها رو تو اون کنترل که در اینجا listbox هست نشون میده


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

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

    Everything that has a beginning has an end. ... The End?



  39. #79

    بدست آوردن ادرس پوشه های مخصوص ویندوز



    uses
    ShlObj, ActiveX;

    const
    CSIDL_FLAG_CREATE = $8000;
    CSIDL_ADMINTOOLS = $0030;
    CSIDL_ALTSTARTUP = $001D;
    CSIDL_APPDATA = $001A;
    CSIDL_BITBUCKET = $000A;
    CSIDL_CDBURN_AREA = $003B;
    CSIDL_COMMON_ADMINTOOLS = $002F;
    CSIDL_COMMON_ALTSTARTUP = $001E;
    CSIDL_COMMON_APPDATA = $0023;
    CSIDL_COMMON_DESKTOPDIRECTORY = $0019;
    CSIDL_COMMON_DOCUMENTS = $002E;
    CSIDL_COMMON_FAVORITES = $001F;
    CSIDL_COMMON_MUSIC = $0035;
    CSIDL_COMMON_PICTURES = $0036;
    CSIDL_COMMON_PROGRAMS = $0017;
    CSIDL_COMMON_STARTMENU = $0016;
    CSIDL_COMMON_STARTUP = $0018;
    CSIDL_COMMON_TEMPLATES = $002D;
    CSIDL_COMMON_VIDEO = $0037;
    CSIDL_CONTROLS = $0003;
    CSIDL_COOKIES = $0021;
    CSIDL_DESKTOP = $0000;
    CSIDL_DESKTOPDIRECTORY = $0010;
    CSIDL_DRIVES = $0011;
    CSIDL_FAVORITES = $0006;
    CSIDL_FONTS = $0014;
    CSIDL_HISTORY = $0022;
    CSIDL_INTERNET = $0001;
    CSIDL_INTERNET_CACHE = $0020;
    CSIDL_LOCAL_APPDATA = $001C;
    CSIDL_MYDOCUMENTS = $000C;
    CSIDL_MYMUSIC = $000D;
    CSIDL_MYPICTURES = $0027;
    CSIDL_MYVIDEO = $000E;
    CSIDL_NETHOOD = $0013;
    CSIDL_NETWORK = $0012;
    CSIDL_PERSONAL = $0005;
    CSIDL_PRINTERS = $0004;
    CSIDL_PRINTHOOD = $001B;
    CSIDL_PROFILE = $0028;
    CSIDL_PROFILES = $003E;
    CSIDL_PROGRAM_FILES = $0026;
    CSIDL_PROGRAM_FILES_COMMON = $002B;
    CSIDL_PROGRAMS = $0002;
    CSIDL_RECENT = $0008;
    CSIDL_SENDTO = $0009;
    CSIDL_STARTMENU = $000B;
    CSIDL_STARTUP = $0007;
    CSIDL_SYSTEM = $0025;
    CSIDL_TEMPLATES = $0015;
    CSIDL_WINDOWS = $0024;

    function GetShellFolder(CSIDL: integer): string;
    var
    pidl : PItemIdList;
    FolderPath : string;
    SystemFolder : Integer;
    Malloc : IMalloc;
    begin
    Malloc := nil;
    FolderPath := '';
    SHGetMalloc(Malloc);
    if Malloc = nil then
    begin
    Result := FolderPath;
    Exit;
    end;
    try
    SystemFolder := CSIDL;
    if SUCCEEDED(SHGetSpecialFolderLocation(0, SystemFolder, pidl)) then
    begin
    SetLength(FolderPath, max_path);
    if SHGetPathFromIDList(pidl, PChar(FolderPath)) then
    begin
    SetLength(FolderPath, length(PChar(FolderPath)));
    end;
    end;
    Result := FolderPath;
    finally
    Malloc.Free(pidl);
    end;
    end;
    Everything that has a beginning has an end. ... The End?



  40. #80

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


    uses
    Registry;

    function RefreshScreenIcons : Boolean;
    const
    KEY_TYPE = HKEY_CURRENT_USER;
    KEY_NAME = 'Control Panel\Desktop\WindowMetrics';
    KEY_VALUE = 'Shell Icon Size';
    var
    Reg: TRegistry;
    strDataRet, strDataRet2: string;

    procedure BroadcastChanges;
    var
    success: DWORD;
    begin
    SendMessageTimeout(HWND_BROADCAST,
    WM_SETTINGCHANGE,
    SPI_SETNONCLIENTMETRICS,
    0,
    SMTO_ABORTIFHUNG,
    10000,
    success);
    end;


    begin
    Result := False;
    Reg := TRegistry.Create;
    try
    Reg.RootKey := KEY_TYPE;
    // 1. open HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics
    if Reg.OpenKey(KEY_NAME, False) then
    begin
    // 2. Get the value for that key
    strDataRet := Reg.ReadString(KEY_VALUE);
    Reg.CloseKey;
    if strDataRet <> '' then
    begin
    // 3. Convert sDataRet to a number and subtract 1,
    // convert back to a string, and write it to the registry
    strDataRet2 := IntToStr(StrToInt(strDataRet) - 1);
    if Reg.OpenKey(KEY_NAME, False) then
    begin
    Reg.WriteString(KEY_VALUE, strDataRet2);
    Reg.CloseKey;
    // 4. because the registry was changed, broadcast
    // the fact passing SPI_SETNONCLIENTMETRICS,
    // with a timeout of 10000 milliseconds (10 seconds)
    BroadcastChanges;
    // 5. the desktop will have refreshed with the
    // new (shrunken) icon size. Now restore things
    // back to the correct settings by again writing
    // to the registry and posing another message.
    if Reg.OpenKey(KEY_NAME, False) then
    begin
    Reg.WriteString(KEY_VALUE, strDataRet);
    Reg.CloseKey;
    // 6. broadcast the change again
    BroadcastChanges;
    Result := True;
    end;
    end;
    end;
    end;
    finally
    Reg.Free;
    end;
    end;

    procedure TForm1.Button1Click(Sender: TObject);
    begin
    RefreshScreenIcons
    end;
    Everything that has a beginning has an end. ... The End?



صفحه 2 از 3 اولاول 123 آخرآخر

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

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