Outline · [ Standard ] · Linear+ Windows Xp Trikowi, Owo je ipak zanimljivije i korisnije...

[NeverMore21]

E owako...Poshto su se swi wec smorili sa tipichnim algoritmima vezanih za brojeve, stringowe, nizowe itd. (zadaci sa bloka), ewo nove teme koja ce valjda biti zanimljivija i ne bash tako monotona! Swi koji hoce (i znaju) neka owde postuju funkcije i procedure vezane za Windows XP (znaci pre svega Win API)!!! I bez funkicja tipa: kako dobiti 3. znak iz verzije Service Pack-a, i slicno!!! Za pocetak, postovacu neke korisne funkcije i procedure!!! Ali u drugom postu!!! Pozzzz

[NeverMore21]

Za pocetak, ewo funkcije koja otwara CD-ROM DRIVE:

CODE

uses MMSystem;

procedure OpenCDRom;
begin
mciSendString ('Set cdaudio door open wait', nil, 0, handle);
end;

i naravno funkcija koja zatwara CD-ROM DRIVE:

CODE

uses MMSystem;

procedure CloseCDRom;
begin
mciSendString('Set cdaudio door closed wait', nil, 0, handle);
end;

Idemo dalje; Sledeca funkcija upravlja prikazivanjem sata na taskbaru. Znaci, ako
vam je sat dosadio, samo pozowite owu funkciju:

CODE

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

Ipak, ako zelite da sakrijete taskbar, ew wam reshenja:

CODE

procedure ShowTaskBar(show: boolean);
begin
if show=true then
ShowWindow(FindWindow('Shell_TrayWnd',nil), SW_SHOWNA); end else
        ShowWindow(FindWindow('Shell_TrayWnd',nil), SW_HIDE);
end;

Ako neko BASH woli da se igra sa ikonicama ewo mu procedure za skriwanje desktop ikonica:

CODE

procedure ShowDesktopIcons(const Show: boolean);
var h : THandle;
begin
h := FindWindow('ProgMan', nil);
h := GetWindow(h, GW_CHILD);
if Show = True then
 ShowWindow(h, SW_SHOW)
else
  ShowWindow(h, SW_HIDE);
end;

Dobro, dosta sa sakrivanjem swega i swacega (ipak ima tu josh dosta toga ). Sledeca procedura zamenjuje akcije levog i desnog dugmeta na mishu:

CODE

procedure SwapMouseButtons(bValue: Boolean);
begin
 if bValue then
   SystemParametersInfo(SPI_SETMOUSEBUTTONSWAP, 1, nil, 0)
 else
   SystemParametersInfo(SPI_SETMOUSEBUTTONSWAP, 0, nil, 0);
end;

Hocete da pravite probleme , onda ewo koda za iskljucivanje task manager-a:

CODE

uses
 Registry;

procedure EnableCTRLALTDEL(YesNo : boolean);
const
sRegPolicies = '\Software\Microsoft\Windows\CurrentVersion\Policies';
begin
 with TRegistry.Create do
 try
   RootKey:=HKEY_CURRENT_USER;
   if OpenKey(sRegPolicies+'\System\',True) then
   begin
     case YesNo of
       False:
         begin
           WriteInteger('DisableTaskMgr',1);
         end;
       True:
         begin
           WriteInteger('DisableTaskMgr',0);
         end;
     end;
   end;
   CloseKey;
   if OpenKey(sRegPolicies+'\Explorer\',True) then
   begin
     case YesNo of
       False:
         begin
           WriteInteger('NoChangeStartMenu',1);
           WriteInteger('NoClose',1);
           WriteInteger('NoLogOff',1);
         end;
       True:
         begin
           WriteInteger('NoChangeStartMenu',0);
           WriteInteger('NoClose',0);
           WriteInteger('NoLogOff',0);
         end;
     end;
   end;
   CloseKey;
 finally
   Free;
 end;
end;

Ako hocete da zeznete profesora, sledecim kodom mozete ugasiti monitor:

CODE

SendMessage(Application.Handle, wm_SysCommand, Windows.SC_MONITORPOWER, 1); {gasi monitor}
SendMessage(Application.Handle, wm_SysCommand, Windows.SC_MONITORPOWER, -1); {pali monitor}

Ewo i koda za igranje sa tastaturom. Njime mozete upravljati (gasiti i paliti) LED diodama na tastaturi:

CODE

procedure SetLedState(KeyCode: TKeyType; bOn: Boolean);
var
 KBState: TKeyboardState;
 Cod: Byte;
begin
 case KeyCode of
   ktScrollLock: Cod := VK_SCROLL;
   ktCapsLock: Cod := VK_CAPITAL;
   ktNumLock: Cod := VK_NUMLOCK;
 end;
 GetKeyboardState(KBState);
 if (Win32Platform = VER_PLATFORM_WIN32_NT) then
 begin
   if Boolean(KBState[Cod]) <> bOn then
   begin
     keybd_event(Cod,
                 MapVirtualKey(Cod, 0),
                 KEYEVENTF_EXTENDEDKEY,
                 0);

     keybd_event(Cod,
                 MapVirtualKey(Cod, 0),
                 KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP,
                 0);
   end;
 end
 else
 begin
   KBState[Cod] := Ord(bOn);
   SetKeyboardState(KBState);
 end;
end;

Uh smorih se!!! Odoh sad neshto da radim, a sutra cu da postujem josh :D!!!
Narawno, sve je otworeno za pitanja! Swako ko ima neki dobar kod nek ga postuje ! Pozzzz

P.S. Utrnushe mi prsti ! Srecna NG !

[RZA]

ok.. lepo je to.. lepo je znati... ali koj ce mi to? ..
neke mogu da uradim sa jednostavnih par klikova.. ali dobro.. ..
ponavljam lepo je znati.. nastavi.. mozda dodje nesto stvarno stvarno dobro..

[NeverMore21]

Pa dobro, nije da mi je dosadno ali ewo me 05! Postowacu josh par korisnih kodowa. Pa da pochnem:

Sledeca funkcija uslikawa trenutnu sliku ekrana i wratja je kao tip TBitmap (samo je dodelite Image-u):

CODE

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

Sledecom funkicjom proverawate da li je trenutno ulogovani korisnik administrator:

CODE

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

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

Hocete iz programa da ispraznite Recycle Bin, ewo reshenja:

CODE

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
 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;

I ewo, za danas josh jedan kod kojim mozete da upravljate jachinom zwuka media plejera:

CODE

uses
 MPlayer, MMSystem;
const
 MCI_SETAUDIO = $0873;
 MCI_DGV_SETAUDIO_VOLUME = $4002;
 MCI_DGV_SETAUDIO_ITEM = $00800000;
 MCI_DGV_SETAUDIO_VALUE = $01000000;
 MCI_DGV_STATUS_VOLUME = $4019;
type
 MCI_DGV_SETAUDIO_PARMS = record
   dwCallback: DWORD;
   dwItem: DWORD;
   dwValue: DWORD;
   dwOver: DWORD;
   lpstrAlgorithm: PChar;
   lpstrQuality: PChar;
 end;
type
 MCI_STATUS_PARMS = record
   dwCallback: DWORD;
   dwReturn: DWORD;
   dwItem: DWORD;
   dwTrack: DWORD;
 end;

procedure SetMPVolume(MP: TMediaPlayer; Volume: Integer);
 { Volume: 0 - 1000 }
var
 p: MCI_DGV_SETAUDIO_PARMS;
begin
 { Volume: 0 - 1000 }
 p.dwCallback := 0;
 p.dwItem := MCI_DGV_SETAUDIO_VOLUME;
 p.dwValue := Volume;
 p.dwOver := 0;
 p.lpstrAlgorithm := nil;
 p.lpstrQuality := nil;
 mciSendCommand(MP.DeviceID, MCI_SETAUDIO,
   MCI_DGV_SETAUDIO_VALUE or MCI_DGV_SETAUDIO_ITEM, Cardinal(@p));
end;

Eto, waljda ce nekom koristiti... ... Odoh sad malo na Rise of Nations ! Pozzz

[NeverMore21]

Pa waljda nekom zatreba !!! Od owoga se pocinje graditi program, a posle swe ostalo ... Pa sad ne znam shta je to stwarno stwarno dobro...Necu valjda da pishem kako da oborish sistem kad to moze u 2 reda ...(ili ipak jedan)! U swakom slucaju hwala na kritici, pokusacu da nadjem neshto 'korisnije'

[pyost]

Svaka cast za temu i kodove

[NeverMore21]

Hwala na podrshci ! Da se bar nekom swidi

[bone_fletcher]

Pa waljda nekom zatreba !!! Od owoga se pocinje graditi program, a posle swe ostalo ... Pa sad ne znam shta je to stwarno stwarno dobro...Necu valjda da pishem kako da oborish sistem kad to moze u 2 reda ...(ili ipak jedan)! U swakom slucaju hwala na kritici, pokusacu da nadjem neshto 'korisnije'

Bojane svaka cast za temu,ukljucicu se i ja u nju.

[Eli0t]

Lepo.. A jel bi mogao da postujes izvor odakle si uzeo sve ovo (u slucaju da si copy/pasteovao sa neta..) ?

[Iva]

http://www.delphitricks.com/source-code/misc/
http://www.delphitricks.com/source-code/systeminfo/1/
http://www.delphitricks.com/source-code/internet/1/

Mrzi me da kopiram sve linkove.. snaci cete se.

[NeverMore21]

Ima tu kodova sa raznih site-ova, ali vecina je obradjena za Delphi 7+

Imah na
Forumu pomoc wezanu za swe...

Adrese? Hm, pa ima ih mnogo (pored dole navedene):

www.greatis.com/delphicb/tips/lib/tips.html
www.inner-smile.com/delphit.phtml
www.planet-source-code.com
www.delphi32.com
www.chami.com/tips/delphi
www.feedback.nildram.co.uk/richardebbs/delphi/delphitipntrik.htm
www.winsite.com
www.chmaas.handshake.de/delphi/tipsmain.htm
www.programmingtutorials.com/delphi.aspx
www.torry.net

itd.

Na owoj poslednjoj imash i weliki broj komponenti (i freeware i share) koje su mnoooogo bolje od standardnih koje dobijesh uz delphijew VCL paket !

[Puzzler]

nevermore je dokaz da je Ib odeljenje bolje nego što svi misle...
Svi sa prve godine, čak i Aovci nas potcenjuju...

In your faces!

[NeverMore21]

Dobro, to je tachno, ali to nije tema owog topica... ! U swakom slucaju ima li neko
pitanje wezano za dosadasnje kodowe? Postoji tu jedna greska kod uprawljanja monitorom, jer navedeni kod radi samo pri odredjenoj konfiguraciji. Medjutim, umesto parametra -1 treba stawiti 0 ako wetj sa njim ne radi... Pozzz

[^_NiN0_^]

Jel to kucamo u Delphi , i pokrenemo ?

[NeverMore21]

Da u delphi-u! Ovde su ti dati kodovi kao funkcije i procedure - znaci prekopirash ceo kod u aplikaciju i samo ga pozovesh na neki dogadjaj, ok?

[NeverMore21]

OK, ewo stize nowi paket kodowa

Sledecim kodom mozete blokirati misha i tastaturu (poziwaju se originalne funkcije iz USER32 biblioteke):

CODE

function FuncAvail (_dllname, _funcname: string; var _p: pointer): boolean;
var _lib: tHandle;
begin
   Result := false;
   _p := NIL;
   if LoadLibrary(PChar(_dllname)) = 0 then exit;
   _lib := GetModuleHandle(PChar(_dllname));
   if _lib <> 0 then
    begin
    _p := GetProcAddress(_lib, PChar(_funcname));
    if _p <> NIL then Result := true;
    end;
end;

i onda je pozowete na owaj nacin:

CODE

procedure TForm1.Button1Click(Sender: TObject);
var
   xBlockInput : function(Block: bool):  bool;  stdcall;
begin
  if FuncAvail
   ('USER32.DLL', 'BlockInput', @xBlockInput) then
  begin
   xBlockInput(true);
   Sleep(5000);
   xBlockInput(false);
  end;
end;

Sledeci kod prikazuje desktop (minimizuje swe programe):

CODE

procedure ShowDesktop;
begin
keybd_event( VK_LWIN, MapvirtualKey( VK_LWIN, 0), 0, 0 );
keybd_event( Ord('D'), MapvirtualKey( Ord('D'), 0), 0, 0 );
keybd_event( Ord('D'), MapvirtualKey( Ord('D'), 0), KEYEVENTF_KEYUP, 0 );
keybd_event( VK_LWIN, MapvirtualKey( VK_LWIN, 0), KEYEVENTF_KEYUP, 0 );
end;

Owom funkcijom citate HomePage iz Registry-a:

CODE

uses
Registry;


function GetIEStartPage: string;
var
 Reg: TRegistry;
begin
 Reg := TRegistry.Create;
 try
   Reg.RootKey := HKEY_CURRENT_USER;
   Reg.OpenKey('Software\Microsoft\Internet Explorer\Main', False);
   try
     Result := Reg.ReadString('Start Page');
   except
     Result := '';
   end;
   Reg.CloseKey;
 finally
   Reg.Free;
 end;
end;

I na kraju ewo koda koji menja pozadinu desktopa (ne radi na swim konfiguracijama):

CODE

procedure MenjajPozadinu(putanja: string);
begin
if fileexists(putanja) then
begin

 if  SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, Pointer(putanja),
   SPIF_SENDWININICHANGE) then    ShowMessage('Wallpaper uspesno promenjen!') else
   ShowMessage('Promena wallpaper-a nije uspela!');       end else
   ShowMessage('Putanja do datoteke nije pronadjena!');
end;

Eto, pa ako ima pitanja postujte ! Nema shta, ipak je owaj API mocna stwar