1. Accueil
  2. Tous les snippets
  3. Snippets Delphi / Pascal
  4. K-eagle : ensemble de fonctions utiles (fichiers, système, strings, rs232 ...)

K-eagle : ensemble de fonctions utiles (fichiers, système, strings, rs232 ...)

3/5 (1 avis)

Snippet vu 7 803 fois - Téléchargée 196 fois

Commenter

Contenu du snippet

Voila quelques fonctions qui pouront rendre service à certains.
Il y a 3 sortes de foctions :
  • fabriqués maison
  • modifiés maison
  • copiés sur d'autres sources


Mises à jours prevues pour bientôt.

Bonne prog.

Source / Exemple : 


unit perso;

interface

uses
  Windows,Messages,Dialogs,SysUtils,Math,Classes, Consts, ShellAPI, Forms ;

type
  EInvalidDest = class(EStreamError);
  EFCantMove = class(EStreamError);

//-------------------------------------------------------------------------------------
// ------- DECLARATION DES PROCEDURES ET FONCTIONS ------------------------------------
//-------------------------------------------------------------------------------------

// Fonctions divers
procedure TEMPO(temps:longint);
function Crypter(str_pass_original : string ) : string;

// Fonctions mathématiques
function Arrondir( nombre : extended ; nbDecim : extended) : extended;

// Liaison série RS232
procedure InitPort;
procedure OpenPort;
procedure ClosePort;
function Envoi_RS232( str_envoi : string) : boolean;

// Fonctions système
procedure SimuClick(bouton : integer ; x : DWord ; y : DWord);

// Opérations sur fichiers et dossiers
procedure CopieFichier(Const sourcefilename, targetfilename : string);
procedure MakeDir(s:string);
procedure MoveFile(const FileName, DestName: string);
function GetFileSize(const FileName: string): LongInt;
function FileDateTime(const FileName: string): TDateTime;
function HasAttr(const FileName: string; Attr: Word): Boolean;
function ExecuteFile(const FileName, Params, DefaultDir: string;
  ShowCmd: Integer): THandle;

// Traitement sur chaînes de caractères
function NumToString(str : string ; nb_0 : integer) : string;
function EnleverCaracteres( str_chaine : string; position : integer; nb_car : integer) : string;
function EnleverChaine( str_chaine_source : string ; str_chaine_a_effacer : string ) : string;
function NombreRepetitionsChaine(str_chaine_source : string; chaine_a_compter : string ) : integer;
function PresenceCaracteres(str_chaine_source : string ; chaine_carac : string) : boolean;
function EnleverExtension(str : string) : string;

// Déclaration de constantes
const

     // Carcteres Speciaux
     NUMEROS = '0123456789';
     LETTRES_MIN = 'abcdefghijklmnopqrstuvwxyz';
     LETTRES_MAJ = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ';
     INTERDITS_FICHIERS = ',;:!./*$?#{}][''';

     // Fonction enlever caracteres
     DEBUT = 0;
     FIN = 1;

     // Event Click Souris
     DROIT = 1;
     GAUCHE = 2;
     MILIEU = 3;

     NULL = 0;

     SInvalidDest = 'Le fichier de destination %s n''existe pas';
     SFCantMove = 'Impossible de déplacer %s';

// Déclaration de variables globales
var

test : integer;
DCB:TDCB;
RS232_ouverte,test_RS232:Boolean;
Hdl,Hdl2:THandle;

implementation

//*******************************************************************************
//*******************************************************************************
//******                                             ****************************
//******  FONCTIONS SUR LES FICHIERS ET REPERTOIRES  ****************************
//******                                             ****************************
//*******************************************************************************
//*******************************************************************************

{ MoveFile procedure }
{
  Moves the file passed in FileName to the directory specified in DestDir.
  Tries to just rename the file.  If that fails, try to copy the file and
  delete the original.

  Raises an exception if the source file is read-only, and therefore cannot
  be deleted/moved.
}

procedure MoveFile(const FileName, DestName: string);
var
  Destination: string;
begin
  Destination := ExpandFileName(DestName); { expand the destination path }
  if not RenameFile(FileName, Destination) then { try just renaming }
  begin
    if HasAttr(FileName, faReadOnly) then  { if it's read-only... }
      raise EFCantMove.Create(Format(SFCantMove, [FileName])); { we wouldn't be able to delete it }
      CopieFichier(FileName, Destination); { copy it over to destination...}
//      DeleteFile(FileName); { ...and delete the original }
  end;
end;

{ GetFileSize function }
{
  Returns the size of the named file without opening the file.  If the file
  doesn't exist, returns -1.
}

function GetFileSize(const FileName: string): LongInt;
var
  SearchRec: TSearchRec;
begin
  if FindFirst(ExpandFileName(FileName), faAnyFile, SearchRec) = 0 then
    Result := SearchRec.Size
  else Result := -1;
end;

function FileDateTime(const FileName: string): System.TDateTime;
begin
  Result := FileDateToDateTime(FileAge(FileName));
end;

function HasAttr(const FileName: string; Attr: Word): Boolean;
begin
  Result := (FileGetAttr(FileName) and Attr) = Attr;
end;

function ExecuteFile(const FileName, Params, DefaultDir: string;
  ShowCmd: Integer): THandle;
var
  zFileName, zParams, zDir: array[0..79] of Char;
begin
  Result := ShellExecute(Application.MainForm.Handle, nil,
    StrPCopy(zFileName, FileName), StrPCopy(zParams, Params),
    StrPCopy(zDir, DefaultDir), ShowCmd);
end;

{fabrique un sous-répertoire donné avec gestion d'erreurs}

procedure MakeDir(s:string);
var Rech: TSearchRec;
begin
     {$I-}
     if FindFirst(s+'\*.*', faDirectory, Rech)<>0 then begin {s'il n'existe pas déjà}
        MkDir(s);
        if IOResult <> 0 then
           MessageDlg('Impossible de créer le répertoire '+s, mtError, [mbOk], 0);
     end;
     FindClose(Rech);
     {$I+}
end;

procedure CopieFichier(Const sourcefilename, targetfilename : string);
var
   S,T : TFileStream;
begin

     S := TFileStream.Create(sourcefilename, fmOpenRead);
     try
        T := TFileStream.Create(targetfilename, fmOpenWrite or fmCreate);

        try
           T.CopyFrom(S, S.Size);
        finally
               T.Free;
        end;
     finally
            S.Free;
     end;
end;

//*******************************************************************************
//*******************************************************************************
//******                                           ******************************
//******  FONCTIONS SUR LES CHAINES DE CARACTERES  ******************************
//******                                           ******************************
//*******************************************************************************
//*******************************************************************************

{ Detecte si les caracteres envoyés en 2e parametre se trouvent dans la chaine
  correspondand au 1er parametre.
  Renvoi TRUE si les caracteres sont present dans la chaîne sinon FALSE}

function EnleverExtension(str : string) : string;
var
   taille, i : integer;
   str_temp : string;

begin

     str_temp := str;

     taille := length(str);

     // On parcours la chaine de droite à gauche
     for i := taille-1 downto 0 do
     begin
          // Si on voit un point
          if Copy(str, i, 1) = '.' then
          begin
                str_temp := Copy(str, 0, i-1);
                break;
          end ;

     end;

     Result := str_temp;

end;

//-------------------------------------------------------------------------------

function PresenceCaracteres(str_chaine_source : string ; chaine_carac : string) : boolean;
var
   i : integer;
   str : string;
   bool_resultat : boolean;
begin

     bool_resultat := false;

     for i := 1 to length(chaine_carac) do
     begin

          if Pos(chaine_carac[i], str_chaine_source) > 0 then
          begin
               bool_resultat := true;
               break;
          end;

     end;

     Result := bool_resultat;
end;

{ Renvoi le nombre de repetitions d'une sous-chaine dans une chaine
  Si la sous-chaine n'est pas presente dans la chaine, la function renvoie 0 }

function NombreRepetitionsChaine(str_chaine_source : string; chaine_a_compter : string ) : integer;
var
   i : integer ;
   chaine : string;
   nb_iterations : integer;
begin

     // On fait une copie
     chaine := str_chaine_source;

     // On ititialise le nb_iterations
     nb_iterations := 0;

     for i := 0 to length(str_chaine_source) do
     begin

          if EnleverChaine(chaine, chaine_a_compter) = 'NULL' then break
          else
          begin
               nb_iterations := nb_iterations + 1;
               chaine := EnleverChaine(chaine, chaine_a_compter);
          end;
     end;

     Result := nb_iterations;

end;

{ Efface une sous-chaine dans une chaine
  Renvoi la chaine apres traitement si déroulement correct
  Si la chaine recherchée n'est pas trouvée elle renvoi 'NULL' }

function EnleverChaine( str_chaine_source : string ; str_chaine_a_effacer : string ) : string ;
var
   ipos : integer;
   str_resultat : string;
begin

     // On cherche la position de la sous-chaine dans la chaine
     ipos := Pos( str_chaine_a_effacer, str_chaine_source);

     if ipos = 0 then str_resultat := 'NULL'
     else
     begin

          // On efface la sous-chaine
          Delete(str_chaine_source, ipos, length(str_chaine_a_effacer));
          str_resultat := str_chaine_source;

     end;

     Result := str_resultat;

end;

{ Cette fonction enleve un certain nombre de carcteres à la fin ou au debut d'1 chaine
  Elle retourne la nouvelle chaine si tout se déroule correctement
  Sinon elle envoi 'NULL' }

function EnleverCaracteres( str_chaine : string; position : integer; nb_car : integer) : string;
var
   str_resultat : string;
   i : integer;

begin

     // Si le nombre de caracteres à effacer est superieur a la longueur de la chaine
     if nb_car >= length(str_chaine) then str_resultat := 'NULL'
     else
     if position = DEBUT then
     begin

          str_resultat := Copy(str_chaine, nb_car + 1, length(str_chaine) - nb_car + 1);

     end
     else if position = FIN then
     begin

          str_resultat := Copy(str_chaine, 0, length(str_chaine) - nb_car);

     end
     else str_resultat := 'NULL';

     Result := str_resultat;

end;

{ Formate une chaîne de caractères
  On formate la chaine 'str' en 'nb_0' caractères
  Si la longueur de 'str' < 'nb_o' alors on ajute des '0' devant 'str'
  sinon on retourne 'NULL'
}
function NumToString(str : string ; nb_0 : integer) : string;
var
   len_str,i : integer;
begin

     len_str := length(str);

     if len_str <= nb_0 then    // si la chaîne est superieure au nombre de cacarteres du format voulu
     begin

          for i := 1 to (nb_0 - len_str) do str := '0' + str;

     end
     else if len_str > nb_0 then str := 'NULL';

     NumToString := str;
end;

//*******************************************************************************
//*******************************************************************************
//**************                             ************************************
//**************  FONCTIONS MATHEMATIQUES    ************************************
//**************                             ************************************
//*******************************************************************************
//*******************************************************************************

function Arrondir( nombre : extended ; nbDecim : extended) : extended;
var
   p10 : extended;

begin

     if nbDecim = 2 then result := round(nombre * 100) / 100
     else
     begin
          p10 := Power(10, nbDecim);
          result := round(nombre * p10) / p10;
     end;

end;

//*******************************************************************************
//*******************************************************************************
//*******************                      **************************************
//*******************   FONCTIONS RS232    **************************************
//*******************                      **************************************
//*******************************************************************************
//*******************************************************************************

// Initialisation de la ligne RS232
procedure InitPort;
begin
DCB.BaudRate:=CBR_9600;
DCB.StopBits:=ONESTOPBIT;
DCB.ByteSize:=8;
DCB.Parity:=NOPARITY;
DCB.DCBLength:=sizeof(DCB);
end;

// Ouverture de la ligne RS232
procedure OpenPort;
var
ComTimeOut:TCommTimeOuts;
begin
if RS232_ouverte=false then begin
   initport;
   Hdl:=CreateFile('COM1',GENERIC_READ or GENERIC_WRITE,0,NIL,OPEN_EXISTING,0,Hdl2);
   SetCommState(Hdl,DCB);                 {Association du Handdle au DCB}
   EscapeCommFunction(Hdl,SETDTR);        {Signal DTR à +12V}
   EscapeCommFunction(Hdl,CLRRTS);        {Signal RTS à -12V}
   ComTimeOut.ReadTotalTimeoutConstant:=10;
   ComTimeOut.ReadTotalTimeoutmultiplier:=1;
   SetCommTimeouts(hdl,ComTimeOut);
   RS232_ouverte:=True;
end;
end;

// Fermeture de la ligne RS232
procedure ClosePort;
begin
CloseHandle(Hdl);
RS232_ouverte:=False;
end;

// Envoie une chaîne de caractères sur la liaison série
function Envoi_RS232( str_envoi : string) : boolean;
var
   c:array[1..30] of char;
   len_valeur : integer;

begin

     // Initilisation de la ligne RS232
     ClosePort;
     InitPort;
     OpenPort;

     // On détermine la taille de la chaîne à envoyer
     len_valeur := length( str_envoi );

     // on convertie la chaine en tableau
     StrPCopy(@c, str_envoi);

     // on écrit sur la ressource Hdl : RS232
     //Envoi_RS232 := WriteFile(Hdl,c,len_valeur,len_valeur,NIL);

end;

//*******************************************************************************
//*******************************************************************************
//**************************                      *******************************
//**************************  FONCTIONS SYSTEME   *******************************
//**************************                      *******************************
//*******************************************************************************
//*******************************************************************************

{ Simule un click de souris à un endroit donné en parametres.
  bouton represente le bouton a cliquer : CLICK_DROIT , CLICK_GAUCHE , CLICK_MILIEU.
  x , y : representent les coordonnées du click. Si x = y = NULL = 0 alors le click
  s'effectue a l'endroit ou se trouve le curseur}

procedure SimuClick(bouton : integer ; x : DWord ; y : DWord);
var
   x_temp, y_temp : DWord;
begin

     Case bouton of

     MILIEU : begin
                   mouse_event(MOUSEEVENTF_MIDDLEDOWN,x,y,0,0);
                   mouse_event(MOUSEEVENTF_MIDDLEUP,x,y,0,0);
              end;
     DROIT  : begin
                   mouse_event(MOUSEEVENTF_RIGHTDOWN,x,y,0,0);
                   mouse_event(MOUSEEVENTF_RIGHTUP,x,y,0,0);
              end;
     GAUCHE : begin
                   mouse_event(MOUSEEVENTF_LEFTDOWN,x,y,0,0);
                   mouse_event(MOUSEEVENTF_LEFTUP,x,y,0,0);
              end;

     end;
end;

//*******************************************************************************
//*******************************************************************************
//**************************                     ********************************
//**************************  FONCTIONS DIVERS   ********************************
//**************************                     ********************************
//*******************************************************************************
//*******************************************************************************

// Renvoie une chaîne de caractères cryptée en modifiant la chine passée en paramettre
// A titre indicatif 'a' = 8.91
function Crypter(str_pass_original : string ) : string;
var
   i ,iVal: integer;
   str : string;

begin

     str := '';
     for i := 1 to length(str_pass_original) do str := str + floattostr(Arrondir((Ord(str_pass_original[i]) + 1) / 11 , 2));
     result := str;

end;

// Tempo en millisecondes
procedure TEMPO(temps:longint);
var
   heur,minute,seconde,msec:Word;
   DepartEnSec,heureEnSec:longint;
begin
     DecodeTime(Time,heur,minute,seconde,msec);
     DepartEnSec:=heur*3600000+minute*60000+seconde*1000+msec;
     DecodeTime(Time,heur,minute,seconde,msec);
     heureEnSec:=heur*3600000+minute*60000+seconde*1000+msec;
     while heureEnSec - DepartEnSec < temps do begin
           DecodeTime(Time,heur,minute,seconde,msec);
           heureEnSec:=heur*3600000+minute*60000+seconde*1000+msec;
     end;
end;

end.

A voir également

Ajouter un commentaire Commentaire
radioham
Messages postés
39
Date d'inscription
mardi 2 septembre 2003
Statut
Membre
Dernière intervention
7 décembre 2006
7 juil. 2006 à 09:10
Bonjour, Débutant en Delphi, je ne saurais noter cela, mais j'en remercie vivement son auteur d'avoir guidé mes premiers pas en pascal.
Radioham
S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (bundy318)