بحثهای آف تاپیک به اینجا منتقل شد.
Printable View
بحثهای آف تاپیک به اینجا منتقل شد.
جلوگیری از لیست توماری شدن منو:
Procedure BreakMoreMenu(fSubMenu:TmenuItem;
fMode:TMenuBreak=mbBarBreak);
var
fMnuHeight:Integer;
ScrHeight:Integer;
Count:integer;
i:integer;
items:integer;
begin
fMnuHeight:=GetSystemMetrics(SM_CYMENU) ;;
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;
به چرخش در آوردن متن:
procedure AngleTextOut(Acanvas:Tcanvas;Angle,x,y: ;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;
یافتن فایل در تمام شاخه و زیر شاخه هایش:
اصلاح شد: با نام فایل هایی که فاصله داشتن مشکل داشت!
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;
بدست آوردن 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 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;
فرم شفاف شده و فقط کنترل ها نشان داده شود!:
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 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;
مخفی و ظاهر ساختن عنوان فرم:
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) ;;
fform.Refresh;
end;
end;
end;
خذف یا انتقال فایل در حال اجرا توسط برنامه دیگر ( فقط در ویندوز نوع 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;
تعیین وضعیت مانیتور:
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;
با سلام
طریقه بوت کردن ویندوز 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;
با سلام
چگونه میتوان پنجره اضافه کردن چاپگر را نمایش داد ؟
ShellExecute(Handle, 'open', 'rundll',
'shell32.dll,SHHelpShortcuts_RunDLL AddPrinter', '', SW_SHOWNORMAL);
با سلام
چگونه میتوان کنترل صفحه کلید را در تمامی ویندوزها بدست گرفت ؟
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 <> Nil) then
begin
UnMapViewOfFile (lpHookRec);
lpHookRec := Nil
end { (lpHookRec <> 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)) <> 0);
(*Remove comments for additional functionability
{Is the Alt key pressed}
if ((lParam and (1 shl 29)) <> 0) then begin
IsAltPressed := TRUE;
end else begin
IsAltPressed := FALSE;
end;
{Is the Control key pressed}
if ((GetKeyState(VK_CONTROL) and (1 shl 15)) <> 0) then begin
IsCtrlPressed := TRUE;
end else begin
IsCtrlPressed := FALSE;
end;
{if the Shift key pressed}
if ((GetKeyState(VK_SHIFT) and (1 shl 15)) <> 0) then begin
IsShiftPressed := TRUE;
end else begin
IsShiftPressed := FALSE;
end;
*)
{if KeyUp then increment the key count}
if (KeyUp <> false) then
begin
inc (lpHookRec^.TheKeyCount)
end { (KeyUp <> false) };
Case wParam Of
{Was the enter key pressed?}
VK_RETURN:
begin
{if KeyUp}
if (KeyUp <> 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 <> 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 <> 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 <> 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 < 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 <> 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 <> 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 <> Nil) and (lpHookRec^.TheHookHandle <> 0)) then
begin
{Remove our hook and clear our hook handle}
if (UnHookWindowsHookEx (lpHookRec^.TheHookHandle) <> false) then
begin
lpHookRec^.TheHookHandle := 0
end { (UnHookWindowsHookEx (lpHookRec^.TheHookHandle) <> false) }
end { ((lpHookRec <> Nil) and (lpHookRec^.TheHookHandle <> 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.
این هم یکی دیگر
کد خطا های زمان اجرای دلفی
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
نشان دادن تمام گزینه های منو در روی دکمه برنامه در Taskbar:
در حالت عادی سه گزینه در منو وجود داره که با این روش همه گزینه های استاندارد نشان داده خواهند شد!! :shock:
فقط همین:
GetSystemMenu(Application.handle,true);
در حقیقت این دستور با خوارج کردن کنترل منو ها از دست برنامه این کار را انجام می دهد :shock:
با سلام خدمت دوستان عزیز
و با تشکر ا کد های بسیار جذاب دوستان
زمان آخرین دسترسی به یک فایل
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 <> 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 );
فهمیدن اینکه آیا یک ایمیل از نظر املایی درست است یا نه!
اصلاح شد: اکنون ایمیلهای یا قالب<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;
حذف داده های تکراری از لیست: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;
سلام
ساده ترین راه برای باز کردن یک فایل توسط برنامه مرتبط با آن :
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);
ایجاد سایه در زیر فرم ها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;
پیدا کردن یک پروسه در پروسه های دیگر با نام فایلش
با استفاده از تابع 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 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 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
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.
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;
یکی از DLL های ویندوز به نام Winmm.dll دارای فانکشنی به نام waveOutGetNumDevs است که با استفاده از آن می توانید چک کنید کارت صدا در سیستم نصب شده است یا نه ...
ابتدا باید به این صورت تابع را تعریف کنید :
function IsSoundcardInstalled: longint; stdcall;
external 'winmm.dll'
name 'waveOutGetNumDevs';
و بدین صورت از آن استفاده کنید:
if IsSoundcardInstalled > 0 then
ShowMessage('Soundcard is there...');
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;
ابتدا باید فانکشن را به این صورت تعریف کنید:
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 ویندوز هستند ...
به سادگی با استفاده از این کد:
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;
با استفاده از این کد می توانید سطل زباله ویندوز را خالی کنید ...
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 شب انجام دهید
با استفاده از این کد می توانید یک درایو را در 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;
با تشکر از دوست محترمی که این قسمت را ایجاد کردند .preocedure wallpaper;
begin
systemparametersinfo(spi_setdeskwallpaper,0,pchar( 'f:paniz.bmp'),0);
end;
امید وارم که ادامه داشته باشد.
این یه کد برای نوشتن یک عدد به حروفFunction TMB.Get1nd(i:integer):String;
Begin
case i of
0: Get1nd:=' ÕÝÑ '; {zero}
1: Get1nd:=' íßþ '; {one}
2: Get1nd:=' Ïæ '; {two}
3: Get1nd:=' Óå '; {three}
4: Get1nd:=' åÇÑ '; {four}
5: Get1nd:=' äÌ '; {five}
6: Get1nd:=' ÔÔ '; {}
7: Get1nd:=' åÝÊ '; {}
8: Get1nd:=' åÔÊ '; {}
9: Get1nd:=' äå '; {}
10: Get1nd:=' Ïå '; {}
11: Get1nd:=' íÇÒÏåþ '; {}
12: Get1nd:=' ÏæÇÒÏå '; {}
13: Get1nd:=' ÓíÒÏå '; {}
14: Get1nd:=' åÇÑÏå '; {}
15: Get1nd:=' ÇäÒÏå '; {}
16: Get1nd:=' ÔÇäÒÏå '; {}
17: Get1nd:=' åÝÏå '; {}
18: Get1nd:=' åÌÏå '; {}
19: Get1nd:=' äæÒÏå '; {}
End;
End;
Function TMB.Get2nd(i:Integer):String;
Begin
case i of
2: Get2nd:=' ÈíÓÊ '; {}
3: Get2nd:=' Óí '; {}
4: Get2nd:=' åá '; {}
5: Get2nd:=' äÌÇå '; {}
6: Get2nd:=' ÔÕÊ '; {}
7: Get2nd:=' åÝÊÇÏ '; {}
8: Get2nd:=' åÔÊÇÏ '; {}
9: Get2nd:=' äæÏ '; {}
End;
End;
Function TMB.Get3nd(i:Integer):String;
Begin
case i of
1: Get3nd:=' íßÕÏþ '; {}
2: Get3nd:=' ÏæíÓÊ '; {}
3: Get3nd:=' ÓíÕÏ '; {}
4: Get3nd:=' åÇÑÕÏ '; {}
5: Get3nd:=' ÇäÕÏ '; {}
6: Get3nd:=' ÔÔÕÏ '; {}
7: Get3nd:=' åÝÊÕÏ '; {}
8: Get3nd:=' åÔÊÕÏ '; {}
9: Get3nd:=' äåÕÏ '; {}
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)+'æ'+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)+'æ'+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:=' æ '+a;
if (i=0)And(mod1>0) then
a:=GetTree(Mod1)+a
Else if (i=1) and (mod1>0) then
a:=GetTree(Mod1)+ 'åÒÇÑ'+a {Towsand}
Else if (i=2) and (mod1>0) then
a:=GetTree(Mod1)+ 'ãíáíæä'+ a {Milion}
Else if (i=3) and (mod1>0) then
a:=GetTree(Mod1)+ 'ãíáíÇÑ ;& Iuml;'+a; {Miliard}
i:=i+1;
Until Num=0;
GetNum:=a+' '+Vahed;
End;
سلامنقل قول:
نوشته شده توسط Wish Master
1-با اخطار دوستم کمی ترسیدم!!! 1024 را مثلا کجا و 768 را کجا وارد کنیم.
2- می شود اول چک کند که 1024*768 است اگر نباشد به این حالت مانیتور را ببرد.
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
اینم کد 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;
اینم کدش
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;
یک 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;
تابع زیر مشخص می کنه که سیستم متصل به انترنت هست یا نه
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;
بدت آوردن نام کاربر
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;
گفتم شاید چند تا ای پی آی که فکر می کنم خوبه بدرد دوستان بخوره
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;
این تابع برنامه مورد نظر را اجر میکند و تا زمان خاتمه آن منتظر میماند.
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;
روشن و خاموش کردن 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;