[Lefoujd] Trucs et Astuces Delphi et API

Vous trouverez sur cette page quelques trucs et astuces de programmation en Delphi. Tous ceux qui ont un petits liens de téléchargement permettent d'avoir un exemple en Delphi 3 (et bientôt Delphi 5 j'espère).
Je n'ai aucunement la prétension de vous donner des cours de programmation, mais simplement de réunir ici tout ce sur quoi j'ai ramé ou qui m'a pris un peu de temps en travail et en recherche sur le net.

Tout ce que vous pourrez télécharger ici ne sera que du code source non compilé (comme ça, pas de problème de virus). Pour le tester chez vous, vous aurez besoins d'avoir une version de Borland Delphi 3 pour les compiler sans adaptations.

Table des matières

Comment calculer la vitesse de son CPU ?

Deux possibilités : Regarder dans la Base de Registre Windows ou calculer le cadensement du processeur

On regarde dans la base de registre. Rien de plus facile. Delphi offre un objet TRegistry qui permet d'ouvrir une entrée sur la base de registre Windows. Ensuite il suffit de savoir où chercher. Et en l'occurance, on va chercher dans "HKEY_LOCAL_MACHINE - Hardware/Description/System/Centralprocessor/0" Le zéro représente le numéro du processeur. Si vous avez un bi-processeur, il faudrait aussi regarder dans "HKEY_LOCAL_MACHINE - Hardware/Description/System/Centralprocessor/1". Mais on peut aussi considérer que les deux processeur ont la même fréquence.

function GetCPUSpeed: extended;
var Reg: TRegistry;
begin
  Reg := nil;
  try
    Reg := TRegistry.Create;
    with Reg do
    begin
      RootKey := HKEY_LOCAL_MACHINE;
      if OpenKey('Hardware/Description/System/Centralprocessor/0', FALSE)
      then result := ReadInteger('˜MHz');
      CloseKey;
    end;
  finally
    if Reg <> nil
    then Reg.Free;
  end;
end;

Calcul de la fréquence du processeur. Mieux vaut connaître un minimum d'assembleur. On utilisera pour cela la fonction décrite ci-dessous. Rien de bien compliqué me direz vous. Il suffit de faire un petit calcul en boucle.

function GetCpuSpeed: Comp;
var
  t: DWORD;
  mhi, mlo, nhi, nlo: DWORD;
  t0, t1, chi, clo, shr32: Comp;
begin
  shr32 := 65536;
  shr32 := shr32 * 65536;
  t := GetTickCount;
  while t = GetTickCount do begin end;
  asm
    DB 0FH
    DB 031H
    mov mhi,edx
    mov mlo,eax
  end;
  while GetTickCount < (t + 1000) do begin end;
  asm
    DB 0FH
    DB 031H
    mov nhi,edx
    mov nlo,eax
  end;
  chi := mhi;
  {$IFNDEF VER120}
  if mhi < 0 then chi := chi + shr32;
  {$ENDIF}
  clo := mlo;
  {$IFNDEF VER120}
  if mlo < 0 then clo := clo + shr32;
  {$ENDIF}
  t0 := chi * shr32 + clo;
  chi := nhi;
  {$IFNDEF VER120}
  if nhi < 0 then chi := chi + shr32;
  {$ENDIF}
  clo := nlo;
  {$IFNDEF VER120}
  if nlo < 0 then clo := clo + shr32;
  {$ENDIF}
  t1 := chi * shr32 + clo;
  Result := (t1 - t0) / 1E6;
end;

Sources : exemple d'un programme qui lit la Base de Registre pour trouver le cadensement du processeur
Sources : exemple d'un programme qui calcule le cadencement du processeur (ceci ne doit pas fonctionner avec un multi-processeur)

Comment poser une icône à coté de l'horloge Windows ?

Tout d'abors cette zone s'appelle "SysTray". Vous le savez peut-être déjà si vous connaissez bien Windows.
Nous utiliserons donc une API Windows : Shell_NotifyIcon, pour faire ce que l'on veux ici. Mais voyons quoi faire.

public
{ Déclarations publiques }
IconData : TNotifyIconData;

   IconData.CbSize           := SizeOf(IconData);
   IconData.Wnd              := Handle;
   IconData.uID              := 100;
   IconData.uFlags           := NIF_MESSAGE + NIF_ICON + NIF_TIP;
   IconData.uCallbackMessage := WM_USER +1;
   IconData.hIcon            := ExtractIcon(hInstance, PChar(ParamStr(0)), 0);
   StrPCopy(IconData.szTip, 'Décalage Horaire');
   Shell_NotifyIcon(NIM_ADD, @IconData);

procedure WndProc(var Msg: TMessage);
var Pt: TPoint;
begin
  case Msg.Msg of
    WM_USER +1:
     begin
       case Msg.LParam of
        WM_RBUTTONDOWN:
          begin
            GetCursorPos(Pt);
            Self.PopupMenuSystray.Popup(Pt.x, Pt.y);
          end;
        WM_LBUTTONDBLCLK:
          begin
            Self.mpShowHide.Click;
          end;
        WM_MOUSEMOVE:
          begin
            IconData.hIcon := ExtractIcon(HInstance, PChar(ParamStr(0)), 0);
            StrPCopy(IconData.szTip, Self.InfoBulleSystray);
            Shell_NotifyIcon(NIM_MODIFY, @IconData);
          end;
       end;
     end;
  end;
  inherited WndProc(Msg);
end;

Shell_NotifyIcon(NIM_DELETE, @IconData);

Sources : exemple d'un programme qui donne l'heure avec le décalage horaire de différentes villes. (Ne prend pas en compte les heures d'été/hiver)

Comment jouer avec le Bouton Start (Démarrer) de Windows ?

Je n'ai pas encore réussi à changer le dessin de ce bouton, ni à gérer son évévenment OnClick. Quand je l'ai récupéré dans ma fenêtre à moi, on ne peut plus clicker dessus. ;o(((
Le truc en fait, est que j'ai ré à changer le text du bouton Démarrer, mais comme il y a une image de posée dessus, changer le text ne change rien à l'écran. Je pense qu'il faudrait trouver le Handle de l'image du bouton, et changer sa valeur vers le handle de l'image que l'on veux y mettre. Mais je n'ai pas eu la patience de le faire pour vous. Un de ces quatres peut-être ?!...
Avec ces quatres fonctions, on peut jouer avec le bouton Démarrer.

function RecupHandleStartButton: HWND;
begin
   Result := FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil);
end;

function RecupHandleBarreDeTache: HWND;
begin
   Result := FindWindow('Shell_TrayWnd', nil);
end;

procedure ChangeParent(HandleObject, HandleParent: HWND);
begin
   SetParent(HandleObject, HandleParent);
end;

procedure GetBitmapButton(HandleButton: HWND; /Img: TImage);   / ne fonctionne pas en fait. Dommage...
var i: integer;
begin
   i := GetBitmapBits(HandleButton, 4096, /Img.Picture.Bitmap);
   if i = 0
   then ShowMessage('Error while getting Bitmap.');
end;

function ChangeTextButton(HandleButton: HWND; const Text: string): boolean;
begin
   if SetWindowText(HandleButton, PChar(Text))
   then Result := true
   else Result := false;
end;

function GetTextButton(HandleButton: HWND): string;
begin
   GetWindowText(HandleButton, PChar(Result), 256);
end;

Comment faire une fenêtre transparente ?

Cette fois (et ce ne sera pas la dernière) j'ai repiqué du code, sans chercher correctement à le comprendre. En fin de compte, on récupère ce qui est dessiné sur le Bureau Windows, et on le met dans l'image qui est sur notre fenêtre.
Le code ressemble à ça :

procedure TForm1.MapBackGround;
begin
   Self.Visible := false;
   DC           := GetDC( 0 );
   Canv         := TCanvas.Create;
   Canv.Handle  := DC;
   BitBlt(Image1.Canvas.handle, 0, 0, Self.Image1.Width, Self.Image1.Height, DC, Self.Left, Self.Top, SRCCOPY);
   ReleaseDC(0, DC);
   Self.Visible := true;
   Self.Refresh;
end;

Sources : exemple d'un programme qui fait une petite horloge sur fond tranparent.

Comment récupérer les information de version d'un fichier ?

On utilisera ici les API Windows : "GetFileVersionInfoSize", "GetFileVersionInfo" et "VerQueryValue", ainsi que le type de structure "TFixedFileInfo" qui décrit une structure de type Record renvoyée par les API.

PFixedFileInfo = ^TFixedFileInfo;
TFixedFileInfo = record
   Signature: DWord;
   StrucVersion: DWord;
   Minor: Word;
   Major: Word;
   Build: Word;
   Release: Word;
   FileFlagsMask: DWord;
   FileFlags: DWord;
   FileOS: DWord;
   FileType: DWord;
   FileSubtype: DWord;
   FileDateMS: DWord;
   FileDateLS: DWord;

Fonction de récupération de la structure contenant toutes les informations sur le fichier.

function GetFileInfo(const FileName: string): TFixedFileInfo;
var Handle, VersionSize: DWord;
    SubBlock: string;
    Temp: Pointer;
    Data: Pointer;
begin
   SubBlock := '/';
   VersionSize := GetFileVersionInfoSize(PChar(FileName), Handle);
   if VersionSize > 0
   then
   begin
      GetMem(Temp, VersionSize);
      try
         if GetFileVersionInfo(PChar(FileName), Handle, VersionSize, Temp)
         then if VerQueryValue(Temp, PChar(SubBlock), Data, VersionSize)
              then Result := PFixedFileInfo(Data)^;
      finally
         FreeMem(Temp);
      end;
   end;
end;

function GetVersion(const FileName: string): string;
var Info: TFixedFileInfo;
begin
    Info := GetFileInfo(FileName);
    with Info do
      Result := IntToStr(Major) + '.' + IntToStr(Minor) + '.' +
                IntToStr(Release) + '.' + IntToStr(Build);
end;

Sources : premier exemple d'un programme qui affiche les informations reccueillies.
Sources : second exemple d'un programme qui affiche les informations reccueillies.

Comment énumérer les functions exportées (external) d'un fichier DLL (Dynamic Link Library) ?

Nous utiliserons ici des méthodes décrites dans l'unité Delphi : ImageHlp
(Borland/Delphi 3/Sources/RTL/Win/Imagehlp.pas).
Les fonctions utilisées sont : MapDebugInformation et UnmapDebugInformation on utilisera aussi la structure de type RECORD : TImageDebugInformation.
On obtiend le code suivant :

procedure ListDLLFunctions(DLLName: string; List: TStrings);
type chararr = array[0..$FFFFFF] of char;
var h : THandle;
    i, fc : integer;
    st : string;
    arr : pointer;
    ImageDebugInformation : PImageDebugInformation;
begin
   List.Clear;
   DLLName := ExpandFileName(DLLName);
   if FileExists(DLLName)
   then
   begin
      h := CreateFile(PChar(DLLName),
                      GENERIC_READ,
                      FILE_SHARE_READ or FILE_SHARE_WRITE,
                      nil,
                      OPEN_EXISTING,
                      FILE_ATTRIBUTE_NORMAL,
                      0);
      if h <> INVALID_HANDLE_VALUE
      then try
              ImageDebugInformation := MapDebugInformation(h, PChar(DLLName), nil, 0);
              if ImageDebugInformation <> nil
              then
              try
                 arr := ImageDebugInformation^.ExportedNames;
                 fc := 0;
                 for i := 0 to ImageDebugInformation^.ExportedNamesSize -1 do
                 begin
                    if chararr(arr^)[i] = #0 then
                    begin
                       st := PChar(@chararr(arr^)[fc]);
                       if length(st) > 0
                       then List.Add(st);
                       if (i > 0) and (chararr(arr^)[i -1] = #0)
                       then Break;
                       fc := i +1;
                    end;
                 end;
              finally
                 UnmapDebugInformation(ImageDebugInformation);
              end;
           finally
              CloseHandle(h);
           end;
   end;
end;

Comment gérer un fichier de Log ?

On va faire une petite unité avec une procédure qui permet de "Loguer". Une chose fort utile dans tout développement d'application conséquente où l'on veut pouvoir tracer les actions d'un utilisateur (par exemple).

procedure Log(aFileName, aMessage: string; aFileSize, aLogLevel: integer);
var TxtFile: TextFile;
tmpDt: string;
begin

   if aLogLevel <= LogLevel
   then
   begin

AssignFile(TxtFile, aFileName);

      //                sinon, on l'ouvre en mode "rewrite" (création-écriture en début de fichier)
      if FileExists(aFileName)
      then Append(TxtFile)
      else Rewrite(TxtFile);

DateTimeToString(tmpDt, 'yyyy/mm/dd hh:nn:ss', now);
Writeln(TxtFile, tmpDt + ' : ' + aMessage);

ResizeLogFile(aFileName, aFileSize);

      CloseFile(TxtFile);
   end;
end;

procedure ResizeLogFile(aFileName: string; aFileSize: integer);
var FileStream: TFileStream;
    FileLines : TStringList;
begin

   if aFileSize > 0
   then
   begin
      FileStream := nil;
      FileLines := nil;
      try

FileStream := TFileStream.Create(aFileName, fmOpenRead);

while (FileStream.Size > aFileSize) do
begin

FileLines := TStringList.Create;

FileStream.Seek(0, soFromBeginning);

FileLines.LoadFromStream(FileStream);

FileLines.Delete(0);

            FileStream.Free;
            FileStream := TFileStream.Create(aFileName, fmCreate);
            FileLines.SaveToStream(FileStream);
         end;
      finally

         if FileStream <> nil
         then FileStream.Free;
         if FileLines <> nil
         then FileLines.Free;
      end;
   end;
end;

Comment redessiner la forme de sa fenêtre ?

Ce n'est pas si compliqué que ça en fait, il suffit de connaître les bonne API Windows et de tâtonner un peu. Ca peut même donner des trucs sympatoche de temps en temps. Suivent ici trois exemples, le premier nous fait une fenêtre aux bords arrondis (dans le genre une fenêtre de chargement avec une petite image et un message pour patienter), le second donne une forme bizarre à notre fenêtre, et le troisième fait des trous dans la fenêtre (le plus fun à vrai dire).
Les API Windows utilisées sont GetWindowRgn, SetWindowRogn, CombineRgn, CreateEllipticRgn...

Exemple 1 : Comment rogner sa fenêtre pour lui donner une forme elliptique ? Super simple en fait !

R := CreateEllipticRgn(16, 35, Width -14, Height -14);
SetWindowRgn(Handle,R,True);

Exemple 2 : Comment sélectionner plusieurs régions de la fenêtre et les assembler. Ici nous dessinerons une fenêtre à peu près rectangulaire (avec des coins arrondis) et nous ajouterons deux becs pointant vers le bas.

formregion := CreateRoundRectRgn(0, 0, clientwidth, clientheight -48, 40, 40);
beak[0] := Point(50, clientheight -50);
beak[1] := Point(55, clientheight );
beak[2] := Point(80, clientheight -50);
beakregion := CreatePolygonRgn(beak, 3, WINDING);
CombineRgn(formregion, formregion, beakregion, RGN_OR);
DeleteObject(beakregion);
beak[0] := Point(clientwidth -50, clientheight -50);
beak[1] := Point(clientwidth -55, clientheight );
beak[2] := Point(clientwidth -80, clientheight -50);
beakregion := CreatePolygonRgn(beak, 3, WINDING);
CombineRgn(formregion, formregion, beakregion, RGN_OR);
DeleteObject(beakregion);
SetWindowRgn(handle, formregion, true);

Exemple 3 : Comment percer des trous dans sa fenêtre. Ici nous serons obligé de mémoriser tous les clicks que nous ferons sur la fenêtre, pour pouvoir les redessiner. Nous y sommes obligé car il nous faut redessiner toutes la région de la fenêtre qui a été modifiée à chaque nouveau trou. l'API GetWindowRgn ne semble pas fonctionner pour récupérer les régions complexes.

SetWindowRgn(Self.Handle, 0, true);
Self.FormRegion := CreateRoundRectRgn(0, 0, Width, Height, 0, 0);
GetWindowRgn(Self.Handle, Self.FormRegion);

with Self.PointList do
begin
   Region := CreateEllipticRgn(TClick(Items[0]).X - TClick(Items[0]).R,
                               TClick(Items[0]).Y - TClick(Items[0]).R,
                               TClick(Items[0]).X + TClick(Items[0]).R,
                               TClick(Items[0]).Y + TClick(Items[0]).R);

   for i := 1 to Self.PointList.Count -1 do
   begin
      CombineRgn(Region,
                 Region,
                 CreateEllipticRgn(TClick(Items[i]).X - TClick(Items[i]).R,
                                   TClick(Items[i]).Y - TClick(Items[i]).R,
                                   TClick(Items[i]).X + TClick(Items[i]).R,
                                   TClick(Items[i]).Y + TClick(Items[i]).R),
                 RGN_OR);
   end;
end;

CombineRgn(Self.FormRegion, Self.FormRegion, Region, RGN_XOR);
DeleteObject(Region);
SetWindowRgn(Self.Handle, Self.FormRegion, true);

Sources : exemple 1 : un programme qui dessine une fenêtre elliptique.
Sources : exemple 2 : un programme qui dessine une fenêtre bizarre en assemblant plusieurs régions.
Sources : exemple 3 : un programme qui fait des trous dans la fenétre.

Comment créer un raccourcis Windows ?

Rien de plus simple (enfin... quand on sait faire). Une API Windows à utiliser. Ca n'est pas évident à trouver et ça ne s'invente pas, je vous l'accorde. Démonstration tout de suite.

if CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IID_IShellLinkA, ps1) = S_OK
then
begin
   StrPCopy(buf, Target);
   ps1.SetPath(buf);
   StrPCopy(buf, Icon);
   ps1.SetIconLocation(buf, 0);
   StrPCopy(buf, Arguments);
   ps1.SetArguments(buf);
   StrPCopy(buf, WorkingDir);
   ps1.SetWorkingDirectory(buf);
   StrPCopy(buf, '');
   ps1.SetDescription(buf);
   if ps1.QueryInterface(IID_IPersistFile, archive) = S_OK
   then
   begin
      StrPCopy(buf, ShortCut);
      MultiByteToWideChar(CP_ACP, 0, buf, -1, bufw, 300);
      archive.Save(bufw, TRUE);
      Result := TRUE;
   end
   else Result := FALSE;
end
else Result := FALSE;

Comment récupérer l'adresse MAC de sa carte réseau ?

L'adresse MAC c'est un code unique (GUID : Global Unique IDentifier) qui va de paire avec la carte réseau de votre machine. Chaque carte réseau a un identifiant unique ; ce qui permet d'ailleurs si vous avez envie de sécuriser un réseau d'entreprise de n'autoriser l'accès à certains services/serveur/machine/... qu'à certaines personnes, le tout grace aux GUID des cartes réseau. Bon courrage quand même.
Enfin, si vous n'avez pas de carte réseau et que vous demandez la création d'un GUID, il ne sera unique que sur votre machine.
Ici donc, nous allons utiliser ceci pour nous faciliter la tâche. En gros, nous allons demander la création d'un GUID (avec "CoCreateGuid" fonction externe de la DLL "ole32.dll"), et nous allons récupérer le l'adresse MAC de la carte qui se trouve dedans. Il existe une autre méthode bien plus complexe qui consiste à aller chercher l'adresse directement sur la carte (à vérifier) avec l'API NetBios.
Suit la solution la plus simple :

function CoCreateGUID(var guid: TGUID): HResult; stdcall; far external 'ole32.dll';

function Get_MACAddress: string;
var g: TGUID;
    i: byte;
begin
   Result := '';
   CoCreateGUID(g);
   for i := 2 to 7 do
      Result := Result + IntToHex(g.D4[i], 2) + '-';
   Result := Copy(TRIM(Result), 1, Length(Result) -1);
end;

Pour l'autre méthode, la plus compliquée, allez chercher dans les sources en dessous.

Sources : exemple d'un programme qui affiche de plusieurs manières différentes l'adresse MAC.

Et pour changer, un petit composant : TMultilineButton

C'est top cool d'avoir un bouton sur lequel on peut écrire sur plusieurs ligne non ?! En plus maintenant qu'on a celui ci, on peut facilement faire la même chose avec d'autres composants et se faire tout un palette.

TMultilineButton = class(Tbutton)
private
protected
  function  GetCaption    : string;                         virtual;
  procedure SetCaption    (const aValue: string);           virtual;
public
  procedure CreateParams  (Var params: TCreateParams);     override;
  constructor Create      (aOwner: TComponent);                 override;
published
  property Caption  : string     read GetCaption     write SetCaption;
end;

procedure TMultilineButton.CreateParams(var Params: TCreateParams);
begin
inherited;
Params.Style := Params.Style or BS_MULTILINE;
end;

procedure TMultilineButton.SetCaption(const aValue: string);
begin
   if aValue <> Caption
   then
   begin
      inherited Caption := StringReplace(aValue, '|', #13);
      Invalidate;
   end;
end;

function TMultilineButton.GetCaption: string;
begin
   Result := StringReplace(inherited Caption, #13, '|');
end;

Comment changer programmatiquement l'imprimante par défaut de Windows ?

Une chose qui paraît assez simple quand on sait que lorsqu'on inclut l'unité Delphi "Printers" à son projet, une instance d'objet appelée "Printer" est automatiquement créée, et que en changeant sa propriété "PrinterIndex", on peut changer l'imprimante sur laquelle on veut imprimer. Mais le problème ici présent est que le changement effectué n'a d'effet que dans l'application courante.
Pour modifier l'imprimante par défaut de Windows, nous allons utiliser les API : "WriteProfileString" et "SendMessage". La première pour dire à Windows de changer son imprimante par défaut, et la seconde pour prévenir en direct live les autres process que cette valeur à changée.

procedure TForm1.ChangePrinterDefault;
var Device      : array[0..255] of char;
    Driver      : array[0..255] of char;
    Port        : array[0..255] of char;
    hDeviceMode : THandle;
begin
   Printer.PrinterIndex := StrToInt(Self.EdtNewDefaultPrinter.Text);
   Printer.GetPrinter(Device, Driver, Port, hDeviceMode);
   StrCat(Device, ',');
   StrCat(Device, Driver);
   StrCat(Device, ',');
   StrCat(Device, Port);
   WriteProfileString('windows', 'device', Device);
   StrCopy(Device, 'windows');
   SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, longint( @Device));
end;

Sources : exemple d'un programme qui liste les différentes imprimantes installées, et qui change l'imprimante par défaut.

Comment changer les dates de création et de modification d'un fichier ?

Il existe une API Windows qui s'appelle "SetFileTime". Et bien voilà ! Le travail est fait. Maintenant, il ne reste plus qu'à savoir deux ou trois petites choses et puis c'est bon. Des petits trucs dans le genre il faut ouvrir le fichier en écriture, il faut changer toutes les dates du fichier pour que ça fonctionne, il y a trois dates différentes pour un fichier sous Windows : Date de Création, de Dernière Modification et de Dernier Accès. Bon aller, un petit exemple de Code qui nous fait ça.
En revanche, j'ai pu remarquer un fonctionnement bizarre sous Windows NT4 SP4. Quand je donne une heure précise (par ex 12:00:00), les fichiers sont modifier avec une heure de plus (13:00:00) mais dans mon appli, elles sont à pile l'heure voulue pour l'heure de Création et à -2 pour l'heure de dernière Modif. Alors, si quelqu'un peut me dire pourquoi. J'en serait bien content.

function TwChangeFileDate.SetFileCreateTime(const FileName: string; CreateDateTime: TDateTime): boolean;
var F            : THandle;
    FileCreateTime: TFileTime;
    SysTime       : TSystemTime;
begin
   DateTimeToSystemTime(CreateDateTime, SysTime);
   SystemTimeToFileTime(SysTime, FileCreateTime);
   F := CreateFile(PChar(FileName), GENERIC_WRITE, 0, nil, OPEN_EXISTING, 0, 0);
   if F <> INVALID_HANDLE_VALUE
   then
   begin
      try
         Result := SetFileTime(F, @FileCreateTime, @FileCreateTime, @FileCreateTime);
      finally
         CloseHandle(F)
      end;
   end
   else Result := FALSE;
end;

Sources : exemple d'un programme qui modifie ces dates sur une liste de fichiers sélectionnés.

Comment faire en sorte qu'une seule instance de son programme ne s'exécute à la fois ?

Un moyen simple et intuitif voudrait qu'on liste les applications en cours d'exétion et que lon ne s'exécaute pas si on existe déjà. Mais franchement, c'est pas beau et en plus c'est long. Non, nous vivons dans un monde merveilleux où on il existe un "truc" fantastique qui s'appelle "Mutex". En gros, l'application essaye de trouver un Mutex, si elle le trouve c'est qu'elle s'exécute déjà, sinon elle crée ce Mutex, et dans ce cas, toutes les autres occurances lancées le trouveront et ne s'exécuteront pas. Simple non ?!

function AlreadyLoaded;
begin
   result := True;
   if OpenMutex(MUTEX_ALL_ACCESS, False, pChar(ExtractFileName(Application.ExeName))) <> 0
   then exit;
   MutexHandle := CreateMutex(Nil, True, pChar(ExtractFileName(Application.ExeName)));
   if MutexHandle = 0
   then exit;
   Result := False;
end;

Un petit programme de zieutage de CaribouManga

Un petit délire pour regarder les Mangas des aventures de Caribou qui se trouve sur le site : Les Caribouteries d'Al-Kashi.

Récupérer son adresse IP

Je ne donnerai ici que la fonction, pas de sources pour son utilisation parce qu'elle est vraiment trop simple. La fonction renvoie l'adresse IP de la machine sous forme d'une chaine de caractères. C'est tout ce qu'il y a à dire. Ah si ! Il faut ajouter l'unités "WinSock" dans la liste des "uses"

function GetIP: String;
type
   TaPInAddr = Array[0..10] of PInAddr;
   PaPInAddr = ^TaPInAddr;
var
   phe: PHostEnt;
   pptr: PaPInAddr;
   Buffer: Array[0..63] of Char;
   I: Integer;
   GInitData: TWSAData;
begin
   WSAStartup($101, GInitData);
   Result := '';
   GetHostName(Buffer, SizeOf(Buffer));
   phe := GetHostByName(buffer);
   if phe = nil then Exit;
   pPtr := PaPInAddr(phe^.h_addr_list);
   I := 0;
   while pPtr^[I] <> nil do
   begin
      Result := inet_ntoa(pptr^[I]^);
      Inc(I);
   end;
   WSACleanup;
end;

Récupérer le UserName par défaut d'une Machine

La function GetDefaultNetWareUserName fait tout ça très bien. Et la voici ! Ca fonctionne très bien sous Windows NT, sur les autres système MS, je n'ai pas testé.

function GetDefaultNetWareUserName: string;
var ipNam: PChar;
    Size: DWord;
begin
   ipNam := nil;
   Size := 128;
   try
      Result   := '';
      GetMem(ipNam, Size);
      if GetUserName(ipNam, Size)
      then Result := UpperCase(TRIM(strPas(ipNam)))
      else Result := '?';
   finally
      FreeMem(ipNam, 10);
   end;
end;

Récupérer le nom de la machine

Une fois encore une simple function sans programme pour expliquer, rien de plus simple.

function GetDefaultComputerName: string;
var ipNam: PChar;
    Size: DWord;
begin
   ipNam := nil;
   Size := MAX_COMPUTERNAME_LENGTH + 1;
   try
      Result := '';
      GetMem(ipNam, Size);
      if GetComputerName(ipNam, Size)
      then Result := UpperCase(TRIM(strPas(ipNam)))
      else Result := '?';
   finally
      FreeMem(ipNam, 10);
   end;
end;

Récupérer la version d'un programme

Ici, un petit piège, il faut déclarer ces deux types dans la clause TYPE de l'INTERFACE de l'unité dans laquelle vous posez cette fonction (ou alors dans uen unités qui se trouve dans la clause USES).

function GetVersion: string;
var Handle, VersionSize: DWord;
    SubBlock: string;
    Temp: Pointer;
    Data: Pointer;
    Info: TFixedFileInfo;
begin
   SubBlock := '\';
   VersionSize := GetFileVersionInfoSize(PChar(Application.ExeName), Handle);
   if VersionSize > 0
   then
   begin
      GetMem(Temp, VersionSize);
      try
         if GetFileVersionInfo(PChar(Application.ExeName), Handle, VersionSize, Temp)
         then if VerQueryValue(Temp, PChar(SubBlock), Data, VersionSize)
              then Info := PFixedFileInfo(Data)^;
      finally
         FreeMem(Temp);
      end;
   end;
   with Info
   do Result := IntToStr(Major) + '.' + IntToStr(Minor) + '.' + IntToStr(Release) + '.' + IntToStr(Build);
end;

Des fenêtres de Dialogue toujours centrées sur une autre fenêtre

En fait la procédure intéressante est ici : CenterDlgOnOwnnerWin, mais je donne l'unité en entier comme ça, il n'y a plus qu'à l'ajouter au projet, et appeler les fonctions adaptées ( WinMessInformation(Application.MainForm, 'Ceci est une fenêtre d''information'); par exemple).
Le truc c'est que quand on veux centrer une fenêtre par rapport à une autre, il ne faut penser oublier de penser à vérifier si l'autre fenêtre existe et si sa propriété Left/Top n'ont pas changées de référentiel (exemple typique, une fenêtre fille d'une application MDI (FormStyle = fsMDIChild) dont le Top et le Left on pour référentiel la partie utilisable de la fenêtre principale de l'application MDI). Et c'est là que j'ai ramé avant d'y réfléchir un bon coup. ;o)

procedure CenterDlgOnOwnerWin(Own, Dlg: TForm);
var oTop, oLeft, oWidth, oHeight,
    dTop, dLeft, dWidth, dHeight: integer;
begin
   // initialisations
   if Own = nil
   then // si la fenêtre appelante est = nil, on centre sur l'écran
   begin
      oTop     := 0;
      oLeft    := 0;
      oWidth   := Screen.Width;
      oHeight  := Screen.Height;
   end
   else // sinon, on centre sur la fenêtre
   begin
      oTop     := Own.Top;
      oLeft    := Own.Left;
      oWidth   := Own.Width;
      oHeight  := Own.Height;
   end;
   dWidth   := Dlg.Width;
   dHeight  := Dlg.Height;
   // calculs
   if (Own.FormStyle = fsMDIChild)
   then
   begin
      dLeft    := oLeft + Application.MainForm.Left + (oWidth  div 2) - (dWidth  div 2);
      dTop     := oTop  + Application.MainForm.Top  + (oHeight div 2) - (dHeight div 2);
   end
   else
   begin
      dLeft    := oLeft + (oWidth  div 2) - (dWidth  div 2);
      dTop     := oTop  + (oHeight div 2) - (dHeight div 2);
   end;
   // centrage de la fenêtre Dlg
   Dlg.Top  := dTop;
   Dlg.Left := dLeft;
end;

Quelques répertoires spéciaux de Windows

Alors en fait, il existe trois (ou plus) API qui nous donnent le chemin de répertoires spéciaux : GetTempPath, GetWindowsDirectory, GetSystemDirectory. Ces trois là étant très facile à utiliser, je ne passerai pas plus de temps dessus.
En revanche, il y a une autre API bien plus simpatoche : SHGetSpecialFolderLocation qui accepte pour paramètre des constantes un peu spéciales qui caractérisent un répertoire spécifique du Menu Démarrer ou du répertoire Windows/Profiles (je pense qu'elle est réservée pour NT)
Cette API nous donne donc accès à des chemins (parfois virtuels comme le répertoire "fonts" qui regroupe simplement toutes les fonts installées quelques soient le répertoire réel où on trouvera les fichier de ses polices) qui peuvent nous permettre d'utiliser quelques options simpathiques de Windows (ajouter son appli dans les "send to", dans le menu démarrer, sur le bureau...)

function TwSpecialFolder.GetSpecialFolder(Folder: integer): string;
var p  : pitemidlist;
    pc : pchar;
begin
   SHGetSpecialFolderLocation (Self.Handle, Folder, p);
   GetMem(pc, MAX_PATH);
   if SHGetPathFromIDList (p, pc)
   then Result := String(pc)
   else Result := 'Error';
   FreeMem(pc, MAX_PATH);
end;

Cette fonction prend pour paramètre ces fameuses constantes :
Tous les répertoires récupérés ici sont en fait des répertoires spéciaux, parfois même de faux répertoires (des sorte de répertoires imaginaires quoi, des trucs pour regrouper les informations sans qu'elles le soient vraiment, une sorte de vision de l'esprit.) Et tous ceux qu'on retrouve ici sont en fait des répertoires privés pour chaque utilisateur. Je ne sais pas comment ça fonctionne (ni même si ça fonctionne) sous Win 9x, en tout cas sous NT, les répertoires récupérés sont du genre "C:\Winnt\Profiles\Lefoujd\..."

CSIDL_BITBUCKET        : ???
CSIDL_CONTROLS         : Répertoire Control Panel / Panneau de Contrôle
CSIDL_DESKTOP          : Répertoire Desktop / Bureau (pour ajouter des icones sur le bureau par exemple)
CSIDL_DESKTOPDIRECTORY : idem
CSIDL_DRIVES           : ???
CSIDL_FONTS            : Répertoire Fonts / Polices (pour récupérer les polices de caractères)
CSIDL_NETHOOD          : Répertoire Voisinage Réseau
CSIDL_NETWORK          : ???
CSIDL_PERSONAL         : Répertoire personnel
CSIDL_PRINTERS         : Répertoire listant les imprimantes
CSIDL_PROGRAMS         : Répertoire Menu Démarrer / Programmes
CSIDL_RECENT           : Répertoire Fichiers Récents
CSIDL_SENDTO           : Répertoire Send to / Envoyer vers
CSIDL_STARTMENU        : Répertoire Menu Démarrer
CSIDL_STARTUP          : Répertoire Menu Démarrer / Programme / Démarrage
CSIDL_TEMPLATES        : Répertoire Templates