دو ال و أكواد متفرقة

[MjIrIm]

في البداية السلام عليكم


Kill Program

procedure KillProgram(Classname : string; WindowTitle : string);
const
PROCESS_TERMINATE = $0001;
var
ProcessHandle : THandle;
ProcessID: Integer;
TheWindow : HWND;
begin
TheWindow := FindWindow(PChar(Classname),PChar(WindowTitle));
GetWindowThreadProcessID(TheWindow, @ProcessID);
ProcessHandle := OpenProcess(PROCESS_TERMINATE, FALSE, ProcessId);
TerminateProcess(ProcessHandle,4);
end;

Clear The Console Screen

program Project1;
{$APPTYPE CONSOLE}
uses
Windows;
{$R *.RES}
var
sbi : TConsoleScreenBufferInfo;
i : integer;
begin
Writeln('A Console Applicaiton');
Writeln('Press Enter To Clear The Screen');
GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT _HANDLE),sbi);
Readln;
GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT _HANDLE),sbi);
for i := 0 to sbi.dwSize.y do writeln;
Writeln('Press Enter To End');
Readln;
end.

Check Url

uses wininet;

Function CheckUrl(url:string):boolean;
var
hSession, hfile, hRequest: hInternet;
dwindex,dwcodelen :dword;
dwcode:array[1..20] of char;
res : pchar;
begin
if pos('http://',lowercase(url))=0 then
url := 'http://'+url;
Result := false;
hSession := InternetOpen('InetURL:/1.0',INTERNET_OPEN_TYPE_PRECONFIG,nil, nil, 0);
if assigned(hsession) then
begin
hfile := InternetOpenUrl( hsession, pchar(url), nil, 0, INTERNET_FLAG_RELOAD, 0);
dwIndex := 0;
dwCodeLen := 10;
HttpQueryInfo(hfile, HTTP_QUERY_STATUS_CODE, @dwcode, dwcodeLen, dwIndex);
res := pchar(@dwcode);
result:= (res ='200') or (res ='302');
if assigned(hfile) then InternetCloseHandle(hfile);
InternetCloseHandle(hsession);
end;
end

Set Num Lock

procedure SetNumLock(bState:Boolean);
var
KeyState : TKeyboardState;
begin
GetKeyboardState(KeyState);
if ( (bState) and (not ((KeyState[VK_NUMLOCK] and 1)=1) ) or ( (not (bState)) and ((KeyState[VK_NUMLOCK] and 1)=1))) then
// Simulate a key press
keybd_event(VK_NUMLOCK, $45, (KEYEVENTF_EXTENDEDKEY or 0), 0);
// Simulate a key release
keybd_event( VK_NUMLOCK, $45, (KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP), 0);
end;

Print Without TPrinter

uses CommDlg;

{$IFNDEF WIN32}
const MAX_PATH = 144;
{$ENDIF}

procedure TForm1.Button1Click(Sender: TObject);
var
Pd : TPrintDlg;
DocInfo: TDocInfo;
begin
FillChar(Pd, sizeof(Pd), #0);
Pd.lStructSize := sizeof(Pd);
Pd.hWndOwner := Form1.Handle;
Pd.Flags := PD_RETURNDC;
if PrintDlg(pd) then
begin
FillChar(DocInfo, sizeof(DocInfo), #0);
DocInfo.cbSize := SizeOf(DocInfo);
GetMem(DocInfo.lpszDocName, 32);
GetMem(DocInfo.lpszOutput, MAX_PATH);
lStrCpy(DocInfo.lpszDocName, 'My Document');
{Add this line to print to a file }
lStrCpy(DocInfo.lpszOutput, 'C:\Download\Test.doc');
StartDoc(Pd.hDc, DocInfo);
StartPage(Pd.hDc);
TextOut(Pd.hDc, 100, 100, 'Page 1', 6);
EndPage(Pd.hDc);
StartPage(Pd.hDc);
TextOut(Pd.hDc, 100, 100, 'Page 2', 6);
EndPage(Pd.hDc);
EndDoc(Pd.hDc);
FreeMem(DocInfo.lpszDocName, 32);
FreeMem(DocInfo.lpszOutput, MAX_PATH);
end;

Format Drive

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;

Disable Caption Close Button

procedure DisableCaptionCloseButton(const FormHandle: THandle);
var
hMnu: THandle;
begin
hMnu := GetSystemMenu(FormHandle, FALSE);
EnableMenuItem(hMnu, SC_MINIMIZE, SC_CLOSE or MF_GRAYED);
end;

Enable Caption Close Button


procedure EnableCaptionCloseButton(const FormHandle: THandle);
var
hMnu: THandle;
begin
hMnu := GetSystemMenu(FormHandle, FALSE);
EnableMenuItem(hMnu, SC_MINIMIZE, SC_CLOSE or MF_ENABLED);
end;


Font Add

function FontAdd(const FontFilename: string): Boolean;
begin
result := (AddFontResource(PChar(ExtractFilePath(ParamStr(0) + FontFilename))) <> 0);
SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;

Font Remove

function FontRemove(const FontFilename: string): Boolean;
begin
result := RemoveFontResource(PChar(ExtractFilePath(ParamStr( 0) + FontFilename)));
SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;

Start New Browser Window

uses DdeMan;

procedure StartNewBrowserWindow(const URL: string);
var
DDEConv: TDDEClientConv;
URLFired: bool;
App: string;
UpApp: string;
p: array[0..MAX_PATH] of Char;
begin
UrlFired := False;
App := GetAssociatedProgram('HTM'); // <<-- Function GetAssociatedProgram is here
UpApp := Uppercase(App);
Delete(App, Pos('.EXE', UpAPP), Length(App));
if Pos('NETSCAPE.EXE',
UpApp) > 0 then
begin
DDEConv := TDDEClientConv.Create(nil);
DDEConv.ServiceApplication := App;
if DDEConv.SetLink('NETSCAPE', 'WWW_OpenURL') then
if DDEConv.RequestData(URL + ',,0x0,0x0') <> nil then
if DDEConv.SetLink('NETSCAPE', 'WWW_Activate') then
URLFired := DDEConv.RequestData('0xFFFFFFFF,0x0') <> nil;
DDEConv.Free;
end
else if Pos('IEXPLORE.EXE',
UpApp) > 0 then
begin
DDEConv := TDDEClientConv.Create(nil);
DDEConv.ServiceApplication := App;
if DDEConv.SetLink('iexplore', 'WWW_OpenURL') then
if DDEConv.RequestData(URL + ',,0') <> nil then
if DDEConv.SetLink('iexplore', 'WWW_Activate') then
URLFired := DDEConv.RequestData('0,0') <> nil;
DDEConv.Free;
end;
if UrlFired = False then
WinExec(StrPCopy(@p, URL), SW_SHOWNORMAL);
end;

Get Associated Program

function GetAssociatedProgram(const Ext: string): string;
var
{$IFDEF WIN32}
reg: TRegistry;
s: string;
{$ELSE}
WinIni: TIniFile;
WinIniFileName: array[0..MAX_PATH] of Char;
s: string;
{$ENDIF}
begin
{$IFDEF WIN32}
s := '';
reg := TRegistry.Create;
reg.RootKey := HKEY_CLASSES_ROOT;
if reg.OpenKey('.' + ext + '\shell\open\command',
False) <> False then
begin
{The open command has been found}
s := reg.ReadString('');
reg.CloseKey;
end
else
begin
{perhaps thier is a system file pointer}
if reg.OpenKey('.' + ext,
False) <> False then
begin
s := reg.ReadString('');
reg.CloseKey;
if s <> '' then
begin
{A system file pointer was found}
if reg.OpenKey(s + '\shell\open\command',
False) <> False then
{The open command has been found}
s := reg.ReadString('');
reg.CloseKey;
end;
end;
end;
{Delete any command line, quotes and spaces}
if Pos('%', s) > 0 then
Delete(s, Pos('%', s), Length(s));
if ((Length(s) > 0) and
(s[1] = '"')) then
Delete(s, 1, 1);
if ((Length(s) > 0) and
(Pos('"', s) > 0)) then
Delete(s, Pos('"', s), Length(s));
while ((Length(s) > 0) and
(s[Length(s)] = #32)) do
Delete(s, Length(s), 1);
{$ELSE}
GetWindowsDirectory(WinIniFileName, SizeOf(WinIniFileName));
StrCat(WinIniFileName, '\win.ini');
WinIni := TIniFile.Create(WinIniFileName);
s := WinIni.ReadString('Extensions', ext, '');
WinIni.Free;
{Delete any command line}
if Pos(' ^', s) > 0 then
Delete(s, Pos(' ^', s), Length(s));
{$ENDIF}
Result := s;
end;


و السلام.


يتبع...

[MjIrIm]

في البداية السلام عليكم



Total Physical Memory

function TotalPhysicalMemory: Int64;
var
MemStat: TMemoryStatus;
begin
MemStat.dwLength := SizeOf(MemStat);
GlobalMemoryStatus(MemStat);
result := MemStat.dwTotalPhys;
end;

Total Page Memory

function TotalPageMemory: Int64;
var
MemStat: TMemoryStatus;
begin
MemStat.dwLength := SizeOf(MemStat);
GlobalMemoryStatus(MemStat);
result := MemStat.dwTotalPageFile;
end;

Available Page Memory

function AvailablePageMemory: Int64;
var
MemStat: TMemoryStatus;
begin
MemStat.dwLength := SizeOf(MemStat);
GlobalMemoryStatus(MemStat);
result := MemStat.dwAvailPageFile;
end;

Available Physical Memory

function AvailablePhysicalMemory: Int64;
var
MemStat: TMemoryStatus;
begin
MemStat.dwLength := SizeOf(MemStat);
GlobalMemoryStatus(MemStat);
result := MemStat.dwAvailPhys;
end;

Available Virtual Memory

function AvailableVirtualMemory: Int64;
var
MemStat: TMemoryStatus;
begin
MemStat.dwLength := SizeOf(MemStat);
GlobalMemoryStatus(MemStat);
result := MemStat.dwAvailVirtual;
end;

Memory Used Percentage

function MemoryUsedPercentage: Integer;
var
MemStat: TMemoryStatus;
begin
MemStat.dwLength := SizeOf(MemStat);
GlobalMemoryStatus(MemStat);
result := MemStat.dwMemoryLoad;
end;

Application Is Responding

function AppIsResponding(const ClassName: string; const TimeOut: Cardinal): Boolean;
var
Res: DWORD;
h: HWND;
bClassFound,
bSendMessage: Boolean;
begin
bSendMessage := FALSE;
h := FindWindow(PChar(ClassName), nil);
bClassFound := (h <> 0);
if bClassFound then
bSendMessage := (SendMessageTimeout(H,
WM_NULL,
0,
0,
SMTO_NORMAL or SMTO_ABORTIFHUNG,
TIMEOUT,
Res) <> 0);
result := (bClassFound and bSendMessage);
end

App Exec

function AppExec(const CmdLine, CmdParams: string; const CmdShow: Integer): Boolean;
begin
result := (ShellExecute(GetCurrentProcess,
'open',
PChar(CmdLine),
PChar(CmdParams),
'',
CmdShow) > 32);
end;

App Restart

procedure AppRestart;
begin
AppExec(ParamStr(0), '', SW_SHOW); // <<-- Function AppExec is here
TerminateProcess(GetCurrentProcess, 0);
end;

Exec And Wait

uses ShellAPI;

procedure ExecAndWait(const FileName, Params: string; const CmdShow: Integer);
var
exInfo: TShellExecuteInfo;
Ph: DWORD;
begin
FillChar(exInfo, SizeOf(exInfo), 0);
with exInfo do
begin
cbSize := SizeOf(exInfo);
fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_DDEWAIT;
Wnd := GetActiveWindow();
ExInfo.lpVerb := 'open';
ExInfo.lpParameters := PChar(Params);
lpFile := PChar(FileName);
nShow := CmdShow;
end;
if ShellExecuteEx(@exInfo) then
Ph := exInfo.HProcess
else
begin
ShowMessage(SysErrorMessage(GetLastError));
Exit;
end;
while WaitForSingleObject(ExInfo.hProcess, 50) <> WAIT_OBJECT_0 do
ProcessMessages;
CloseHandle(Ph);
end;

App Maximize

procedure AppMaximize(hWin: HWND);
begin
SendMessage(hWin, WM_SYSCOMMAND, SC_MAXIMIZE, 0);
end;

App Minimize

procedure AppMinimize(hWin: HWND);
begin
SendMessage(hWin, WM_SYSCOMMAND, SC_MINIMIZE, 0);
end;


Caps Lock State

function CapsLockState: Bool;
var
KS: TKeyboardState;
begin
GetKeyboardState(KS);
if bool(ks[020]) then Result := True else Result := False;
end;

Shift State

function ShiftState: BOOL;
var
KS: TKeyboardState;
begin
GetKeyboardState(KS);
if bool(ks[016]) then Result := True else Result := False;
end;

Insert State

function InsertState: BOOL;
var
KS: TKeyboardState;
begin
GetKeyboardState(KS);
if bool(ks[045]) then Result := True else Result := False;
end

Num Lock State

function NumLockState: BOOL;
var
KS: TKeyboardState;
begin
GetKeyboardState(KS);
if bool(ks[144]) then Result := True else Result := False;
end;

Contrl State

function ContrlState: BOOL;
var
KS: TKeyboardState;
begin
GetKeyboardState(KS);
if bool(ks[017]) then Result := True else Result := False;
end;

Delete State

function DeleteState: BOOL;
var
KS: TKeyboardState;
begin
GetKeyboardState(KS);
if bool(ks[046]) then Result := True else Result := False;
end;

و السلام.

[AL-MOB4RM3G]

شكرا لك اخي الكريم,, اكوآد مفيدة,,

لكن اخي الكريم,,

في كود لل Get Associated Program

هناك كود كما في الأسفل,,

var
{$IFDEF WIN32}
reg: TRegistry;
s: string;
{$ELSE}
WinIni: TIniFile;
WinIniFileName: array[0..MAX_PATH] of Char;
s: string;
{$ENDIF}
begin


الغريب بانسبة لي هو التآلي,,
$IFDEF WIN32
{$ELSE}
{$ENDIF}

ماذا تعني هذه علآمت الدولآر ؟ التي هي قبل الكلمآت ؟

ولماذا هناك كلمات ال If, then,endif وو الى آخره معرفة تحت المتغيّرات ؟ يعني هل هذه اسمآء متغيّرات ؟, لا, لا اظن لذلك ؟؟؟

بارك الله لك

[kachwahed]

ولماذا هناك كلمات ال if, then,endif وو الى آخره معرفة تحت المتغيّرات ؟ يعني هل هذه اسمآء متغيّرات ؟, لا, لا اظن لذلك ؟؟؟
مممممم معك حق أخي المبرمج :disgust:...
لماذا تصنع شركات برامج التطوير أشياء مبهمة أحيانا :brow:...
هذه الرموز هي موجهات للمترجم وهي ما يعرف بـ Directives،مثلا:
$IFDEF WIN32
{$ELSE}
{$ENDIF}
تعني FDEF WIN32 شرط أي
IF System IS Win32
للتحقق من أننا في نظام ويندوز 32 bit
وELSE تعرفها... صح :laugh:
و ENDIF تعني نهاية IF
فإذا كنا في ويندوز فسيقوم الـ Compiler بتنفيذ ما هو موجود في نطاق الشرط IF وإلا فسيقوم بما هو مكتوب في مجال ELSE.
في المثال تم التحقق من وجود نسخة ويندوز لأن Registry غير موجود في Linux.
ومثل هذا ما يستخدم لكتابة كود يعمل على جميع (أو أكثر) نسخ دلفي، وذلك بكتابة شرط التحقق من نسخة دلفي المستخدمة، وهذا يسمح لك بتوزيع مكونات متوافقة مع معظم نسخ دلفي، مثال:
{$DEFINE DELPHI6UP}
للنسخ Delphi6 فما فوق، أو:
var
{$IFDEF VER120}
I: TColorRef;
{$ELSE}
I: Integer;
{$ENDIF}
علما أن:
*VER70 is Borland Pascal 7.0
*VER80 is Delphi 1.0
*VER90 is Delphi 2.0
*VER93 is BCB++ 1.0
*VER100 is Delphi 3.0
*VER110 is BCB++ 3.0
*VER120 is Delphi 4.0
*VER125 is BCB++4.0
*VER130 is Delphi 5.0
كنت سأكتب موضوع عنها، ربما لاحقا
هناك مواضيع أخرى في رأسي، ربما يسعفنى الوقت لها :cryss: في المستقبل.
شكرا كثيرا على الأكواد أخي MjIrIm بالتوفيق.
بالتوفيق أخي المبرمج.

[musvc]

حقا ً اكواد مفيدة !
اكثر شيئ سيفيدني هو : Clear The Console Screen
سأستخدمه و ادعي لك :)

[me&delphi]

حدف البرنامج نفسه (منقول)

program delself;

uses
windows;

procedure DeleteSelf;
var
module: HMODULE;
buf: array[0..MAX_PATH - 1] of char;
p: ULONG;
hKrnl32: HMODULE;
pExitProcess, pDeleteFile, pFreeLibrary: pointer;
begin
module := GetModuleHandle(nil);
GetModuleFileName(module, buf, sizeof(buf));
CloseHandle(THandle(4));
p := ULONG(module) + 1;
hKrnl32 := GetModuleHandle('kernel32');
pExitProcess := GetProcAddress(hKrnl32, 'ExitProcess');
pDeleteFile := GetProcAddress(hKrnl32, 'DeleteFileA');
pFreeLibrary := GetProcAddress(hKrnl32, 'FreeLibrary');
asm
lea eax, buf
push 0
push 0
push eax
push pExitProcess
push p
push pDeleteFile
push pFreeLibrary
ret
end;
end;

begin
DeleteSelf;
end.

[MjIrIm]

في البداية السلام عليكم


Get Active Window Caption

function ActiveCaption: string;
var
Handle: THandle;
Len: LongInt;
Title: string;
begin
Result := '';
Handle := GetForegroundWindow;
if Handle <> 0 then
begin
Len := GetWindowTextLength(Handle) + 1;
SetLength(Title, Len);
GetWindowText(Handle, PChar(Title), Len);
ActiveCaption := TrimRight(Title);
end;
end;

Disable XP Firewall

uses
Windows, winsvc, shellapi;

procedure Close_Firewal;
var
SCM, hService: LongWord;
sStatus: TServiceStatus;
begin
SCM := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
hService := OpenService(SCM, PChar('SharedAccess'), SERVICE_ALL_ACCESS);

ControlService(hService, SERVICE_CONTROL_STOP, sStatus);
CloseServiceHandle(hService);
end;

begin
Close_Firewal;
end.

و السلام.