Procédure et fonction Delphi

Divers

Réduction d'affichage d'un chemin

function retourne(a: string; b: integer):string;
var x: integer;
begin
  result := '';
  if b > length(a) then b := length(a);
  for x := 1 to b do
    result := a[x] + result
end;

function affiche(a: string): string;
var x: integer;
begin
  result := a;
  if length(a) < 40 then exit;
  a := retourne(a, 65535);
  result := retourne(a, pos('\', a));
  a := retourne(a, 65535);
  result := ' . . . ' + result;
  result := copy(a, 1, pos('\', a))+ result // ou result := copy(a, 1, 40 - length(result))+ result
end;

Accès à un composant indexé:

form1.FindComponent('Edit'+IntToStr(i)) as TEdit).clear

Dates

Bissextile:

Function Bisextil(an: word): word;
var an1, an2: word;
begin
  an1 := an div 100; an2 := an mod 100;
  if an2 mod 4 = 0 then result := 1 else result := 0;
  if (an2 = 0) and (an1 mod 4 <> 0) then result := 0;
end;

Jour est semaine:

Function  JourSemaine(val: string; dat: TDateTime): word;
var an, mo, jo, jd, bis: word;
begin
  DecodeDate(dat, an, mo, jo);
  jd := DayOfWeek(EncodeDate(an, 1, 1)); bis := bisextil(an);
  Case mo of
     1: mo := 0;
     2: mo := 31;
     3: mo := 59 + bis;
     4: mo := 90 + bis;
     5: mo := 120 + bis;
     6: mo := 151 + bis;
     7: mo := 181 + bis;
     8: mo := 212 + bis;
     9: mo := 243 + bis;
    10: mo := 273 + bis;
    11: mo := 304 + bis;
    12: mo := 334 + bis
  end;
  case jd of
    1: jd := 5;
    2: jd := 6;
    3: jd := 7;
    4: jd := 8;
    5: jd := 9;
    6: jd := 3;
    7: jd := 4
  end;
  if val = 'semaine' then
    begin
      result:= ( mo + jo + jd ) div 7;
      if (result = 53) and (dayofweek(encodedate(an + 1, 1, 1)) < 6) then result := 1;
      if result = 0 then result := joursemaine('semaine',encodedate(an -1, 12 ,31));
    end;
  if val ='jour' then Joursemaine := mo + jo
end;

Pâques:

http://www.tondering.dk/claus/calendar.html
function Paques(Year: word = 0 ): TDateTime;
var a, b, c, d, e, mois, jour: integer;
begin
    a := Year mod 19;
    b := Year div 100;
    c := ( b - ( b div 4 ) - ( ( 8 * b + 13 ) div 25 ) + ( 19 * a ) + 15 ) mod 30;
    d := c - ( c div 28 ) * ( 1 - ( c div 28 ) * ( 29 div ( c + 1 ) ) * ( ( 21 - a ) div 11 ) );
    e := d - ( (Year + (Year div 4 ) + d + 2 - b + ( b div 4 ) ) mod 7 );
    mois := 3 + ( ( e + 40 ) div 44 );
    jour := e + 28 - ( 31 * ( mois div 4 ) );
    Result := EncodeDate(Year, mois, jour );
end;

Chaînes

Suppression des espaces inutiles en début et fin de chaîne ainsi que les espaces doublés:

function supespas(x: string): string;
var compt: integer;
begin
  while x[1] = ' ' do delete(x, 1, 1);
  compt := 1;
  while compt <= length(x) do
    if (x[compt] = ' ') and ((x[compt + 1] = ' ')or(x[compt + 1] = ''))
      then delete(x, compt, 1)
      else inc(compt);
  result := x
end;

Remplacement dans une chaîne x des caractères y par les caractères z:

ex: changlettre('azertyuiop', 'etu', 'qsd') = 'azqrsydiop'
function changlettre(x: string; y: string; z: string): string;
var a: integer;
begin
  if length(y) <> length(z) then raise EConvertError.create('erraur');
  for a := 1 to length(x) do
    if pos(x[a], y) <> 0 then x[a] := z[pos(x[a], y)];
  result := x
end;

Supprime dans la chaîne x tous les caractères autre que ceux présents dans la chaîne y:

ex: suplettre('azertyuiopqsdfghjklmwxcvbn', 'aeiouy') = 'aeyuio'
function suplettre(x: string; y: string): string;
var compt: integer;
begin
  compt := 1;
  while compt <= length(x) do
    if pos(x[compt], y) = 0 then delete(x, compt, 1) else inc(compt);
  result := x
end;

Inversion des caractères dans une chaîne:

function reversestring(x: string): string;
var a: integer;
begin
  result := '';
  for a := 1 to x[0] do
    result := x[a] + result
end;
 

Les fichiers

Copie d'un fichier:

copyfile(pchar('file'), pchar('file2'), boolean): boolean. Si bool = fasle, le fichier ne sera pas copié si il existe déjas.
Rend la valeur true si tout c'est bien passé sinon false.

Déplacer un fichier:

Movefile('file', 'file2'): boolean(true/false) déplace le fichier file vers file2.
Rend la valeur true si tout c'est bien passé sinon false.

Suppression d'un fichier:

sysutils.DeleteFile(NomFichier):boolean
Rend la valeur true si tout c'est bien passé sinon false.

Créer un répertoire:

CreateDir('Chemin complet du répertoire'):boolean
Rend la valeur true si tout c'est bien passé sinon false.

Non du répertoire windows:

var buffer: array [0..255] of char;
begin
  GetWindowsDirectory(buffer, SizeOf(buffer));
  repwindows := buffer;

Fichier passer au démarrage de l'application:

paramcount = Nombre de fichier;
paramstr(a) = nom du fichier; //a de 1 à paramcount, paramstr(0) = Nom du programme

Drag and drop:

Pour fichier:
use messages, shellapi;
private
  procedure WMDropFiles(var msg : TMessage); message WM_DROPFILES;
---
procedure TForm1.FormCreate(Sender: TObject);
begin
  DragAcceptFiles( Handle, True);
end;

procedure TForm1.WMDropFiles(var msg : TMessage);
var hand: THandle; nbFich, i : integer; buf:array[0..254] of Char; count: integer;
begin
  hand:=msg.wParam;
  nbFich:= DragQueryFile(hand, 4294967295, buf, 254);
  for i:= 0 to nbFich - 1 do
    begin
      DragQueryFile(hand, i, buf, 254);
      buf = nom du fichier<-----------------------------------------------------------------------
    end;
  DragFinish(hand)
end;

Pour texte:
uses messages, ActiveX, ComObj, ShellAPI;

Type TForm1 = class(TForm, IDropTarget)

private
    function DragEnter(const dataObj: IDataObject;
                       grfKeyState: Longint;
                       pt: TPoint;
                       var dwEffect: Longint): HResult; stdcall;
    function DragOver(grfKeyState: Longint;
                      pt: TPoint;
                      var dwEffect: Longint): HResult; stdcall;
    function DragLeave: HResult; stdcall;
    function Drop(const dataObj: IDataObject;
                  grfKeyState: Longint; pt: TPoint;
                  var dwEffect: Longint): HResult; stdcall;
   function _AddRef: Integer; stdcall;
   function _Release: Integer; stdcall;
---
procedure TForm1.FormCreate(Sender: TObject);
begin
  OleInitialize(nil);
  OleCheck(RegisterDragDrop(Handle, Self));
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  RevokeDragDrop(Handle);
  OleUninitialize;
end;

function TForm1.DragEnter(const dataObj: IDataObject;
  grfKeyState: Longint;
  pt: TPoint;
  var dwEffect: Longint): HResult;
begin
  dwEffect := DROPEFFECT_COPY;
  Result  := S_OK;
end;

function TForm1.DragOver(grfKeyState: Longint;
  pt: TPoint;
  var dwEffect: Longint): HResult;
begin
  dwEffect := DROPEFFECT_COPY;
  Result := S_OK;
end;

function TForm1.DragLeave: HResult;
begin
  Result := S_OK;
end;

function TForm1._AddRef: Integer;
begin
   Result := 1;
end;

function TForm1._Release: Integer;
begin
   Result := 1;
end;

function TForm1.Drop(const dataObj: IDataObject;
  grfKeyState: Longint;
  pt: TPoint;
  var dwEffect: Longint): HResult;
var
  aFmtEtc: TFORMATETC;
  aStgMed: TSTGMEDIUM;
  pData: PChar;
begin
  if (dataObj = nil) then
    raise Exception.Create('IDataObject-Pointer is not valid!');
  with aFmtEtc do
  begin
    cfFormat := CF_TEXT;
    ptd := nil;
    dwAspect := DVASPECT_CONTENT;
    lindex := -1;
    tymed := TYMED_HGLOBAL;
  end;
  OleCheck(dataObj.GetData(aFmtEtc, aStgMed));
  try
    pData := GlobalLock(aStgMed.hGlobal);
    pData = "texte reçus"<---------------------------------------------------------
  finally
    GlobalUnlock(aStgMed.hGlobal);
    ReleaseStgMedium(aStgMed);
  end;
  Result := S_OK;
end;
 

Recherche d'un fichier dans un répertoire:

Procedure tform1.recherche(nom: string);
var fichier: tsearchrec; erreur: integer;
begin
  erreur := sysutils.findfirst('répertoire', faanyfile, 'fichier');
  while erreur = 0 do {erreur = 0 fichier trouvé, = 2 fichier non trouvé}
    begin
      while (erreur = 0) and ((fichier.Name = '.') or (fichier.Name ='..')) do erreur := findnext(fichier);
      fichier.Name = nom du fichier trouvé;
      fichier.attr = attribue du fichier {readonly = 1, caché = 2, système = 4, volume = 8, répertoire = 16, archive = 32, tous le fichier = 64 ?}
      fichier.size = taille du fichier
      fichier.time = date du fichier
      erreur := sysutils.findnext(fichier) // fichier suivant
    end;
  sysutils.findclose(fichier);
end;

Lance une application

Rend la valeur true si tout c'est bien passé sinon false.
Utilise shellapi:
Shellexecute(0, 'open', 'executable', nil, nil, sw_show): boolean(true/false); lance l'application executable
Utilise windows:
Winexec(pchar(programme), x): boolean. Lance le programme, x = 1 normal, 2 réduit,  3 agrandit.

Les disques

Place libre sur un disque:

diskfree(Nombre) = place libre. Nombre = 1 pour A, 2 pour B, etc...Si place libre = -1 le numéro du disque est incorrecte.

Imprimer

PrintDialog.execute
Printer.Orientation := PoPortrait ou PoLandScape
Printer.BeginDoc Début du document
Printer.EndDoc Fin du document
Printer.Canvas.TextOut(x, y, 'azertyui') Remplissage du document d'impression
Printer.Cavas.Draw(x, y, image.picture.graphic) x et y position du texte ou image dans l'impression
Var x: system.text;
begin
  AssignPrn(x);
  Rewrite(x);
  WriteLn(x, 'dtukjfygjk');
  System.close(x)
end;

Les blocs de sécurité

Exemple:
procedure enregistrement;
var fichier: textfile; a: integer;
begin
 
try {début du bloc de sécurité}
  assignfile(fichier,repwindows + '\eadsinfo.ini'); {affectation de la variable}
  rewrite(fichier); {ouverture du fichier}
except {Début traitement de l'erreur
  exit si il y a un problème le programme passe par except (ici on arrête tout avec exit)
end; fin du bloc de sécurité,}
   
try {début du bloc de sécurité}
  writeln(fichier, inttostr(form1.Width));
  writeln(fichier, inttostr(form1.height));
  writeln(fichier, inttostr(form1.top));
  writeln(fichier, inttostr(form1.left));
finally {Début passage obligé,
  closefile(fichier) quel que soit l'exécution précédente le programme passe par ici pour fermer le fichier,
end; fin du bloc de sécurité}
end;