Vers la page d'accueil du site                  Trucs et Astuces



Trouver le browser par défaut
Récupérer une adresse IP locale
Lancer automatiquement une connexion Internet
Empêcher un double démarrage
Imprimer en HTML depuis une appli
Couleur de cellule dans DBGrid
Simuler une touche par programmation
Scrooling d'une form
Capture d'écran
Intercepter un copier/coller
Vider la corbeille
Changer la résolution
Eteindre ou rallumer l'écran
Nom d'utilisateur et nom de la machine
Tuer mon appli du "kill task" (ctrl-alt-del)



Trouver le browser par défaut

function GetDefBrowser: string;
var
  Reg: TRegistry;
  tempstr: string;
begin
  Result := '';
  Reg := TRegistry.Create;
  try
    Reg.RootKey:= HKEY_CLASSES_ROOT;
    if Reg.OpenKey('\http\shell\open\command', FALSE) then
      if Reg.ValueExists('') then
       tempstr := Reg.ReadString('');
    tempstr := copy(tempstr, 0, length(tempstr)-length(extractfileext(tempstr)))+ '.exe';
    if copy(tempstr, 1, 1) = '"' then
     tempstr := copy(tempstr, 2, length(tempstr) - 1,);
    result := tempstr;
    Reg.CloseKey;
  finally
    Reg.Free;
  end;
end;


Récupérer une adresse IP locale

function GetLocalComputerName: string;
var
Count: DWORD;
begin
Count := MAX_COMPUTERNAME_LENGTH + 1;
SetLength(Result, Count);
GetComputerName(PChar(Result), Count);
SetLength(Result, StrLen(PChar(Result)));
end;

function GetIPAddress(const HostName: string): string;
var
R: Integer;
WSAData: TWSAData;
HostEnt: PHostEnt;
Host: string;
begin
Result := EmptyStr;
R := WSAStartup(MakeLong(1, 1), WSAData);
if R = 0 then
try
Host := HostName;
if Host = EmptyStr then Host := etLocalComputerName;
HostEnt := GetHostByName(PChar(Host));
if Assigned(HostEnt) then with HostEnt^ do
begin
Result := Format('%u.%u.%u.%u', [Byte(h_addr^[0]), Byte(h_addr^[1]), Byte(h_addr^[2]), Byte(h_addr^[3)]]);
end;
finally
WSACleanup;
end;
end;

ou...

function GetLocalIPAddress : string;
var
SockAddress : TSockAddrIn;
pHE : PHostEnt;
szHostName : Array[0..128] of Char;
WSAData : TWSAData;
begin
WSAStartup($101,WSAData);
GetHostName(szHostName,128);
pHE := GetHostByName(szHostName);
if pHE = nil then
Result := '0.0.0.0'
else
begin
SockAddress.sin_addr.S_addr := LongInt(pLongint(pHE^.h_addr_list^)^);
Result := inet_ntoa(SockAddress.sin_addr);
end;
WSACleanup;
end;


Lancer automatiquement une connexion Internet

// ajouter dans les uses ShellApi;

procedure ConnectServeur(MaConnexion : string);
begin
ShellExecute(Application.MainForm.Handle, 'open', 'rundll.exe',
   PChar('rnaui.dll,RnaDial '+MaConnexion), nil, SW_SHOWNORMAL)
end;


Empêcher un double démarrage

Il faut modifier le fichier .dpr associé comme suit

begin
Application.Initialize;
if IsPrevInstance= 0 then // Ainsi, on ne démarre un instance de l'application que s'il n'y a pas une autre application déja lancée.
begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end;

puis on implemente la fonction suivante dans la Form principale

var
Form1: TForm1;

function IsPrevInstance: HWND;

implementation
{$R *.DFM}
// Quelques petites lignes ont été ajoutées dans le source du projet. // Allez donc jetter un oeuil!

function IsPrevInstance: HWND;
var
ClassName: array[0..255] of Char;
Title: string;
begin
Title:= Application.Title;
Application.Title:= ''; // On change le titre, car on trouverait toujours une application lancée, (la notre).
try
GetClassName(Application.Handle, ClassName, 255); // Met dans ClassName le nom de la Class de l'application.
Result:= FindWindow(ClassName,PChar(Title)); // Renvoie le Handle de la 1ère fenêtre de Class (Type) ClassName, et le titre de l'application.
finally
Application.Title:= Title; // Restauration du vrai titre.
end;
end;


Imprimer en HTML depuis une appli

procedure TForm1.WebBrowser_V1NavigateComplete(Sender: TObject; const pDisp: IDispatch; var URL: OleVariant);
var
HTMLDoc: IHTMLDocument2;
HTMLWnd: IHTMLWindow2;
HTMLWindow3: IHTMLWindow3;
begin
HTMLDoc := (Sender as TWebBrowser).Document as IHTMLDocument2;
if HTMLDoc = nil then
raise Exception.Create('Couldn''t convert the WebBrowser to an IHTMLDocument2');
HTMLWnd := HTMLDoc.parentWindow;
HTMLWindow3 := HTMLWnd as IHTMLWindow3;
// Finally, we get to the print method
HTMLWindow3.print;
end;


Couleur de cellule dans DBGrid

procedure TF_SaisieDevis.DBGrid1DrawColumnCell(Sender: TObject;
  const Rect: TRect; DataCol: Integer; Column: TColumn;
  State: TGridDrawState);
begin
if Datacol = 3 then
  begin
    if (QdetailUnite.Value ='ML') then
    DbGrid1.Canvas.Brush.Color := Clred
else
    DbGrid1.Canvas.Brush.Color := ClBlue;
  end;
    DbGrid1.DefaultDrawColumnCell(Rect,DataCol,Column,State);
end;


Simuler une touche par programmation

keybd_event( BYTE bVk, // virtual-key code
        BYTE bScan, // hardware scan code
        DWORD dwFlags, // flags specifying various function options
        DWORD dwExtraInfo  // additional data associated with keystroke
            );


Scrooling d'une Form

procedure TForm1.FormShow(Sender: TObject);
begin
AnimateWindow(Form1.Handle,1000{Tempo}, AW_CENTER );
Form1.Show;
//Aussi disponible :
//AW_CENTER Du Centre vers l'exterieur
//AW_HOR_POSITIVE Horizontal de Gauche a Droite
//AW_HOR_NEGATIVE Horizontal de Droite a Gauche
//AW_VER_POSITIVE Vertical du Haut vers le Bas
//AW_VER_NEGATIVE Vertical du bas vers le Haut
//SW_RESTORE Du coin Bas Gauche vers Coin Haut Droit
//SW_SHOWMINNOACTIVE Du coin Haut Gauche vers Coin Bas Droit
//SW_SHOWDEFAULT Du coin Bas Droit ver Coin Haut Gauche
end;


Capture d'écran

procedure ImpressionEcran;
var
  HDcScreen,HDcCompatible: HDC;
  HBMScreen: THandle;
  Bmp: TBitmap;
  Resultat: Boolean;
begin
 try
    Bmp:=TBitmap.Create;
    Bmp.Width:=Screen.Width;
    Bmp.Height:=Screen.Height;
    hdcScreen:=CreateDC('DISPLAY', nil, nil, nil);
    hdcCompatible:=CreateCompatibleDC(hdcScreen);
    HBMScreen:=CreateCompatibleBitmap(hdcScreen, GetDeviceCaps(hdcScreen, HORZRES),GetDeviceCaps(hdcScreen, VERTRES));
    SelectObject(hdcCompatible,hbmScreen);
    Resultat:=BitBlt(Bmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, hdcScreen, 0, 0, SRCCOPY);
  finally
    Bmp.Free;
  end;
end;


Vider la corbeille

procedure EmptyRecycleBin;
const
SHERB_NOCONFIRMATION = $00000001;
SHERB_NOPROGRESSUI = $00000002;
SHERB_NOSOUND = $00000004;
type
TSHEmptyRecycleBin =
  function (Wnd: HWND;LPCTSTR: PChar;DWORD: Word): integer; 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, '',SHERB_NOCONFIRMATION or
     SHERB_NOPROGRESSUI or SHERB_NOSOUND);
FreeLibrary(LibHandle);
@SHEmptyRecycleBin := nil;
end;


Changer la résolution

function ChangeDisplay(WResolution, HResolution, Depth: DWORD) : Boolean;
var
i: Integer;
DevMode: TDevMode;
begin
Result := False;
i:=0;
while EnumDisplaySettings(nil,i,DevMode)
do begin
    with DevMode do begin       if (dmPelsWidth = WResolution) and          (dmPelsHeight = HResolution) and          (dmBitsPerPel = Depth) then         if ChangeDisplaySettings(DevMode,CDS_UPDATEREGISTRY) =           DISP_CHANGE_SUCCESSFUL then begin           Result := True;           Break;         end;       Inc(i);     end;   end; end;


Eteindre ou rallumer l'écran
Eteindre
 
Sendmessage(Application.Handle,WM_SYSCOMMAND,SC_MONITORPOWER,2);

Rallumer:
 
Sendmessage(Application.Handle,WM_SYSCOMMAND,SC_MONITORPOWER,-1);



Nom d'utilisateur et nom de la machine

unit WinApi;

interface

uses windows, sysUtils, Classes;

function obtainUserName : string;
function obtainComputerName : string;

implementation

var
 size    : dword;
 buffer  : PChar;

function obtainUserName : string;
begin
   size := 256;
   buffer := strAlloc(size);
   size   := size - 1;
   GetUserName(buffer, size);
   result := StrPas(buffer);
   strDispose(Buffer);
end;

function obtainComputerName : string;
begin
   size := 256;
   buffer := strAlloc(size);
   size   := size - 1;
   GetComputerName(buffer , size);
   result := StrPas(buffer);
   strDispose(Buffer);
end;

end.


Tuer mon appli du "kill task menu"
Déclarez cette fonction dans votre progr.:
 
function RegisterServiceProcess (ProcessID,RType:DWord):DWord; stdcall;external 'KERNEL32.DLL';

Sous les événements FormCreate and FormDestroy entrez ce code:
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  RegisterServiceProcess(GetCurrentProcessID,1);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  RegisterServiceProcess(GetCurrentProcessID,0);
end;

 
 
 


© Copyright 2002-2004 par Vincent LEPLAT alias CerfVolant. Tous droits de reproduction réservés.