Nekoliko malih Tips&Tricks kodova za Delphi

• 0Niko još nije pohvalio poruku.
  Registruj se da bi pohvalio/la poruku!

Ipitivanje da li ste trenutno konektovani na Internet?
~~~~~~~~~~~~~~~~~~~~~~~~~
procedure TForm1.Button1Click(Sender: TObject) ;

function FuncAvail(_dllname, _funcname: string;
var _p: pointer): boolean;
{return True if _funcname exists in _dllname}
var _lib: tHandle;
begin
Result := false;
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;

{
Call SHELL32.DLL for Win > Win98
otherwise call URL.dll
}
{buton code:}
var
InetIsOffline : function(dwFlags: DWORD):
BOOL; stdcall;
begin
if FuncAvail('URL.DLL', 'InetIsOffline',
@InetIsOffline) then
if InetIsOffLine(0) = true
then ShowMessage('Not connected')
else ShowMessage('Connected!') ;
end;
~~~~~~~~~~~~~~~~~~~~~~~~~

Enable/Disable the Windows 'START' button
~~~~~~~~~~
//Enable:
EnableWindow(FindWindowEx(FindWindow
('Shell_TrayWnd', nil), 0,'Button',nil),TRUE) ;
//Disable:
EnableWindow(FindWindowEx(FindWindow
('Shell_TrayWnd', nil), 0,'Button',nil),FALSE) ;

~~~~~~~~~~


Show/Hide the TaskBar in Windows
~~~~~~~~~~
//To hide the task bar use
ShowWindow(FindWindow
('Shell_TrayWnd',nil), SW_HIDE) ;

//To show the task bar use
ShowWindow(FindWindow
('Shell_TrayWnd',nil), SW_SHOWNA) ;
~~~~~~~~~~

Open & Close CD-drive from code
~~~~~~~~~~~~~~~~~~~~~~~~~
{ To OPEN the CD-ROM: }
mciSendString
('Set cdaudio door open wait', nil, 0, handle) ;

{ To CLOSE the CD-ROM: }
mciSendString
('Set cdaudio door closed wait', nil, 0, handle) ;
~~~~~~~~~~~~~~~~~~~~~~~~~

Show / Hide Desktop icons
~~~~~~~~~~~~~~~~~~~~~~~~~
procedure ShowDesktop(const YesNo : boolean) ;
var h : THandle;
begin
h := FindWindow('ProgMan', nil) ;
h := GetWindow(h, GW_CHILD) ;
if YesNo = True then
ShowWindow(h, SW_SHOW)
else
ShowWindow(h, SW_HIDE) ;
end;
~~~~~~~~~~~~~~~~~~~~~~~~~
Hide/Show Tray icons
~~~~~~~~~~~~~~~~~~~~~~~~~
procedure TraySHOW
var TopWindow : HWND;
begin
TopWindow:=
FindWindow('Shell_TrayWnd', nil) ;
TopWindow:=
FindWindowEx(TopWindow,0, 'ReBarWindow32', nil) ;
TopWindow:=
FindWindowEx(TopWindow,0, 'SysPager', nil) ;
ShowWindow( TopWindow,Sw_Show) ;
end;

procedure TrayHIDE
var TopWindow : HWND;
begin
TopWindow:=
FindWindow('Shell_TrayWnd', nil) ;
TopWindow:=
FindWindowEx(TopWindow,0, 'ReBarWindow32', nil) ;
TopWindow:=
FindWindowEx(TopWindow,0, 'SysPager', nil) ;
ShowWindow( TopWindow,Sw_Hide) ;
end;

~~~~~~~~~~~~~~~~~~~~~~~~~
Empty Recycle Bin
~~~~~~~~~~~~~~~~~~~~~~~~~
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes,
Graphics, ShellApi,Controls, Forms,
Dialogs,StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject) ;
end;

var Form1: TForm1;

function SHEmptyRecycleBin
(Wnd:HWnd; LPCTSTR:PChar;
DWORD:Word):Integer; stdcall;

const
SHERB_NOCONFIRMATION = $00000001;
SHERB_NOPROGRESSUI = $00000002;
SHERB_NOSOUND = $00000004;

implementation {$R *.DFM}

function SHEmptyRecycleBin; external
'SHELL32.DLL' name 'SHEmptyRecycleBinA';

procedure TForm1.Button1Click(Sender: TObject) ;
begin
SHEmptyRecycleBin(self.handle,'',
SHERB_NOCONFIRMATION) ;
end;
end.
~~~~~~~~~~~~~~~~~~~~~~~~~


Shut down Windows 2000 / XP / NT
~~~~~~~~~~~~~~~~~~~~~~~~~
function ShutdownNTplatform:boolean;
const
ADJUST_PRIV = TOKEN_QUERY or TOKEN_ADJUST_PRIVILEGES;
SHTDWN_PRIV = 'SeShutdownPrivilege';
PRIV_SIZE = sizeOf(TTokenPrivileges) ;
var
Len: DWORD;
TokenPriv, Dummy: TTokenPrivileges;
Token: THandle;
Text,
Machine:array [0..128] of Char;
Force,Reboot:boolean;
Error:integer;
begin
Error := 0;
if not OpenProcessToken(GetCurrentProcess(), ADJUST_PRIV, Token) then
Error := Error or 4;
{ ShowMessage('OpenProcessToken failed') ; }
if not LookupPrivilegeValue(nil, SHTDWN_PRIV,TokenPriv.Privileges[0].Luid) then
Error:=Error or 8;
{ ShowMessage('LookupPrivilegeValue failed') ; }
TokenPriv.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
TokenPriv.PrivilegeCount := 1; // One privilege to set
if not AdjustTokenPrivileges(Token, false, TokenPriv, PRIV_SIZE,Dummy, Len) then
Error:=Error or 16;
{ ShowMessage('AdjustTokenPrivileges failed') ; }
StrPCopy(Text,FMessage) ;
StrPCopy(Machine,FMachineName) ;
InitiateSystemShutDown (Machine,Text,FTimeOut,True,False) ;
Result := (Error = 0) ;
end;

~~~~~~~~~~~~~~~~~~~~~~~~~

From TTime and TDate to TDateTime
~~~~~~~~~~~~~~~~~~~~~~~~~
var
DateValue : TDate;
TimeValue: TTime;
OutDateTime : TDateTime;
...
// OutDateTime combines DateValue and TimeValue
OutDateTime := Int(DateValue) + Frac(TimeValue) ;

~~~~~~~~~~~~~~~~~~~~~~~~~

How to convert Seconds to Time
Here'a a simple function to convert an "amount" of seconds to HH:MM:SS string.
~~~~~~~~~~~~~~~~~~~~~~~~~
function SecToTime(Sec: Integer): string;
var
H, M, S: string;
ZH, ZM, ZS: Integer;
begin
ZH := Sec div 3600;
ZM := Sec div 60 - ZH * 60;
ZS := Sec - (ZH * 3600 + ZM * 60) ;
H := IntToStr(ZH) ;
M := IntToStr(ZM) ;
S := IntToStr(ZS) ;
Result := H + ':' + M + ':' + S;
end;
~~~~~~~~~~~~~~~~~~~~~~~~~
Get Last Day in Month
~~~~~~~~~~~~~~~~~~~~~~~~~
function LastDayCurrMon: TDate;
var
y, m, d: word;
begin
decodedate(now, y, m, d) ;
m := m + 1;
if m > 12 then
begin
y := y + 1;
m := 1;
end;
result := encodedate(y, m, 1) - 1;
end;

{Usage:}
ShowMessage(DateToStr(LastDayCurrMon)) ;
~~~~~~~~~~~~~~~~~~~~~~~~~

Week number calculating
~~~~~~~~~~~~~~~~~~~~~~~~~
function WeekNum(const TDT:TDateTime) : Word;
var
Y,M,D:Word;
dtTmp:TDateTime;
begin
DecodeDate(TDT,Y,M,D) ;
dtTmp := EnCodeDate(Y,1,1) ;
Result :=
(Trunc(TDT-dtTmp)+(DayOfWeek(dtTmp)-1)) DIV 7;
if Result <> 0 then Result := Result - 1;
end;
~~~~~~~~~~~~~~~~~~~~~~~~~

Nadam se da ce vam ovi sourcevi biti zanimljivi. Ako nesto nije jasno pitajte?

• 0Niko još nije pohvalio poruku.
  Registruj se da bi pohvalio/la poruku!

Dobra ovo fora za enable-disable start buton. Malo bih moga da se igram, dao si mi dobre ideje.

• 0Niko još nije pohvalio poruku.
  Registruj se da bi pohvalio/la poruku!

Fino, fino NuLLCoDe, ovde ima stvarno korisnih stvarčica, mada sam za večinu već znao ( ovo za Start btton mi do sada nije trebalo pa nisam ni znao, ali kao što Max reče, nove ideje za prankove su rođene ).

• 0Niko još nije pohvalio poruku.
  Registruj se da bi pohvalio/la poruku!

Posto mi na faxu daju internet na kasicicu dao si mi dobar predlog sta da radim u slobodno vreme

• 0Niko još nije pohvalio poruku.
  Registruj se da bi pohvalio/la poruku!

I ja imam problema sa mojima na faxu. Moracu da smislim nesto
Napravili su usera "Student" koji ne moze nista da radi...jedva su dozvolili da mogu i start menu da otvorim

• 0Niko još nije pohvalio poruku.
  Registruj se da bi pohvalio/la poruku!

Onaj OPEN/CLOSE CD-ROM bas nesto i nece da mi radi!

Da tu ne treba jos nesto? Stalno mi javlja Da mciSendString nije deklarisan.

• 0Niko još nije pohvalio poruku.
  Registruj se da bi pohvalio/la poruku!

Dodaj MMSystem u uses listu.

Dopuna: 22 Mar 2006 0:36

Da malo osvezimo ovu temu

Svrljao sam malo netom i naidjem na ovaj sajt: [Link mogu videti samo ulogovani korisnici]

Ima prilicno korisnih stvari.

• 0Niko još nije pohvalio poruku.
  Registruj se da bi pohvalio/la poruku!

Moj favorit:
[Link mogu videti samo ulogovani korisnici]