صفحه 3 از 11 اولاول 12345 ... آخرآخر
نمایش نتایج 81 تا 120 از 435

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

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

  2. #82
    جلوگیری از لیست توماری شدن منو:
    Procedure BreakMoreMenu(fSubMenu:TmenuItem;
    fMode:TMenuBreak=mbBarBreak);
    var
    fMnuHeight:Integer;
    ScrHeight:Integer;
    Count:integer;
    i:integer;
    items:integer;
    begin
    fMnuHeight:=GetSystemMetrics(SM_CYMENU&#41 ;;
    If fMnuHeight<1 then
    fMnuHeight:=4
    else
    fMnuHeight:=fMnuHeight+3;
    ScrHeight:=(screen.Height)-(fMnuHeight *5) ;
    Count:=(ScrHeight div fMnuHeight);//Menus in screen
    items:=0;
    for i:=0 to fSubMenu.Count-1 do begin
    If items>=Count then begin
    fSubMenu.Items[i].Break:=fMode;
    items:=0;
    end;
    items:=items+1;
    end;
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:48 عصر

  3. #83
    به چرخش در آوردن متن:
    procedure AngleTextOut(Acanvas:Tcanvas;Angle,x,y&#58  ;integer;Str:String);
    var
    LogRec:TLogFont;
    OldFontHandle,
    NewFontHandle:Hfont;
    begin
    GetObject(Acanvas.Font.Handle,SizeOf(LogRe c),Addr(LogRec));
    LogRec.lfEscapement:=Angle*10;
    NewFontHandle:=CreateFontIndirect(logRec&# 41;;
    OldFontHandle:=SelectObject(Acanvas.handle ,NewFontHandle);
    ACanvas.TextOut(x,y,Str);
    NewFontHandle:=SelectObject(Acanvas.handle ,OldFontHandle);
    DeleteObject(NewFontHandle);
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:48 عصر

  4. #84
    یافتن فایل در تمام شاخه و زیر شاخه هایش:

    اصلاح شد: با نام فایل هایی که فاصله داشتن مشکل داشت!
    function  FindFile(Path,Files:String):TStrin  gs;
    Var
    Dirs,Fill:String;
    IO,len,i:Integer;
    Search:TsearchRec;
    Begin
    Result:=TStringList.Create;
    If Path='' then exit;
    //While Pos(';',files)>0 do
    // Files[Pos(';',Files)]:=' '; //****
    Dirs:='';
    If Path[Length(Path)]='\' then
    Delete(path,length(path),1);
    Repeat
    I:=Length(Files);
    Repeat
    Fill:='';
    While (I>0) and (files[I]<>';') do //' ') do //******
    Begin
    Fill:=files[I]+Fill;
    I:=i-1;
    end;
    I:=i-1;
    IO:=findFirst(path+'\'+fill,faAnyFile-faDirectory,Search);
    While Io=0 do
    Begin
    If (search.Name<>'.') and (search.name<>'..') then
    Result.Add(path+'\'+Search.name);
    IO:=FindNext(Search);
    end;
    FindClose(search);
    until I<1;
    IO:=FindFirst(Path+'\*.*',faAnyFile,Search );
    While IO=0 do
    Begin
    If (search.Name<>'.') and (search.name<>'..') and (search.Attr and FaDirectory>0) then
    Dirs:=Dirs+Path+'\'+Search.Name+#13;
    Io:=FindNext(search);
    end;
    FindClose(search);
    Len:=length(Dirs)-1;
    Io:=len;
    If Len>0 then
    Begin
    While (IO>0) and (Dirs[IO]<>#13) do Io:=IO-1;
    Path:=Copy(Dirs,IO+1,Len-IO);
    SetLength(Dirs,IO);
    end;
    Until(len<0);
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:48 عصر

  5. #85
    بدست آوردن Handle یک پروسه با نام فایلش:
    const
    TH32CS_SNAPPROCESS = $00000002;
    SYNCHRONIZE = $00100000;
    PROCESS_TERMINATE = $0001;

    type
    TProcessEntry32 = packed record
    dwSize: DWORD;
    cntUsage: DWORD;
    th32ProcessID: DWORD; // this process
    th32DefaultHeapID: DWORD;
    th32ModuleID: DWORD; // associated exe
    cntThreads: DWORD;
    th32ParentProcessID: DWORD; // this process's parent process
    pcPriClassBase: Longint; // Base priority of process's threads
    dwFlags: DWORD;
    szExeFile: array[0..MAX_PATH - 1] of Char;// Path
    end;

    function CreateToolhelp32Snapshot (dwFlags, th32ProcessID: DWORD): THandle stdcall;external kernel32 name 'CreateToolhelp32Snapshot';
    function Process32First(hSnapshot: THandle; var lppe: TProcessEntry32): BOOL stdcall;external kernel32 name 'Process32First';
    function Process32Next(hSnapshot: THandle; var lppe: TProcessEntry32): BOOL stdcall;external kernel32 name 'Process32Next';
    function OpenProcess(dwDesiredAccess: DWORD; bInheritHandle: BOOL; dwProcessId: DWORD): THandle; stdcall;external kernel32 name 'OpenProcess';
    function TerminateProcess(hProcess: THandle; uExitCode: UINT): BOOL; stdcall;external kernel32 name 'TerminateProcess';

    Function FindInProcess(name:string;SearchInOther&#5 8;Boolean;var FileName:string):THandle;
    var
    fData: TProcessEntry32;
    fHandler: THandle;
    fFileN:string;

    Function SearchProcess:THandle;
    begin
    fFileN:=fData.szExeFile;
    fFileN:=extractFileName(fFileN);
    result:=0;
    name:=LowerCase(name);
    fFileN:=LowerCase(fFileN);
    If name=fFileN then
    Result:=OpenProcess(SYNCHRONIZE or PROCESS_TERMINATE, False,fData.th32ProcessID)
    else
    If SearchInOther then
    If pos(name,fFileN)<>0 then
    Result:=OpenProcess(SYNCHRONIZE or PROCESS_TERMINATE, False,fData.th32ProcessID);
    If Result<>0 then
    FileName:=fData.szExeFile ;
    //result:=fData.th32ProcessID;
    end;

    begin
    fData.dwSize := SizeOf(fData);
    fHandler := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
    result:=0;
    FileName:='';
    try
    if Process32First(fHandler, fData) then
    begin
    result:=SearchProcess;
    If result<>0 then exit;

    while Process32Next(fHandler, fData) do
    begin
    result:=SearchProcess;
    If result<>0 then exit;
    end;
    end;
    finally
    CloseHandle(fHandler);
    end;

    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:49 عصر

  6. #86
    فرم شفاف شده و فقط کنترل ها نشان داده شود!:
    procedure TranparentForm(Form:Tform;HaveCaption,Have  Menu:Boolean);
    var
    frmRegion,
    tempRegion:HRGN;
    i:Integer;
    Arect:Trect;
    begin
    frmRegion:=0;
    For i:=0 to Form.controlcount -1 do
    begin
    Arect:=Form.controls[i].BoundsRect;
    Offsetrect(Arect,Form.ClientOrigin.x-Form.left,Form.ClientOrigin.y-Form.top);
    tempRegion:=CreateRectRgnIndirect(Arect&#4 1;;
    if frmRegion=0 then
    begin
    frmRegion:=tempRegion;
    end
    else
    Begin
    CombineRgn(frmRegion,frmRegion,TempRegion,RGN_ OR);
    DeleteObject(tempRegion);
    end;
    end;
    tempRegion:=0;
    If HaveCaption and HaveMenu then
    tempRegion:= CreateRectRgn(0,0,Form.Width,
    GetSystemMetrics(SM_CYCAPTION)+
    GetSystemMetrics(SM_CYSIZEFRAME)+
    GetSystemMetrics(SM_CYMENU)*ORD(Form.M enu<>nil));
    If (HaveCaption=false) and HaveMenu then
    tempRegion:= CreateRectRgn(0,GetSystemMetrics(SM_CYCAPT ION)+GetSystemMetrics(SM_CYSIZEFRAmE), Form.Width,
    (GetSystemMetrics(SM_CYSIZEFRAmE)+GetS ystemMetrics(SM_CYMENU)*ORD(Form.Menu& lt;>nil))+GetSystemMetrics(SM_CYCAPTIO N));
    If HaveCaption and (HaveMenu=false) then
    tempRegion:= CreateRectRgn(0,0,Form.Width,
    GetSystemMetrics(SM_CYCAPTION)+
    GetSystemMetrics(SM_CYSIZEFRAmE));
    If (HaveCaption=false) and (HaveMenu=false) then
    tempRegion:= CreateRectRgn(0,0,Form.Width,0);

    CombineRgn(frmregion,frmregion,tempregion,rgn_ or);
    Deleteobject(tempregion);
    setwindowrgn(Form.handle,frmregion,true);
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:50 عصر

  7. #87
    مخفی و ظاهر ساختن عنوان فرم:
    Procedure Hide_ShowCaption(fForm:Tform;fHide:Boo  lean);
    var
    Save:LongInt;
    Begin
    If fform.BorderStyle=bsnone then exit;
    Save:=GetWindowLong(fform.Handle,gwl_Style );
    If Fhide then begin
    If (Save and Ws_Caption )=ws_Caption then begin
    Case fform.BorderStyle of
    bsSizeable,
    bsSingle:
    SetWindowLong(fform.Handle,gwl_style,
    save and (not (ws_Caption)) or ws_Border);
    bsDialog:
    SetWindowLong(fform.Handle,gwl_style,
    save and (not (ws_Caption)) or DS_MODALFRAME or ws_DlgFrame);
    end;
    fform.Height:= fform.Height-GetSystemMetrics(sm_CyCaption);
    fform.Refresh;
    end;
    end else begin
    If (Save and Ws_Caption )=ws_Caption then begin
    Case fform.BorderStyle of
    bsSizeable,
    bsSingle:
    SetWindowLong(fform.Handle,gwl_style,
    save or ws_Caption or ws_Border);
    bsDialog:
    SetWindowLong(fform.Handle,gwl_style,
    save or ws_Caption or DS_MODALFRAME or ws_DlgFrame);
    end;
    fform.Height:= fform.Height+GetSystemMetrics(sm_CyCaption&#41 ;;
    fform.Refresh;
    end;
    end;
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:50 عصر

  8. #88
    خذف یا انتقال فایل در حال اجرا توسط برنامه دیگر ( فقط در ویندوز نوع NT):
    function MoveDelFileReboot(Fileanme,New:String;fMov  e:Boolean=true):Boolean;
    begin
    If fMove then
    result:=movefileEx(Pchar(Fileanme) ,Pchar(new),MoveFile_Replace_Existing or MoveFile_Delay_Until_Reboot)
    else
    Result:=movefileEx(Pchar(Fileanme) ,nil,MoveFile_Replace_Existing or MoveFile_Delay_Until_Reboot);
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:50 عصر

  9. #89
    تعیین وضعیت مانیتور:
    procedure MonitorState(HWnd:HWnd;StandBy:Boolean  );
    begin
    If StandBy then
    sendMessage(HWnd,WM_SYSCOMMAND,SC_MonitorPower ,0)
    else
    sendMessage(HWnd,WM_SYSCOMMAND,SC_MonitorPower ,-1);
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:51 عصر

  10. #90
    کاربر تازه وارد
    تاریخ عضویت
    فروردین 1383
    پست
    56
    با سلام
    طریقه بوت کردن ویندوز 2000 و XP برای دوستان عزیز
    function MyExitWindows(RebootParam: Longword): Boolean ;
    var
    TTokenHd: THandle;
    TTokenPvg: TTokenPrivileges;
    cbtpPrevious: DWORD;
    rTTokenPvg: TTokenPrivileges;
    pcbtpPreviousRequired: DWORD;
    tpResult: Boolean;
    const
    SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';
    begin
    If Win32Platform = VER_PLATFORM_WIN32_NT then
    Begin
    tpResult := OpenProcessToken(GetCurrentProcess(),
    TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, TTokenHd) ;
    If tpResult Then
    Begin
    tpResult := LookupPrivilegeValue(Nil, SE_SHUTDOWN_NAME,
    TTokenPvg.Privileges[0].Luid) ;
    TTokenPvg.PrivilegeCount := 1;
    TTokenPvg.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED ;
    cbtpPrevious := SizeOf(rTTokenPvg) ;
    pcbtpPreviousRequired := 0 ;
    If tpResult then
    Windows.AdjustTokenPrivileges(TTokenHd, False, TTokenPvg,
    cbtpPrevious, rTTokenPvg,
    pcbtpPreviousRequired) ;
    end;
    end;
    Result := ExitWindowsEx(RebootParam, 0);
    end;



    procedure TForm1.Button1Click(Sender: TObject);
    begin
    MyExitWindows(EWX_REBOOT or EWX_FORCE);
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:51 عصر

  11. #91
    کاربر تازه وارد
    تاریخ عضویت
    فروردین 1383
    پست
    56
    با سلام
    چگونه میتوان پنجره اضافه کردن چاپگر را نمایش داد ؟

    ShellExecute(Handle, 'open', 'rundll',
    'shell32.dll,SHHelpShortcuts_RunDLL AddPrinter', '', SW_SHOWNORMAL);
    آخرین ویرایش به وسیله hr110 : چهارشنبه 15 اسفند 1386 در 16:19 عصر

  12. #92
    کاربر تازه وارد
    تاریخ عضویت
    فروردین 1383
    پست
    56
    با سلام
    چگونه میتوان کنترل صفحه کلید را در تمامی ویندوزها بدست گرفت ؟


    Library TheHook;

    uses
    Windows, Messages, SysUtils;

    {Define a record for recording and passing information process wide}
    type
    PHookRec = ^ THookRec;
    THookRec = Packed Record
    TheHookHandle: HHOOK;
    TheAppWinHandle: HWnd;
    TheCtrlWinHandle: HWnd;
    TheKeyCount: DWord;
    end;

    var
    hObjHandle : THandle; {Variable for the file mapping object}
    lpHookRec : PHookRec;
    {Pointer to our hook record}
    procedure MapFileMemory (dwAllocSize: DWord);
    begin { MapFileMemory }
    {Create a process wide memory mapped variable}
    hObjHandle := CreateFileMapping ($FFFFFFFF, Nil, PAGE_READWRITE, 0,
    dwAllocSize, 'HookRecMemBlock');
    if (hObjHandle = 0) then
    begin
    MessageBox (0, 'Hook DLL', 'Could not create file map object', mb_Ok);
    exit
    end { (hObjHandle = 0) };
    {Get a pointer to our process wide memory mapped variable}
    lpHookRec := MapViewOfFile (hObjHandle, FILE_MAP_WRITE, 0, 0, dwAllocSize);
    if (lpHookRec = Nil) then
    begin
    CloseHandle (hObjHandle);
    MessageBox (0, 'Hook DLL', 'Could not map file', mb_Ok);
    exit
    end { (lpHookRec = Nil) }
    end; { MapFileMemory }


    procedure UnMapFileMemory;
    begin { UnMapFileMemory }
    {Delete our process wide memory mapped variable}
    if (lpHookRec &lt;> Nil) then
    begin
    UnMapViewOfFile (lpHookRec);
    lpHookRec := Nil
    end { (lpHookRec &lt;> Nil) };
    if (hObjHandle > 0) then
    begin
    CloseHandle (hObjHandle);
    hObjHandle := 0
    end { (hObjHandle > 0) }
    end; { UnMapFileMemory }


    function GetHookRecPointer : pointer
    stdcall;
    begin { GetHookRecPointer }
    {Return a pointer to our process wide memory mapped variable}
    Result := lpHookRec
    end; { GetHookRecPointer }


    {The function that actually processes the keystrokes for our hook}
    function KeyBoardProc (code: Integer; wParam: Integer; lParam: Integer) :
    Integer;
    stdcall;
    var
    KeyUp : bool;
    {Remove comments for additional functionability
    IsAltPressed : bool;
    IsCtrlPressed : bool;
    IsShiftPressed : bool;
    }
    begin { KeyBoardProc }
    Result := 0;

    Case code Of
    HC_ACTION:
    begin
    {We trap the keystrokes here}
    {Is this a key up message?}
    KeyUp := ((lParam and (1 shl 31)) &lt;> 0);

    (*Remove comments for additional functionability
    {Is the Alt key pressed}
    if ((lParam and (1 shl 29)) &lt;> 0) then begin
    IsAltPressed := TRUE;
    end else begin
    IsAltPressed := FALSE;
    end;

    {Is the Control key pressed}
    if ((GetKeyState(VK_CONTROL) and (1 shl 15)) &lt;> 0) then begin
    IsCtrlPressed := TRUE;
    end else begin
    IsCtrlPressed := FALSE;
    end;

    {if the Shift key pressed}
    if ((GetKeyState(VK_SHIFT) and (1 shl 15)) &lt;> 0) then begin
    IsShiftPressed := TRUE;
    end else begin
    IsShiftPressed := FALSE;
    end;
    *)
    {if KeyUp then increment the key count}
    if (KeyUp &lt;> false) then
    begin
    inc (lpHookRec^.TheKeyCount)
    end { (KeyUp &lt;> false) };

    Case wParam Of
    {Was the enter key pressed?}
    VK_RETURN:
    begin
    {if KeyUp}
    if (KeyUp &lt;> false) then
    begin
    {Post a bogus message to the window control in our app}
    PostMessage (lpHookRec^.TheCtrlWinHandle, WM_KEYDOWN, 0, 0);
    PostMessage (lpHookRec^.TheCtrlWinHandle, WM_KEYUP, 0, 0)
    end { (KeyUp &lt;> false) };
    {if you wanted to swallow the keystroke then return -1}
    {else if you want to allow the keystroke then return 0}
    Result := 0;
    exit
    end; {VK_RETURN}
    {if the left arrow key is pressed then lets play a joke!}
    VK_LEFT:
    begin
    {if KeyUp}
    if (KeyUp &lt;> false) then
    begin
    {Create a UpArrow keyboard event}
    keybd_event (VK_RIGHT, 0, 0, 0);
    keybd_event (VK_RIGHT, 0, KEYEVENTF_KEYUP, 0)
    end { (KeyUp &lt;> false) };
    {Swallow the keystroke}
    Result := -1;
    exit
    end; {VK_LEFT}
    end { case wParam }; {case wParam}
    {Allow the keystroke}
    Result := 0
    end; {HC_ACTION}
    HC_NOREMOVE:
    begin
    {This is a keystroke message, but the keystroke message}
    {has not been removed from the message queue, since an}
    {application has called PeekMessage() specifying PM_NOREMOVE}
    Result := 0;
    exit
    end;
    end { case code }; {case code}
    if (code &lt; 0) then
    {Call the next hook in the hook chain}
    Result := CallNextHookEx (lpHookRec^.TheHookHandle, code, wParam, lParam)
    end; { KeyBoardProc }


    procedure StartKeyBoardHook
    stdcall;
    begin { StartKeyBoardHook }
    {if we have a process wide memory variable}
    {and the hook has not already been set...}
    if ((lpHookRec &lt;> Nil) and (lpHookRec^.TheHookHandle = 0)) then
    begin
    {Set the hook and remember our hook handle}
    lpHookRec^.TheHookHandle := SetWindowsHookEx (WH_KEYBOARD, @KeyBoardProc,
    HInstance, 0)
    end { ((lpHookRec &lt;> Nil) and (lpHookRec^.TheHookHandle = 0)) }
    end; { StartKeyBoardHook }


    procedure StopKeyBoardHook
    stdcall;
    begin { StopKeyBoardHook }
    {if we have a process wide memory variable}
    {and the hook has already been set...}
    if ((lpHookRec &lt;> Nil) and (lpHookRec^.TheHookHandle &lt;> 0)) then
    begin
    {Remove our hook and clear our hook handle}
    if (UnHookWindowsHookEx (lpHookRec^.TheHookHandle) &lt;> false) then
    begin
    lpHookRec^.TheHookHandle := 0
    end { (UnHookWindowsHookEx (lpHookRec^.TheHookHandle) &lt;> false) }
    end { ((lpHookRec &lt;> Nil) and (lpHookRec^.TheHookHandle &lt;> 0)) }
    end; { StopKeyBoardHook }


    procedure DllEntryPoint (dwReason: DWord);
    begin { DllEntryPoint }
    Case dwReason Of
    Dll_Process_Attach:
    begin
    {if we are getting mapped into a process, then get}
    {a pointer to our process wide memory mapped variable}
    hObjHandle := 0;
    lpHookRec := Nil;
    MapFileMemory (sizeof (lpHookRec^))
    end;
    Dll_Process_Detach:
    begin
    {if we are getting unmapped from a process then, remove}
    {the pointer to our process wide memory mapped variable}
    UnMapFileMemory
    end;
    end { case dwReason }
    end; { DllEntryPoint }


    Exports
    KeyBoardProc name 'KEYBOARDPROC',
    GetHookRecPointer name 'GETHOOKRECPOINTER',
    StartKeyBoardHook name 'STARTKEYBOARDHOOK',
    StopKeyBoardHook name 'STOPKEYBOARDHOOK';

    begin
    {Set our Dll's main entry point}
    DLLProc := @DllEntryPoint;
    {Call our Dll's main entry point}
    DllEntryPoint (Dll_Process_Attach)
    end.
    آخرین ویرایش به وسیله hr110 : چهارشنبه 15 اسفند 1386 در 16:20 عصر

  13. #93
    کاربر تازه وارد
    تاریخ عضویت
    فروردین 1383
    پست
    56
    این هم یکی دیگر
    کد خطا های زمان اجرای دلفی

    1 Invalid function number
    2 File not found
    3 Path not found
    4 Too many open files
    5 File access denied
    6 Invalid file handle
    12 Invalid file access code
    15 Invalid drive number
    16 Cannot remove current directory
    17 Cannot rename across drives
    100 Disk read error
    101 Disk write error
    102 File not assigned
    103 File not open
    104 File not open for input
    105 File not open for output
    106 Invalid numeric format
    200 Division by zero
    201 Range check error
    202 Stack overflow error
    203 Heap overflow error
    204 Invalid pointer operation
    205 Floating point overflow
    206 Floating point underflow
    207 Invalid floating point operation
    210 Object not initialized
    211 Call to abstract method
    212 Stream registration error
    213 Collection index out of range
    214 Collection overflow error
    215 Arithmetic overflow error
    216 General protection fault

    آخرین ویرایش به وسیله hr110 : چهارشنبه 15 اسفند 1386 در 16:20 عصر

  14. #94
    نشان دادن تمام گزینه های منو در روی دکمه برنامه در Taskbar:

    در حالت عادی سه گزینه در منو وجود داره که با این روش همه گزینه های استاندارد نشان داده خواهند شد!! :shock:

    فقط همین:
    GetSystemMenu(Application.handle,true);


    در حقیقت این دستور با خوارج کردن کنترل منو ها از دست برنامه این کار را انجام می دهد :shock:
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:52 عصر

  15. #95
    کاربر تازه وارد
    تاریخ عضویت
    فروردین 1383
    پست
    56
    با سلام خدمت دوستان عزیز
    و با تشکر ا کد های بسیار جذاب دوستان
    زمان آخرین دسترسی به یک فایل


    function GetFileLastAccessTime(
    sFileName : string ) : TDateTime;
    var
    ffd : TWin32FindData;
    dft : DWord;
    lft : TFileTime;
    h : THandle;
    begin
    //
    // get file information
    h := Windows.FindFirstFile(
    PChar(sFileName), ffd);
    if(INVALID_HANDLE_VALUE &lt;> h)then
    begin
    //
    // we're looking for just one file,
    // so close our "find"
    Windows.FindClose( h );
    //
    // convert the FILETIME to
    // local FILETIME
    FileTimeToLocalFileTime(
    ffd.ftLastAccessTime, lft );
    //
    // convert FILETIME to
    // DOS time
    FileTimeToDosDateTime(lft,
    LongRec(dft).Hi, LongRec(dft).Lo);
    //
    // finally, convert DOS time to
    // TDateTime for use in Delphi's
    // native date/time functions
    Result := FileDateToDateTime(dft);
    end;
    end;

    مثالی در رابطه با برنامه بالا

    MessageDlg(
    'c:\config.sys was last accessed on ' +
    DateTimeToStr(
    GetFileLastAccessTime( 'c:\config.sys' ) ),
    mtInformation, [mbOk], 0 );
    آخرین ویرایش به وسیله hr110 : چهارشنبه 15 اسفند 1386 در 16:21 عصر

  16. #96
    فهمیدن اینکه آیا یک ایمیل از نظر املایی درست است یا نه!
    اصلاح شد: اکنون ایمیلهای یا قالب<span dir=ltr> email.mail@Site.com</span>رو پشتیبانی میکنه!
    Function IsValidMail(mail:string):Boolean;
    var
    i,Dot,AtSine:longInt;
    tmpMail:string;
    ch:char;
    begin
    result:=false;
    If mail='' then exit;
    tmpMail:=lowercase(mail);
    AtSine:=pos('@',tmpMail);
    Dot:=PosEx('.',tmpMail,atsine);
    If Dot>AtSine then begin
    for i:=1 to length(tmpMail) do begin
    ch:=(tmpMail[i]);
    If not( (ch in ['a'..'z']) or (ch in ['0'..'9']) or (ch in ['-','_','.']) ) then
    begin
    Result:=false;
    Exit;
    end;
    end;
    Result:=True;
    end;
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:52 عصر

  17. #97
    حذف داده های تکراری از لیست:
    Procedure RemoveDuplicateItem(SrcList,DestList:TStri  ngList);
    var
    i:cardinal;
    index:longint;
    str:string;
    begin
    If not assigned(SrcList) then
    SrcList := TStringList.Create;
    If not assigned(DestList) then
    DestList := TStringList.Create;
    SrcList.Sort;
    for i:=0 to SrcList.Count-1 do begin
    str:=SrcList.Strings[i];
    DestList.Sort;
    index:=0;
    If not DestList.Find(str,index) then begin
    DestList.Insert(index,str);
    end;
    end;
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:53 عصر

  18. #98
    کاربر دائمی آواتار BOB
    تاریخ عضویت
    خرداد 1383
    محل زندگی
    http://www.mshams.ir
    پست
    450
    سلام
    ساده ترین راه برای باز کردن یک فایل توسط برنامه مرتبط با آن :
    WinExec('rundll32.exe url.dll,FileProtocolHandler '+[filePath] ,SW_NORMAL);


    ظاهر شدن پنجره OpenWith برای یک فایل :
    WinExec('rundll32.exe shell32.dll,OpenAs_RunDLL '+[filePath] ,SW_NORMAL);

    چاپ یک فایل HTML :
    WinExec('rundll32.exe MSHTML.DLL,PrintHTML '+[filePath] ,SW_NORMAL);
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:54 عصر

  19. #99
    ایجاد سایه در زیر فرم ها
    type
    Tform1 = class(TForm)
    private
    {/ Private declarations /}
    Procedure CreateParams(Var Params: TCreateParams); override;
    end;

    implementation

    {/$R *.DFM/}

    procedure Tform1.CreateParams(var Params: TCreateParams);
    begin
    inherited;
    if CheckWin32Version(5, 1) then
    Params.WindowClass.Style := Params.WindowClass.style or CS_DROPSHADOW;
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:54 عصر

  20. #100

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

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

    با استفاده از تابع FindInProcessEx می توانید هندل (Handle) یک پروسه مانند با آدرس فایل آن بدست بیاورید.
    توجه: این تابع بر روی پروسه های سیستمی ویندوز های نوع NT مانند NT ، 2000 و XP کار نخواهد کرد. برخی پروسه های سیستمی عبارتند از mdm.exe , inetinfo.exe , svhost.exe و...

    type
    DWORD = Longword;
    BOOL=Boolean;
    UINT=Cardinal;

    const
    TH32CS_SNAPHEAPLIST = $00000001;
    TH32CS_SNAPPROCESS = $00000002;
    TH32CS_SNAPTHREAD = $00000004;
    TH32CS_SNAPMODULE = $00000008;
    TH32CS_INHERIT = $80000000;
    TH32CS_SNAPALL = TH32CS_SNAPHEAPLIST or TH32CS_SNAPPROCESS or
    TH32CS_SNAPTHREAD or TH32CS_SNAPMODULE;

    MAX_MODULE_NAME32 = 255;
    SYNCHRONIZE = $00100000;
    PROCESS_TERMINATE = $0001;
    MAX_PATH = 260;
    kernel32 = 'kernel32.dll';

    type
    TProcessEntry32 = packed record
    dwSize: DWORD;
    cntUsage: DWORD;
    th32ProcessID: DWORD; // this process
    th32DefaultHeapID: DWORD;
    th32ModuleID: DWORD; // associated exe
    cntThreads: DWORD;
    th32ParentProcessID: DWORD; // this process's parent process
    pcPriClassBase: Longint; // Base priority of process's threads
    dwFlags: DWORD;
    szExeFile: array[0..MAX_PATH - 1] of Char;// Path
    end;

    TModuleEntry32 = record
    dwSize: DWORD;
    th32ModuleID: DWORD; // This module
    th32ProcessID: DWORD; // owning process
    GlblcntUsage: DWORD; // Global usage count on the module
    ProccntUsage: DWORD; // Module usage count in th32ProcessID's context
    modBaseAddr: PBYTE; // Base address of module in th32ProcessID's context
    modBaseSize: DWORD; // Size in bytes of module starting at modBaseAddr
    hModule: HMODULE; // The hModule of this module in th32ProcessID's context
    szModule: array[0..MAX_MODULE_NAME32] of Char;
    szExePath: array[0..MAX_PATH - 1] of Char;
    end;

    function CreateToolhelp32Snapshot (dwFlags, th32ProcessID: DWORD): THandle stdcall;external kernel32 name 'CreateToolhelp32Snapshot';
    function Process32First(hSnapshot: THandle; var lppe: TProcessEntry32): BOOL stdcall;external kernel32 name 'Process32First';
    function Process32Next(hSnapshot: THandle; var lppe: TProcessEntry32): BOOL stdcall;external kernel32 name 'Process32Next';
    function OpenProcess(dwDesiredAccess: DWORD; bInheritHandle: BOOL; dwProcessId: DWORD): THandle; stdcall;external kernel32 name 'OpenProcess';
    function TerminateProcess(hProcess: THandle; uExitCode: UINT): BOOL; stdcall;external kernel32 name 'TerminateProcess';

    function Module32First(hSnapshot: THandle; var lpme: TModuleEntry32): BOOL stdcall;external kernel32 name 'Module32First';
    function Module32Next(hSnapshot: THandle; var lpme: TModuleEntry32): BOOL stdcall;external kernel32 name 'Module32Next';

    Function FindInProcess(name:string;SearchInOther&#5 8;Boolean;var FileName:string):THandle;
    Function FindInProcessEx(name:string;SearchInOther& #58;Boolean;var FileName:string):THandle;
    Function GetProcessFilePath(name:string;ProcessID&# 58;DWORD;findexe:boolean):string;

    implementation

    Function FindInProcess(name:string;SearchInOther&#5 8;Boolean;var FileName:string):THandle;
    var
    fData: TProcessEntry32;
    fHandler: THandle;
    fFileN:string;

    Function SearchProcess:THandle;
    begin
    fFileN:=fData.szExeFile;
    fFileN:=extractFileName(fFileN);
    result:=0;
    name:=LowerCase(name);
    fFileN:=LowerCase(fFileN);
    If name=fFileN then //SYNCHRONIZE or PROCESS_TERMINATE
    //Result:=OpenProcess(PROCESS_ALL_ACCESS or PROCESS_TERMINATE or SYNCHRONIZE , False,fData.th32ProcessID)
    Result:=OpenProcess(SYNCHRONIZE or PROCESS_TERMINATE , False,fData.th32ProcessID)
    else begin
    If SearchInOther then
    If pos(name,fFileN)<>0 then begin
    //Result:=OpenProcess(PROCESS_ALL_ACCESS or SYNCHRONIZE or PROCESS_TERMINATE, False,fData.th32ProcessID);
    Result:=OpenProcess(SYNCHRONIZE or PROCESS_TERMINATE, False,fData.th32ProcessID);
    FileName:=fData.szExeFile ;
    end;
    end;
    end;

    begin
    fData.dwSize := SizeOf(fData);
    fHandler := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
    result:=0;
    FileName:='';
    try
    if Process32First(fHandler, fData) then
    begin
    result:=SearchProcess;
    If result<>0 then exit;

    while Process32Next(fHandler, fData) do
    begin
    result:=SearchProcess;
    If result<>0 then exit;
    end;
    end;
    finally
    CloseHandle(fHandler);
    end;

    end;

    Function FindInProcessEx(name:string;SearchInOther& #58;Boolean;var FileName:string):THandle;
    var
    fData: TProcessEntry32;
    fHandler: THandle;
    fFileN:string;

    Function SearchProcess:THandle;
    begin
    fFileN:=fData.szExeFile;
    fFileN:=extractFileName(fFileN);
    result:=0;
    name:=LowerCase(name);
    fFileN:=LowerCase(fFileN);
    If name=fFileN then
    Result:=OpenProcess(SYNCHRONIZE or PROCESS_TERMINATE , False,fData.th32ProcessID)
    else begin
    If SearchInOther then
    If pos(name,fFileN)<>0 then begin
    Result:=OpenProcess(SYNCHRONIZE or PROCESS_TERMINATE, False,fData.th32ProcessID);
    FileName:=GetProcessFilePath(name,fData.th 32ProcessID,true);
    if FileName='' then
    FileName:=fData.szExeFile;
    end;
    end;
    end;

    begin
    fData.dwSize := SizeOf(fData);
    fHandler := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
    result:=0;
    FileName:='';
    try
    if Process32First(fHandler, fData) then
    begin
    result:=SearchProcess;
    If result<>0 then exit;

    while Process32Next(fHandler, fData) do
    begin
    result:=SearchProcess;
    If result<>0 then exit;
    end;
    end;
    finally
    CloseHandle(fHandler);
    end;

    end;

    Function GetProcessFilePath(name:string;ProcessID&# 58;DWORD;findexe:boolean):string;
    var
    fData: TModuleEntry32;
    fHandler: THandle;
    fFileN:string;
    tmpResult:string;

    function GetFileName:string ;
    begin
    result:='';
    If pos(name,fFileN)<>0 then begin
    if findexe then begin
    if pos('.exe',fFileN)<>0 then
    result:=fData.szExePath;
    end else
    result:=fData.szExePath;
    tmpResult:=fData.szExePath;
    end;
    end;

    begin
    fData.dwSize := SizeOf(fData);
    fHandler := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, ProcessID);
    tmpResult:='';
    result:='';
    fFileN:='';
    name:=LowerCase(name);
    try
    if Module32First(fHandler, fData) then
    begin
    fFileN:=extractFileName(LowerCase(fDat a.szExePath));
    result:=GetFileName;
    if result<>'' then
    exit;
    while Module32Next(fHandler, fData) do
    begin
    fFileN:=extractFileName(LowerCase(fDat a.szExePath));
    result:=GetFileName;
    if result<>'' then
    exit;
    end;
    end;
    if (findexe) and (result='') then
    result:=tmpResult;
    finally
    CloseHandle(fHandler);
    end;
    end;

    منبع:
    http://www.salarsoft.somee.com/questions/q_findprc.htm
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:55 عصر

  21. #101

    تقریبا کلیه فانکشن هایی که برای کار با فلاپی نیاز میشه ...

    unit lDrives;
    interface
    uses Forms, Messages, Classes, WinProcs, WinTypes, SysUtils,
    Dialogs, Controls;

    const
    MsgAskDefault = 'Please insert a disk on drive %s:';
    MsgWProtected = 'Error: The disk %s is write-protected.';

    type
    TDriveType = (dtAll,dtFixed,dtRemovable,dtRemote{$IFDEF WIN32},dtCDRom,dtRamDisk{$ENDIF});

    function ComposeFileName (Dir,Name:string):string;
    function HasDiskSpace({$IFDEF WIN32}Drive: string{$ELSE}Drive: char{$ENDIF}; MinRequired: LongInt): boolean;
    function GetDirectorySize(const Path: string): LongInt;
    function GetFileSizeByName(const Filename: string): longInt;
    function IsDiskRemovable(Drive: char): boolean;
    function IsDiskInDrive(Drive: char): boolean;
    function IsDiskWriteProtected(Drive: char): boolean;
    function AskForDisk(Drive: char; Msg: string; CheckWriteProtected: boolean): boolean;
    procedure GetAvailableDrives(DriveType: TDriveType; Items: TStrings);

    implementation function ComposeFileName (Dir,Name:string):string;
    var
    Separator: string[1];
    begin
    if (length(Dir) > 0) and (Dir[length(Dir)]='\') then
    delete(Dir, length(Dir), 1);
    if (length(Name) > 0) and (Name[1]='\') then
    delete(Name, 1, 1);
    if Name='' then Separator:='' else Separator:='\';
    result:=format('%s%s%s',[Dir,Separator,Name]);
    end;

    function HasDiskSpace(Drive: {$IFDEF WIN32}string{$ELSE}char{$ENDIF}; MinRequired: LongInt): boolean;
    begin
    if Drive='' then Drive:='C';
    {$IFDEF WIN32}
    result:=((GetDriveType(PChar(Drive))<>0) and
    (SysUtils.DiskFree(Ord(UpCase(Drive[1]))-$40)=-1) or
    (SysUtils.DiskFree(Ord(UpCase(Drive[1]))-$40)>=MinRequired));
    {$ELSE}
    result:=((GetDriveType(Ord(UpCase(Drive))-$40)<>0) and
    (DiskFree(Ord(UpCase(Drive))-$40)=-1) or
    (DiskFree(Ord(UpCase(Drive))-$40)>=MinRequired));
    {$ENDIF}
    end;

    function GetDirectorySize(const Path: string): LongInt;
    var
    S: TSearchRec;
    TotalSize: LongInt;
    begin
    TotalSize:=0;
    if FindFirst(ComposeFileName(Path,'*.*'), faAnyFile, S)=0 then
    repeat
    Inc(TotalSize, S.Size);
    until FindNext(S)<>0;
    result:=TotalSize;
    end;

    function GetFileSizeByName(const Filename: string): longInt;
    var
    F: File;
    begin
    AssignFile(F, Filename);
    Reset(F,1);
    result:=FileSize(F);
    CloseFile(F);
    end;

    function IsDiskRemovable(Drive: char): boolean;
    begin
    {$IFDEF WIN32}
    result:=GetDriveType(PChar(Drive+':\'))=DRIVE_REMO VABLE;
    {$ELSE}
    result:=GetDriveType(ord(UpCase(Drive))-65)=DRIVE_REMOVABLE;
    {$ENDIF}
    end;

    function IsDiskInDrive(Drive: char): Boolean;
    var
    ErrorMode: word;
    begin
    Drive:=Upcase(Drive);
    if not (Drive in ['A'..'Z']) then
    begin
    Result:=False;
    Exit;
    end;
    ErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
    try
    if DiskSize(Ord(Drive) - 64) = -1 then
    Result := False
    else
    Result := True;
    finally
    SetErrorMode(ErrorMode);
    end;
    end;

    function IsDiskWriteProtected(Drive: char): Boolean;
    var
    F: File;
    ErrorMode: Word;
    begin
    ErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
    AssignFile(F,Drive+':\_$.$ );
    try
    try
    Rewrite(F);
    CloseFile(F);
    Erase(F);
    Result:=False;
    except
    Result:=True;
    end;
    finally
    SetErrorMode(ErrorMode);
    end;
    end;

    {$IFDEF WIN32}
    procedure GetAvailableDrives(DriveType: TDriveType; Items: TStrings);
    var
    Drive: Integer;
    DriveLetter: string;
    begin
    Items.Clear;
    for Drive := 0 to 25 do
    begin
    DriveLetter := Chr(Drive + ord('A'))+':\';
    case DriveType of
    dtAll : if GetDriveType(PChar(DriveLetter)) in [DRIVE_REMOVABLE,DRIVE_FIXED,DRIVE_REMOTE,
    DRIVE_CDROM,DRIVE_RAMDISK] then
    Items.Add(DriveLetter);
    dtRemovable: if GetDriveType(PChar(DriveLetter))=DRIVE_REMOVABLE then
    Items.Add(DriveLetter);
    dtFixed : if GetDriveType(PChar(DriveLetter))=DRIVE_FIXED then
    Items.Add(DriveLetter);
    dtRemote : if GetDriveType(PChar(DriveLetter))=DRIVE_REMOTE then
    Items.Add(DriveLetter);
    dtCDRom : if GetDriveType(PChar(DriveLetter))=DRIVE_CDROM then
    Items.Add(DriveLetter);
    dtRamDisk : if GetDriveType(PChar(DriveLetter))=DRIVE_RAMDISK then
    Items.Add(DriveLetter);
    end;
    end;
    end;
    {$ELSE}
    procedure GetAvailableDrives(DriveType: TDriveType; Items: TStrings);
    var
    Drive: Integer;
    DriveLetter: char;
    begin
    Items.Clear;
    for Drive := 0 to 25 do
    begin
    DriveLetter := Chr(Drive + ord('A'));
    case DriveType of
    dtAll : if GetDriveType(Drive) in [DRIVE_REMOVABLE,DRIVE_FIXED,DRIVE_REMOTE] then
    Items.Add(DriveLetter+':\');
    dtRemovable: if GetDriveType(Drive)=DRIVE_REMOVABLE then
    Items.Add(DriveLetter+':\');
    dtFixed : if GetDriveType(Drive)=DRIVE_FIXED then
    Items.Add(DriveLetter+':\');
    dtRemote : if GetDriveType(Drive)=DRIVE_REMOTE then
    Items.Add(DriveLetter+':\');
    end;
    end;
    end;
    {$ENDIF}

    function AskForDisk(Drive: char; Msg: string; CheckWriteProtected: boolean): boolean;
    var
    Ready : boolean;
    begin
    Ready:=false; Result:=false;
    if Msg='' then Msg:=Format(MsgAskDefault,[Drive]);
    while not(Ready) do
    try
    if IsDiskRemovable(Drive) then
    case MessageDlg(Msg, mtConfirmation, [mbOk,mbCancel],0) of
    mrOk : ready:=IsDiskInDrive(Drive);
    mrCancel: exit;
    end
    else
    Ready:=true;
    except
    result:=false;
    exit;
    end;
    ready:=false;
    while not(Ready) do
    try
    if CheckWriteProtected and IsDiskWriteProtected(Drive) then
    begin
    ready:=false;
    if MessageDlg(Format(MsgWProtected,[Upcase(Drive)+':']),mtError,[mbRetry,mbCancel],0)=mrCancel then
    exit;
    end
    else
    ready:=true;
    except
    result:=false;
    exit;
    end;
    result:=Ready;
    end;

    end.

    آخرین ویرایش به وسیله Keramatifar : سه شنبه 01 شهریور 1384 در 20:25 عصر

  22. #102

    بدست آوردن پسورد فایلهای اکسس 97

     Procedure GetMDB97PassWord; 

    Const
    XorArr : Array[0..12] of Byte =
    ($86,$FB,$EC,$37,$5D,$44,$9C,$FA,$C6,$5E,$28,$E6,$ 13);

    Var
    I : Integer;
    S1 : String;
    FI : File of Byte;
    By : Byte;
    Access97 : Boolean;
    FileError : Boolean;

    Begin
    // Init
    FileError := False;
    Access97 := True;

    // Open *.mbd file
    AssignFile(FI,Filename);
    Reset(FI);

    // Read file
    I := 0;
    Repeat
    If not Eof(FI) then
    Begin
    Read(FI,By);
    Inc(I);
    End;
    Until (I = $42) or Eof(FI);
    If Eof(FI) then
    FileError := True;

    // Read password string
    S1 := '';
    For I := 0 to 12 do
    If not Eof(FI) then
    Begin
    Read(f,By);
    S1 := S1 + Chr(By);
    End;

    If Eof(FI) then
    FileError := True;

    //Close file
    CloseFile(FI);

    // Is nul string?
    If S1 = #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 then
    Access97 := False;

    // Decode string
    For I := 0 to 12 do
    S1[I + 1] := Chr(Ord(S[I + 1]) xor XORArr[I]);

    // Find end of string
    I := Pos(#0,S1);
    If I = 1 then
    S1 := '';
    If I > 1 then
    S1 := Copy(S1,1,I);

    If Access97 then
    Begin
    If Length(S1) > 0 then
    ShowMessage := ('The password is: "' + S1 + '".')
    else
    ShowMessage ('The file is NOT password protected.');
    End
    else
    ShowMessage('The file is not an Access 97 file.');

    If FileError then
    ShowMessage('File error');

    End;



  23. #103

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

    یکی از DLL های ویندوز به نام Winmm.dll دارای فانکشنی به نام waveOutGetNumDevs است که با استفاده از آن می توانید چک کنید کارت صدا در سیستم نصب شده است یا نه ...
    ابتدا باید به این صورت تابع را تعریف کنید :
     
    function IsSoundcardInstalled: longint; stdcall;
    external 'winmm.dll'
    name 'waveOutGetNumDevs';


    و بدین صورت از آن استفاده کنید:

     
    if IsSoundcardInstalled > 0 then
    ShowMessage('Soundcard is there...');

  24. #104

    بدست آوردن و تنظیم کردن صدا در سیستم

     

    procedure GetVolume(var volL, volR: Word);
    var
    hWO: HWAVEOUT;
    waveF: TWAVEFORMATEX;
    vol: DWORD;
    begin
    volL:= 0;
    volR:= 0;
    // init TWAVEFORMATEX
    FillChar(waveF, SizeOf(waveF), 0);
    // open WaveMapper = std output of playsound
    waveOutOpen(@hWO, WAVE_MAPPER, @waveF, 0, 0, 0);
    // get volume
    waveOutGetVolume(hWO, @vol);
    volL:= vol and $FFFF;
    volR:= vol shr 16;
    waveOutClose(hWO);
    end;


    procedure SetVolume(const volL, volR: Word);
    var
    hWO: HWAVEOUT;
    waveF: TWAVEFORMATEX;
    vol: DWORD;
    begin
    // init TWAVEFORMATEX
    FillChar(waveF, SizeOf(waveF), 0);
    // open WaveMapper = std output of playsound
    waveOutOpen(@hWO, WAVE_MAPPER, @waveF, 0, 0, 0);
    vol:= volL + volR shl 16;
    // set volume
    waveOutSetVolume(hWO, vol);
    waveOutClose(hWO);
    end;


  25. #105

    چگونه دکمه Caps Lock را روشن و خاموش کنیم

    ابتدا باید فانکشن را به این صورت تعریف کنید:

     
    procedure SetCapsLockKey( vcode: Integer; down: Boolean );
    begin
    if Odd(GetAsyncKeyState( vcode )) <> down then
    begin
    keybd_event( vcode, MapVirtualkey( vcode, 0 ),
    KEYEVENTF_EXTENDEDKEY, 0);
    keybd_event( vcode, MapVirtualkey( vcode, 0 ),
    KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP, 0);
    end;
    end;



    سپس به این صورت از آن استفاده کنید:

     SetCapsLockKey( VK_CAPITAL, True );


    توجه:
    فانکشن های 'keybd_event', 'MapVirtualkey' , 'GetAsyncKeyState از فانشکن های API ویندوز هستند ...

  26. #106

    چگونه می توان از جابجایی فرم جلوگیری کرد ...

    به سادگی با استفاده از این کد:
     
    type
    TyourForm = class(TForm)
    private
    { Private declarations }
    procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
    end;

    procedure TyourForm.WMNCHitTest(var Message: TWMNCHitTest);
    begin
    inherited;

    with Message do
    if Result = HTCAPTION then
    Result := HTNOWHERE;
    end;


  27. #107

    چگونه می توان RecycleBin را خالی کرد ...

    با استفاده از این کد می توانید سطل زباله ویندوز را خالی کنید ...
     
    Procedure EmptyRecycleBin ;
    Const
    SHERB_NOCONFIRMATION = $00000001 ;
    SHERB_NOPROGRESSUI = $00000002 ;
    SHERB_NOSOUND = $00000004 ;
    Type
    TSHEmptyRecycleBin = function (Wnd : HWND;
    pszRootPath : PChar;
    dwFlags : DWORD
    ) : HRESULT; stdcall ;
    Var
    SHEmptyRecycleBin : TSHEmptyRecycleBin;
    LibHandle : THandle;
    Begin { EmptyRecycleBin }
    LibHandle := LoadLibrary(PChar('Shell32.dll')) ;
    if LibHandle <> 0 then
    @SHEmptyRecycleBin := GetProcAddress(LibHandle, 'SHEmptyRecycleBinA')
    else
    begin
    MessageDlg('Failed to load Shell32.dll.', mtError, [mbOK], 0);
    Exit;
    end;


    if @SHEmptyRecycleBin <> nil then
    SHEmptyRecycleBin(Application.Handle,
    nil,
    SHERB_NOCONFIRMATION or SHERB_NOPROGRESSUI or SHERB_NOSOUND);
    FreeLibrary(LibHandle);
    @SHEmptyRecycleBin := nil ;
    end;



    نکته مهم:

    البته سعی کنید این کار را قبل از ساعت 9 شب انجام دهید

  28. #108

    فرمت کردن یک دریاو در win32

    با استفاده از این کد می توانید یک درایو را در win32 فرمت کنید:

     const SHFMT_DRV_A = 0;
    const SHFMT_DRV_B = 1;
    const SHFMT_ID_DEFAULT = $FFFF;
    const SHFMT_OPT_QUICKFORMAT = 0;
    const SHFMT_OPT_FULLFORMAT = 1;
    const SHFMT_OPT_SYSONLY = 2;
    const SHFMT_ERROR = -1;
    const SHFMT_CANCEL = -2;
    const SHFMT_NOFORMAT = -3;
    function SHFormatDrive(hWnd : HWND;
    Drive : Word;
    fmtID : Word;
    Options : Word) : Longint
    stdcall; external 'Shell32.dll' name 'SHFormatDrive';
    procedure TForm1.Button1Click(Sender: TObject);
    var
    FmtRes : longint;
    begin
    try
    FmtRes:= ShFormatDrive(Handle,
    SHFMT_DRV_A,
    SHFMT_ID_DEFAULT,
    SHFMT_OPT_QUICKFORMAT);
    case FmtRes of
    SHFMT_ERROR : ShowMessage('Error formatting the drive');
    SHFMT_CANCEL :
    ShowMessage('User canceled formatting the drive');
    SHFMT_NOFORMAT : ShowMessage('No Format')
    else
    ShowMessage('Disk has been formatted');
    end;
    except
    end;
    end;

  29. #109

    عوض کردن wallpaper

    preocedure wallpaper;
    begin
    systemparametersinfo(spi_setdeskwallpaper,0,pchar( 'f:paniz.bmp'),0);
    end;
    با تشکر از دوست محترمی که این قسمت را ایجاد کردند .
    امید وارم که ادامه داشته باشد.
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:56 عصر

  30. #110
    این یه کد برای نوشتن یک عدد به حروف
    Function TMB.Get1nd(i:integer):String;
    Begin
    case i of
    0: Get1nd:=' &Otilde;&Yacute;&Ntilde; '; {zero}
    1: Get1nd:=' &iacute;&szlig;&thorn; '; {one}
    2: Get1nd:=' &Iuml;&aelig; '; {two}
    3: Get1nd:=' &Oacute;&aring; '; {three}
    4: Get1nd:=' &aring;&Ccedil;&Ntilde; '; {four}
    5: Get1nd:=' &auml;&Igrave; '; {five}
    6: Get1nd:=' &Ocirc;&Ocirc; '; {}
    7: Get1nd:=' &aring;&Yacute;&Ecirc; '; {}
    8: Get1nd:=' &aring;&Ocirc;&Ecirc; '; {}
    9: Get1nd:=' &auml;&aring; '; {}
    10: Get1nd:=' &Iuml;&aring; '; {}
    11: Get1nd:=' &iacute;&Ccedil;&Ograve;&Iuml;&aring;&thorn; '; {}
    12: Get1nd:=' &Iuml;&aelig;&Ccedil;&Ograve;&Iuml;&aring; '; {}
    13: Get1nd:=' &Oacute;&iacute;&Ograve;&Iuml;&aring; '; {}
    14: Get1nd:=' &aring;&Ccedil;&Ntilde;&Iuml;&aring; '; {}
    15: Get1nd:=' &Ccedil;&auml;&Ograve;&Iuml;&aring; '; {}
    16: Get1nd:=' &Ocirc;&Ccedil;&auml;&Ograve;&Iuml;&aring; '; {}
    17: Get1nd:=' &aring;&Yacute;&Iuml;&aring; '; {}
    18: Get1nd:=' &aring;&Igrave;&Iuml;&aring; '; {}
    19: Get1nd:=' &auml;&aelig;&Ograve;&Iuml;&aring; '; {}
    End;
    End;
    Function TMB.Get2nd(i:Integer):String;
    Begin
    case i of
    2: Get2nd:=' &Egrave;&iacute;&Oacute;&Ecirc; '; {}
    3: Get2nd:=' &Oacute;&iacute; '; {}
    4: Get2nd:=' &aring;&aacute; '; {}
    5: Get2nd:=' &auml;&Igrave;&Ccedil;&aring; '; {}
    6: Get2nd:=' &Ocirc;&Otilde;&Ecirc; '; {}
    7: Get2nd:=' &aring;&Yacute;&Ecirc;&Ccedil;&Iuml; '; {}
    8: Get2nd:=' &aring;&Ocirc;&Ecirc;&Ccedil;&Iuml; '; {}
    9: Get2nd:=' &auml;&aelig;&Iuml; '; {}
    End;
    End;
    Function TMB.Get3nd(i:Integer):String;
    Begin
    case i of
    1: Get3nd:=' &iacute;&szlig;&Otilde;&Iuml;&thorn; '; {}
    2: Get3nd:=' &Iuml;&aelig;&iacute;&Oacute;&Ecirc; '; {}
    3: Get3nd:=' &Oacute;&iacute;&Otilde;&Iuml; '; {}
    4: Get3nd:=' &aring;&Ccedil;&Ntilde;&Otilde;&Iuml; '; {}
    5: Get3nd:=' &Ccedil;&auml;&Otilde;&Iuml; '; {}
    6: Get3nd:=' &Ocirc;&Ocirc;&Otilde;&Iuml; '; {}
    7: Get3nd:=' &aring;&Yacute;&Ecirc;&Otilde;&Iuml; '; {}
    8: Get3nd:=' &aring;&Ocirc;&Ecirc;&Otilde;&Iuml; '; {}
    9: Get3nd:=' &auml;&aring;&Otilde;&Iuml; '; {}
    End;
    End;
    Function TMB.GetTree(i:Integer):String;
    var
    a:String;
    Begin
    a:='';
    if (i mod 100)>=20 then
    Begin
    if (i mod 10)>0 then
    a:=Get1nd(i Mod 10)+a;
    if (i mod 100 Div 10)>0 then
    if length(a)>0 then
    a:=Get2nd(i mod 100 Div 10)+'&aelig;'+a
    Else
    a:=Get2nd(i mod 100 Div 10)+a;
    End
    Else if (i mod 100) >0 then
    a:=Get1nd(i Mod 100)+a;
    if (i div 100)>0 then
    if length(a)>0 then
    a:=Get3nd(i Div 100)+'&aelig;'+a
    Else
    a:=Get3nd(i Div 100)+a;
    if i=0 then
    a:=Get1nd(0);
    GetTree:=a;

    End;
    Function TMB.GetNum(Num:LongInt):String;
    var
    a:String;
    i,mod1:Integer;
    Begin
    { GetNum:=GetTree(Num);}
    a:='';
    i:=0;
    repeat
    mod1:=num mod 1000;
    num:=num div 1000;
    if (mod1>0) and (Length(a)>0) then
    a:=' &aelig; '+a;
    if (i=0)And(mod1>0) then
    a:=GetTree(Mod1)+a
    Else if (i=1) and (mod1>0) then
    a:=GetTree(Mod1)+ '&aring;&Ograve;&Ccedil;&Ntilde;'+a {Towsand}
    Else if (i=2) and (mod1>0) then
    a:=GetTree(Mod1)+ '&atilde;&iacute;&aacute;&iacute;&aelig;&auml;'+ a {Milion}
    Else if (i=3) and (mod1>0) then
    a:=GetTree(Mod1)+ '&atilde;&iacute;&aacute;&iacute;&Ccedil;&Ntilde ;& Iuml;'+a; {Miliard}
    i:=i+1;
    Until Num=0;
    GetNum:=a+' '+Vahed;
    End;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:56 عصر
    You never know what you can do until you try

  31. #111
    کاربر دائمی آواتار ali_abbasi22145
    تاریخ عضویت
    آذر 1382
    محل زندگی
    يك جايي در پايتخت
    پست
    1,350
    نقل قول نوشته شده توسط Wish Master
    تغییر 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 و ... استفاده کنید
    سلام
    1-با اخطار دوستم کمی ترسیدم!!! 1024 را مثلا کجا و 768 را کجا وارد کنیم.
    2- می شود اول چک کند که 1024*768 است اگر نباشد به این حالت مانیتور را ببرد.

  32. #112
    کاربر دائمی آواتار Ehsansh
    تاریخ عضویت
    بهمن 1384
    محل زندگی
    127.0.0.1
    سن
    39
    پست
    278

    ذخیره کردن یک فرم به عنوان یک عکس


    procedure TForm1.Button1Click(Sender: TObject);
    var DCWindow: HDC;
    bmp: TBitmap;
    begin
    bmp := TBitmap.Create;
    bmp.Height := Form1.Height;
    bmp.Width := Form1.Width;
    DCWindow := GetWindowDC(Form1.Handle);
    BitBlt(bmp.Canvas.Handle, 0, 0, Form1.Width, Form1.Height,
    DCWindow, 0, 0, SRCCOPY);
    bmp.SaveToFile('C:\ScreenShot.bmp');
    ReleaseDC(DCWindow, DCWindow);
    bmp.Free;
    end;

    اندکی ویرایش
    mzjahromi
    آخرین ویرایش به وسیله Ehsansh : یک شنبه 07 اسفند 1384 در 13:12 عصر

  33. #113

    Wink Drop Dawn کردن آیتم های لیست باکس ...

    اینم کد Drop & Dawn کردن آیتم های لیست باکس
    var // form level
    StartingPoint : TPoint;

    implementation

    ...

    procedure TForm1.FormCreate(Sender: TObject) ;
    begin
    ListBox1.DragMode := dmAutomatic;
    end;

    procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer) ;
    var
    DropPosition, StartPosition: Integer;
    DropPoint: TPoint;
    begin
    DropPoint.X := X;
    DropPoint.Y := Y;
    with Source as TListBox do
    begin
    StartPosition := ItemAtPos(StartingPoint,True) ;
    DropPosition := ItemAtPos(DropPoint,True) ;

    Items.Move(StartPosition, DropPosition) ;
    end;
    end;

    procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean) ;
    begin
    Accept := Source = ListBox1;
    end;

    procedure TForm1.ListBox1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer) ;
    begin
    StartingPoint.X := X;
    StartingPoint.Y := Y;
    end;

  34. #114

    Wink گذاشتن هرگونه عکس بر روی BitBtn ...

    اینم کدش
    var
    bmp: TBitmap;
    begin
    bmp:=TBitmap.Create;
    try
    bmp.Width := Image.Picture.Graphic.Width;
    bmp.Height := Image.Picture.Graphic.Height;
    bmp.Canvas.Draw(0, 0, Image.Picture.Graphic) ;
    BitBtn.Glyph:=bmp;
    finally
    bmp.Free;
    end;
    end;

  35. #115

    Wink نمایش صفحه مشخصات یک فایل ( Properties ) ...

    یک Open Dialog و یک دکمه بر روی فرم بزارید ...

    با کد زیر ، بعد از باز شدن فایل به وسیله Open Dialog و زدن دکمه پنجره خصوصیات فایل نشون داده می شه :
    uses
    shellapi;

    procedure PropertiesDialog(FileName: string);
    var
    sei: TShellExecuteInfo;
    begin
    FillChar(sei, SizeOf(sei), 0);
    sei.cbSize := SizeOf(sei);
    sei.lpFile := PChar(FileName);
    sei.lpVerb := 'properties';
    sei.fMask := SEE_MASK_INVOKEIDLIST;
    ShellExecuteEx(@sei);
    end;


    procedure TForm1.Button1Click(Sender: TObject);
    begin
    if Opendialog1.Execute then
    PropertiesDialog(Opendialog1.FileName);
    end;

  36. #116
    کاربر جدید آواتار mrkh1759
    تاریخ عضویت
    اسفند 1384
    محل زندگی
    IRAN-TEHRAN
    پست
    8

    Lightbulb مشخص نمودن وضعیت اتصال به اینترنت

    تابع زیر مشخص می کنه که سیستم متصل به انترنت هست یا نه
    Compilers Delphi
    Category Internet
    Uses
    Windows,
    WinInet;

    Function ConnectedToInternet:Boolean;
    Var Flags : DWORD;
    Begin
    Flags :=INTERNET_CONNECTION_MODEM or INTERNET_CONNECTION_LAN or INTERNET_CONNECTION_PROXY;
    Result:=InternetGetConnectedState(@Flags, 0);
    End;
    آخرین ویرایش به وسیله mrkh1759 : دوشنبه 08 اسفند 1384 در 13:17 عصر

  37. #117
    کاربر جدید آواتار mrkh1759
    تاریخ عضویت
    اسفند 1384
    محل زندگی
    IRAN-TEHRAN
    پست
    8

    Lightbulb Get User Name

    بدت آوردن نام کاربر
    Uses 
    Windows,
    SysUtils;

    function GetUserName : String;
    var
    Name : PChar;
    Size : DWORD;
    begin
    Size := SizeOf(ShortString);
    GetMem(Name, Size);
    try
    GetUserName(Name, Size);
    Result := Trim(StrPas(Name));
    finally
    FreeMem(Name, Size);
    end;
    end;
    البته دوستان منو ببخشند که دخالت کردیم
    گفتم شاید چند تا ای پی آی که فکر می کنم خوبه بدرد دوستان بخوره
    آخرین ویرایش به وسیله mrkh1759 : دوشنبه 08 اسفند 1384 در 13:15 عصر

  38. #118
    کاربر جدید آواتار mrkh1759
    تاریخ عضویت
    اسفند 1384
    محل زندگی
    IRAN-TEHRAN
    پست
    8

    Extract an Icon from EXE or DLL file

    Uses 
    Windows,
    Graphics,
    ShellApi;

    Procedure GetIcon(Filename,IconFilename:String;SmallIcon:Boo lean);
    Var
    HIcon32 ,
    HIcon16 : HIcon;
    Icon : tIcon;
    Begin
    ExtractIconEx(Pchar(Filename),0,HIcon32,HIcon16,1) ;

    If (HIcon16<>0) and SmallIcon then
    Begin
    Icon:=tIcon.Create;
    Icon.handle:=HIcon16;
    Icon.SaveToFile(IconFilename);
    Icon.Free;
    end else
    If (HIcon32<>0) and not SmallIcon then
    Begin
    Icon:=tIcon.Create;
    Icon.handle:=HIcon32;
    Icon.SaveToFile(IconFilename);
    Icon.Free;
    end;
    End;

  39. #119
    کاربر دائمی آواتار Ehsansh
    تاریخ عضویت
    بهمن 1384
    محل زندگی
    127.0.0.1
    سن
    39
    پست
    278
    این تابع برنامه مورد نظر را اجر میکند و تا زمان خاتمه آن منتظر میماند.

    Function ExecuteAndWait(sExecutableFile : String) : Boolean;
    var
    siInfo : TStartUpInfo;
    piInfo : TProcessInformation;
    begin
    FillChar(siInfo, SizeOf(siInfo), #0);

    with siInfo do begin
    cb := SizeOf(siInfo);
    dwFlags := STARTF_USESHOWWINDOW;
    wShowWindow := SW_SHOWNORMAL;
    end;
    Result := CreateProcess(NIL, pChar(sExecutableFile), NIL, NIL, FALSE, CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, NIL, pchar(ExtractFilePath(sExecutableFile)),siInfo, piInfo);
    if Result then
    WaitForSingleObject(piInfo.hprocess,INFINITE);
    end;


  40. #120
    روشن و خاموش کردن Numlock

    function SetNumLock(Active: Boolean): Boolean;
    begin

    // Check to see if the desired state is set
    if (Active <> ((GetKeyState(VK_NUMLOCK) and 1) = 1)) then
    begin
    // Turn on / off
    keybd_event(VK_NUMLOCK, 45, KEYEVENTF_EXTENDEDKEY, 0);
    keybd_event(VK_NUMLOCK, 45, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP , 0);
    end;

    end;

    You never know what you can do until you try

صفحه 3 از 11 اولاول 12345 ... آخرآخر

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

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

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